diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index e2e89577c75..c981ba9e4d6 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -1,7 +1,5 @@ # Later lines in the file take precedence. -* @mshinwell - .github/ @mshinwell .github/CODEOWNERS @mshinwell @lpw25 .gitignore @mshinwell diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 265eda5c21a..326d250b116 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -14,9 +14,11 @@ jobs: os: ubuntu-latest ocamlparam: '' check_arch: true + use_runtime: d + ocamlrunparam: "v=0,V=1" - - name: closure_cfg_local - config: --enable-middle-end=closure --enable-stack-allocation + - name: closure_cfg + config: --enable-middle-end=closure --enable-poll-insertion os: ubuntu-latest ocamlparam: _,ocamlcfg=1 @@ -26,12 +28,12 @@ jobs: ocamlparam: '' - name: flambda1_frame_pointers - config: --enable-middle-end=flambda --enable-frame-pointers + config: --enable-middle-end=flambda --enable-frame-pointers --enable-poll-insertion os: ubuntu-latest ocamlparam: '' - - name: flambda1_cfg_local - config: --enable-middle-end=flambda --enable-stack-allocation + - name: flambda1_cfg + config: --enable-middle-end=flambda --enable-poll-insertion os: ubuntu-latest ocamlparam: _,ocamlcfg=1 @@ -39,14 +41,16 @@ jobs: config: --enable-middle-end=flambda2 os: ubuntu-latest ocamlparam: '' + use_runtime: d + ocamlrunparam: "v=0,V=1" - name: flambda2_frame_pointers - config: --enable-middle-end=flambda2 --enable-frame-pointers + config: --enable-middle-end=flambda2 --enable-frame-pointers --enable-poll-insertion os: ubuntu-latest ocamlparam: '' - - name: flambda2_cfg_local - config: --enable-middle-end=flambda2 --enable-stack-allocation + - name: flambda2_cfg + config: --enable-middle-end=flambda2 os: ubuntu-latest ocamlparam: _,ocamlcfg=1 @@ -65,7 +69,7 @@ jobs: - name: build_upstream-32-bit config: --enable-middle-end=closure CC="gcc -m32" AS="as --32" ASPP="gcc -m32 -c" -host i386-linux PARTIALLD="ld -r -melf_i386" - os: ubuntu-latest + os: ubuntu-20.04 env: J: "3" @@ -82,45 +86,45 @@ jobs: with: path: 'flambda_backend' - - name: Cache OCaml 4.12 and dune + - name: Cache OCaml 4.14 and dune uses: actions/cache@v1 id: cache with: - path: ${{ github.workspace }}/ocaml-412/_install - key: ${{ matrix.os }}-cache-ocaml-412-dune-341 + path: ${{ github.workspace }}/ocaml-414/_install + key: ${{ matrix.os }}-cache-ocaml-414-dune-361 - - name: Checkout OCaml 4.12 + - name: Checkout OCaml 4.14 uses: actions/checkout@master if: steps.cache.outputs.cache-hit != 'true' with: repository: 'ocaml/ocaml' - path: 'ocaml-412' - ref: '4.12' + path: 'ocaml-414' + ref: '4.14' - - name: Build OCaml 4.12 + - name: Build OCaml 4.14 if: steps.cache.outputs.cache-hit != 'true' - working-directory: ocaml-412 + working-directory: ocaml-414 run: | - ./configure --prefix=$GITHUB_WORKSPACE/ocaml-412/_install + ./configure --prefix=$GITHUB_WORKSPACE/ocaml-414/_install make -j $J world.opt make install # Remove unneeded parts to shrink cache file - rm -rf $GITHUB_WORKSPACE/ocaml-412/_install/{lib/ocaml/compiler-libs,lib/ocaml/expunge,bin/*.byte} + rm -rf $GITHUB_WORKSPACE/ocaml-414/_install/{lib/ocaml/compiler-libs,lib/ocaml/expunge,bin/*.byte} - name: Checkout dune github repo uses: actions/checkout@master if: steps.cache.outputs.cache-hit != 'true' with: repository: 'ocaml/dune' - ref: '3.4.1' + ref: '3.6.1' path: 'dune' - name: Build dune working-directory: dune if: steps.cache.outputs.cache-hit != 'true' run: | - PATH=$GITHUB_WORKSPACE/ocaml-412/_install/bin:$PATH make release - cp dune.exe $GITHUB_WORKSPACE/ocaml-412/_install/bin/dune + PATH=$GITHUB_WORKSPACE/ocaml-414/_install/bin:$PATH make release + cp _boot/dune.exe $GITHUB_WORKSPACE/ocaml-414/_install/bin/dune - name: Install GNU parallel if: matrix.os == 'macos-latest' @@ -136,20 +140,22 @@ jobs: autoconf ./configure \ --prefix=$GITHUB_WORKSPACE/_install \ - --with-dune=$GITHUB_WORKSPACE/ocaml-412/_install/bin/dune \ + --with-dune=$GITHUB_WORKSPACE/ocaml-414/_install/bin/dune \ ${{ matrix.config }} - name: Build, install and test Flambda backend working-directory: flambda_backend run: | if [ $run_testsuite = true ]; then target=ci; else target=compiler; fi - export PATH=$GITHUB_WORKSPACE/ocaml-412/_install/bin:$PATH + export PATH=$GITHUB_WORKSPACE/ocaml-414/_install/bin:$PATH if [ $build_upstream = true ]; then make -j$J build_and_test_upstream; else make $target; fi env: BUILD_OCAMLPARAM: ${{ matrix.ocamlparam }} + OCAMLRUNPARAM: ${{ matrix.ocamlrunparam }} + USE_RUNTIME: ${{ matrix.use_runtime }} - name: Check other architectures working-directory: flambda_backend if: matrix.check_arch == true run: | - PATH=$GITHUB_WORKSPACE/ocaml-412/_install/bin:$PATH make check_all_arches + PATH=$GITHUB_WORKSPACE/ocaml-414/_install/bin:$PATH make check_all_arches diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml index 1d7f4ad3374..bbdebbb1134 100644 --- a/.github/workflows/coverage.yml +++ b/.github/workflows/coverage.yml @@ -23,10 +23,10 @@ jobs: path: 'flambda_backend' # This adds a switch at $GITHUB_WORKSPACE/_opam - - name: Set up OCaml 4.12 + - name: Set up OCaml 4.14 uses: ocaml/setup-ocaml@v2 with: - ocaml-compiler: 4.12 + ocaml-compiler: 4.14 opam-pin: false opam-depext: false @@ -35,19 +35,12 @@ jobs: id: cache with: path: ${{ github.workspace }}/_opam - key: ${{ matrix.os }}-cache-ocaml-412-dune-2.9.1-g7606d586 - - - name: Build Dune - if: steps.cache.outputs.cache-hit != 'true' - run: | - opam pin dune --yes \ - git+https://github.com/ocaml-flambda/dune#special_dune + key: ${{ matrix.os }}-cache-ocaml-414-dune-2.9.1-g7606d586 - name: Build bisect_ppx if: steps.cache.outputs.cache-hit != 'true' run: | - # bisect_ppx fails to build with current ppxlib - opam pin ppxlib 0.23.0 --yes + opam pin ppxlib 0.25.1 opam pin bisect_ppx --yes \ git+https://github.com/lukemaurer/bisect_ppx#html-report-collate-fix diff --git a/.github/workflows/ocamlformat.yml b/.github/workflows/ocamlformat.yml index edb11b186d2..865a9eb3518 100644 --- a/.github/workflows/ocamlformat.yml +++ b/.github/workflows/ocamlformat.yml @@ -10,7 +10,7 @@ jobs: matrix: os: [ubuntu-latest] ocaml-compiler: - - "4.12.0" + - "4.14.0" steps: - name: Checkout the Flambda backend repo @@ -26,8 +26,8 @@ jobs: - name: Install a recent version of re run: opam install 're>=1.10.0' - - name: Install ocamlformat 0.19.0 - run: opam pin -y ocamlformat 0.19.0 + - name: Install ocamlformat 0.24.1 + run: opam pin -y ocamlformat 0.24.1 - name: autoconf working-directory: flambda_backend diff --git a/.vscode/settings.json b/.vscode/settings.json index 29f27d9c5a8..4574c8a26e1 100644 --- a/.vscode/settings.json +++ b/.vscode/settings.json @@ -1,6 +1,6 @@ { "ocaml.sandbox": { "kind": "opam", - "switch": "4.12.0" + "switch": "4.14.1" } } diff --git a/.vscode/tasks.json b/.vscode/tasks.json index 6982237e9f0..79ff950d003 100644 --- a/.vscode/tasks.json +++ b/.vscode/tasks.json @@ -4,7 +4,7 @@ { "label": "Build & install Flambda backend", "type": "shell", - "command": "opam exec --switch=4.11.1 make install", + "command": "opam exec --switch=4.14.0 make install", "group": "build", "problemMatcher": [ "$ocamlc" diff --git a/HACKING.md b/HACKING.md index eb0305c57e9..27241559cb0 100644 --- a/HACKING.md +++ b/HACKING.md @@ -3,22 +3,23 @@ This page is intended to keep track of useful information for people who want to modify the Flambda backend. Jump to: - - [Branches, pull requests, etc.](#branches-pull-requests-etc) - - [Upstream subtree](#upstream-subtree) - - [Code formatting](#code-formatting) - - [Rebuilding during dev work](#rebuilding-during-dev-work) - - [Running tests](#running-tests) - - [Running only part of the upstream testsuite](#running-only-part-of-the-upstream-testsuite) - - [Running tests with coverage analysis](#running-tests-with-coverage-analysis) - - [Running the compiler produced by "make hacking" on an example without the stdlib](#running-the-compiler-produced-by-make-hacking-on-an-example-without-the-stdlib) - - [Getting the compilation command for a stdlib file](#getting-the-compilation-command-for-a-stdlib-file) - - [Bootstrapping the ocaml subtree](#bootstrapping-the-ocaml-subtree) - - [Testing the compiler built locally with OPAM](#testing-the-compiler-built-locally-with-opam) - - [Pulling changes onto a release branch](#pulling-changes-onto-a-release-branch) - - [Rebasing to a new major version of the upstream compiler](#rebasing-to-a-new-major-version-of-the-upstream-compiler) - - [How to add a new intrinsic to the compiler](#how-to-add-a-new-intrinsic-to-the-compiler) - - [How to add a new command line option](#how-to-add-a-new-command-line-option) - - [Installation tree comparison script](#installation-tree-comparison-script) +- [Branches, pull requests, etc.](#branches-pull-requests-etc) +- [Upstream subtree](#upstream-subtree) +- [Code formatting](#code-formatting) +- [Rebuilding during dev work](#rebuilding-during-dev-work) +- [Updating magic numbers](#updating-magic-numbers) +- [Running tests](#running-tests) +- [Running only part of the upstream testsuite](#running-only-part-of-the-upstream-testsuite) +- [Running tests with coverage analysis](#running-tests-with-coverage-analysis) +- [Running the compiler produced by "make hacking" on an example without the stdlib](#running-the-compiler-produced-by-make-hacking-on-an-example-without-the-stdlib) +- [Getting the compilation command for a stdlib file](#getting-the-compilation-command-for-a-stdlib-file) +- [Bootstrapping the ocaml subtree](#bootstrapping-the-ocaml-subtree) +- [Testing the compiler built locally with OPAM](#testing-the-compiler-built-locally-with-opam) +- [Pulling changes onto a release branch](#pulling-changes-onto-a-release-branch) +- [Rebasing to a new major version of the upstream compiler](#rebasing-to-a-new-major-version-of-the-upstream-compiler) +- [How to add a new intrinsic to the compiler](#how-to-add-a-new-intrinsic-to-the-compiler) +- [How to add a new command line option](#how-to-add-a-new-command-line-option) +- [Installation tree comparison script](#installation-tree-comparison-script) ## Branches, pull requests, etc. @@ -89,7 +90,7 @@ Depending on the initial changes, it might be necessary to do this multiple time ## Rebuilding during dev work To rebuild after making changes, you can just type `make`. You need to -have a working OCaml 4.12 compiler on your PATH before doing so, +have a working OCaml 4.14 compiler on your PATH before doing so, e.g. installed via OPAM. There is a special target `make hacking` which starts Dune in polling mode. The rebuild @@ -112,6 +113,22 @@ Any changes in `ocaml/asmcomp` and `ocaml/middle_end` directories should also be applied to the corresponding directories `backend` and `middle_end`. +## Updating magic numbers + +Start from a completely clean tree. Then change into the `ocaml` subdirectory +and proceed as follows: +``` +./configure +make coldstart +make coreall +``` +Then edit `runtime/exec.h` and `utils/config.mlp` to bump the numbers. Then: +``` +make coreall +make bootstrap +``` +and commit the result. + ## Running tests Prior to `make install` you can do: @@ -189,58 +206,78 @@ be advisable to clean the whole tree again. It is possible to create a OPAM switch with the Flambda backend compiler. -First, you'll need to install the `opam-custom-install` plugin. See -[here](https://gitlab.ocamlpro.com/louis/opam-custom-install) for instructions. -(This can be done in any OPAM switch, e.g. a standard 4.12.0 switch.) +The first step is to choose where to put the switch. One possibility is to use a +local switch at the root of the tree, in which case the prefix will be +`${flambda-backend-root-dir}/_opam`, but it's also possible to use a local switch elsewhere or +a global switch. For a global switch named `flambda-backend`, the prefix will be +`$(opam var root)/flambda-backend`. -Then you'll need to create an empty switch. The recommended way is to use a -local switch in the Flambda backend directory: +The Flambda backend must then be configured with this switch as prefix: ```shell -opam switch create . --empty +./configure --prefix=${opam_switch_prefix} ... ``` -(A global switch can also be used, in which case the `--prefix` argument -to `configure` given below needs to point at the switch directory under the OPAM root. -It is also necessary to `opam switch` to the new switch and then update the current -environment with `opam env` after the above `opam switch create` command.) +Note that if the Flambda backend tree is already configured, it should be cleaned +thoroughly (e.g. `git clean -dfX`) before reconfiguring with a different prefix. + +Then build the compiler with the command `make _install` (this is the default +target plus some setup in preparation for installation). As usual when building, +a 4.14 compiler (and dune) need to be in the path. + +Now the build part is done, we don't need to stay in the build environment +anymore; the switch creation will likely replace it if your terminal is setup +to automatically follow the active opam switch. -The Flambda backend must also be configured with this switch as prefix -(this can be done before actually creating the switch, the directory only -needs to exist during the installation step): +The next step is to create the switch if it wasn't done already (if you already +had created a switch from a previous attempt, you will need to remove it first): ```shell -./configure --prefix=/path/to/cwd/_opam ... +# For a local switch: +opam switch create . --empty --repositories=flambda2=git+https://github.com/ocaml-flambda/flambda2-opam.git,default +# For a global switch: +opam switch create flambda-backend --empty --repositories=flambda2=git+https://github.com/ocaml-flambda/flambda2-opam.git,default ``` -Note that if the Flambda backend tree is already configured, it should be cleaned -thoroughly (e.g. `git clean -dfX`) before reconfiguring with a different prefix. - -Then build the compiler normally (`make`). -Once that is done, we're ready to install the compiler: +Then we can install the compiler. The recommended way is to use the `opam-custom-install` +plugin. See [here](https://gitlab.ocamlpro.com/louis/opam-custom-install) +for instructions. The plugin can be installed in any existing OPAM switch, +for example a 4.14 switch used for building. Once installed, the plugin will be +available whatever the current active switch is. +Once the plugin is installed, we can use it to install the compiler: ```shell -opam custom-install ocaml-variants.4.12.0+flambda2+trunk -- make install +opam custom-install ocaml-variants.4.14.0+flambda2 -- make -C ${flambda-backend-root-dir} install_for_opam ``` +The `-C ${flambda-backend-dir}` part can be omitted if we're still in the build directory. -The exact version doesn't matter that much, but the version number should -match the one in the Flambda backend tree. (The name of the package given -here is independent of the name of the switch.) +Note that due to issues with some versions of the custom-install plugin, +it is recommended to run the command `opam reinstall --forget-pending` after +every use of `opam custom-install`, otherwise any subsequent `opam` command +tries to rebuild the compiler from scratch. -To finish the installation, `opam install ocaml.4.12.0` will install the remaining +To finish the installation, `opam install ocaml.4.14.0` will install the remaining auxiliary packages necessary for a regular switch. After that, normal opam packages can be installed the usual way. -It is also possible to update the compiler after hacking: +It is also possible to update the compiler after hacking, by running the +`opam custom-install` command again. It also accepts a `-n` flag to skip +recompilation of the packages which depend on the compiler, which can be useful +when the output of the compiler is unchanged apart from extra logging. + +As `opam-custom-install` is still experimental, it can sometimes be hard to install. +In this case, it is possible to use the more fragile `opam install --fake` command: + ```shell -# This will reinstall the compiler, and recompile all packages -# that depend on the compiler -opam custom-install ocaml-variants -- make install -# This skips recompilation of other packages, -# particularly useful for debugging -opam custom-install --no-recompilations ocaml-variants -- make install +opam install --fake ocaml-variants.4.14.0+flambda2 +make -C ${flambda-backend-root-dir} install_for_opam ``` +The main drawback of this approach is that there isn't any way to cleanup an +installation properly without deleting the whole switch; if the set of installed +files change between one `make install_for_opam` command and the next, strange +bugs might appear. + ## Pulling changes onto a release branch This should only be done with the approval of the person responsible for the next release. diff --git a/Makefile b/Makefile index 7ddff0d0c9d..5e8676e690f 100644 --- a/Makefile +++ b/Makefile @@ -93,11 +93,18 @@ fmt: $$(find backend/debug \ \( -name "*.ml" -or -name "*.mli" \)) ocamlformat -i backend/cmm_helpers.ml{,i} + ocamlformat -i backend/cmm_builtins.ml{,i} ocamlformat -i backend/checkmach.ml{,i} ocamlformat -i tools/merge_archives.ml ocamlformat -i \ $$(find backend/debug/dwarf \ \( -name "*.ml" -or -name "*.mli" \)) + ocamlformat -i \ + $$(find utils \ + \( -name "*.ml" -or -name "*.mli" \)) + ocamlformat -i \ + $$(find ocaml/utils \ + \( -name "*.ml" -or -name "*.mli" \)) .PHONY: check-fmt check-fmt: @@ -108,8 +115,11 @@ check-fmt: [ "$$(git status --porcelain backend/asm_targets)" != "" ] || \ [ "$$(git status --porcelain backend/debug)" != "" ] || \ [ "$$(git status --porcelain backend/cmm_helpers.ml{,i})" != "" ] || \ + [ "$$(git status --porcelain backend/cmm_builtins.ml{,i})" != "" ] || \ [ "$$(git status --porcelain backend/checkmach.ml{,i})" != "" ] || \ - [ "$$(git status --porcelain tools/merge_archives.ml)" != "" ]; then \ + [ "$$(git status --porcelain tools/merge_archives.ml)" != "" ] || \ + [ "$$(git status --porcelain ocaml/utils)" != "" ] || \ + [ "$$(git status --porcelain utils)" != "" ]; then \ echo; \ echo "Tree must be clean before running 'make check-fmt'"; \ exit 1; \ @@ -122,8 +132,11 @@ check-fmt: [ "$$(git diff backend/asm_targets)" != "" ] || \ [ "$$(git diff backend/debug)" != "" ] || \ [ "$$(git diff backend/cmm_helpers.ml{,i})" != "" ] || \ + [ "$$(git diff backend/cmm_builtins.ml{,i})" != "" ] || \ [ "$$(git diff backend/checkmach.ml{,i})" != "" ] || \ - [ "$$(git diff tools/merge_archives.ml)" != "" ]; then \ + [ "$$(git diff tools/merge_archives.ml)" != "" ] || \ + [ "$$(git diff ocaml/utils)" != "" ] || \ + [ "$$(git diff utils)" != "" ]; then \ echo; \ echo "The following code was not formatted correctly:"; \ echo "(the + side of the diff is how it should be formatted)"; \ @@ -154,6 +167,10 @@ build_upstream: ocaml/config.status install_upstream: build_upstream (cd _build_upstream && $(MAKE) install) cp ocaml/VERSION $(prefix)/lib/ocaml/ + ln -s ocamltoplevel.cmxa \ + $(prefix)/lib/ocaml/compiler-libs/ocamlopttoplevel.cmxa + ln -s ocamltoplevel.a \ + $(prefix)/lib/ocaml/compiler-libs/ocamlopttoplevel.a .PHONY: build_and_test_upstream build_and_test_upstream: build_upstream diff --git a/README.md b/README.md index 668fa72da9d..4ccbf068f19 100644 --- a/README.md +++ b/README.md @@ -4,7 +4,7 @@ This repository is for more experimental work, of production quality, on the mid and backend of the OCaml compiler. This is also the home of the Flambda 2 optimiser. -The Flambda backend is currently based on OCaml 4.12.0. +The Flambda backend is currently based on OCaml 4.14.0. The following gives basic instructions for getting set up. Please see [`HACKING.md`](HACKING.md) for more detailed instructions if you want to develop in this repo. @@ -18,7 +18,7 @@ Only currently tested on Linux/x86-64 and macOS/x86-64. One-time setup: ``` -$ opam switch 4.12.0 # or "opam switch create 4.12.0" if you haven't got that switch already +$ opam switch 4.14.0 # or "opam switch create 4.14.0" if you haven't got that switch already $ eval $(opam env) $ opam install dune ``` @@ -38,7 +38,7 @@ The Flambda backend tree has to be configured before building. The configure sc in; you have to run `autoconf`. For example: ``` $ autoconf -$ ./configure --prefix=/path/to/install/dir --enable-middle-end=closure --with-dune=$DUNE_DIR/dune.exe +$ ./configure --prefix=/path/to/install/dir --enable-middle-end=closure ``` You can also specify `--enable-middle-end=flambda` or `--enable-middle-end=flambda2`. (The Flambda 2 compiler is not yet ready for production use.) diff --git a/backend/.ocamlformat b/backend/.ocamlformat index 3da0d003a11..a6f157798c0 100644 --- a/backend/.ocamlformat +++ b/backend/.ocamlformat @@ -7,10 +7,11 @@ cases-exp-indent=2 doc-comments=before dock-collection-brackets=false if-then-else=keyword-first +module-item-spacing=sparse parens-tuple=multi-line-only sequence-blank-line=compact space-around-lists=false space-around-variants=false type-decl=sparse wrap-comments=true -version=0.19.0 +version=0.24.1 diff --git a/backend/.ocamlformat-enable b/backend/.ocamlformat-enable index 601cbd702f1..1da586a5145 100644 --- a/backend/.ocamlformat-enable +++ b/backend/.ocamlformat-enable @@ -1,5 +1,7 @@ cmm_helpers.ml cmm_helpers.mli +cmm_builtins.ml +cmm_builtins.mli internal_assembler/*.ml internal_assembler/*.mli checkmach.ml diff --git a/backend/CSEgen.ml b/backend/CSEgen.ml index 44b7af3ea6d..1b0f9fc06cf 100644 --- a/backend/CSEgen.ml +++ b/backend/CSEgen.ml @@ -239,12 +239,14 @@ method class_of_operation op = | Istackoffset _ -> Op_other | Iload(_,_,mut) -> Op_load mut | Istore(_,_,asg) -> Op_store asg - | Ialloc _ -> assert false (* treated specially *) + | Ialloc _ | Ipoll _ -> assert false (* treated specially *) | Iintop(Icheckbound) -> Op_checkbound | Iintop _ -> Op_pure | Iintop_imm(Icheckbound, _) -> Op_checkbound | Iintop_imm(_, _) -> Op_pure + | Iintop_atomic _ -> Op_store true | Icompf _ + | Icsel _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf | Ifloatofint | Iintoffloat | Ivalueofint | Iintofvalue -> Op_pure | Ispecific _ -> Op_other @@ -295,14 +297,14 @@ method private cse n i k = | Iop Iopaque -> (* Assume arbitrary side effects from Iopaque *) self#cse empty_numbering i.next (fun next -> k { i with next; }) - | Iop (Ialloc _) -> + | Iop (Ialloc _) | Iop (Ipoll _) -> (* For allocations, we must avoid extending the live range of a pseudoregister across the allocation if this pseudoreg is a derived heap pointer (a pointer into the heap that does not point to the beginning of a Caml block). PR#6484 is an example of this situation. Such pseudoregs have type [Addr]. Pseudoregs with types other than [Addr] can be kept. - Moreover, allocation can trigger the asynchronous execution + Moreover, allocations and polls can trigger the asynchronous execution of arbitrary Caml code (finalizer, signal handler, context switch), which can contain non-initializing stores. Hence, all equations over mutable loads must be removed. *) diff --git a/backend/amd64/CSE.ml b/backend/amd64/CSE.ml index cd91d8ed973..9d5587a19d2 100644 --- a/backend/amd64/CSE.ml +++ b/backend/amd64/CSE.ml @@ -43,13 +43,14 @@ method! class_of_operation op = end | Imove | Ispill | Ireload | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf | Icompf _ + | Icsel _ | Ifloatofint | Iintoffloat | Ivalueofint | Iintofvalue | Iconst_int _ | Iconst_float _ | Iconst_symbol _ | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ | Iextcall _ | Istackoffset _ | Iload _ | Istore _ | Ialloc _ - | Iintop _ | Iintop_imm _ + | Iintop _ | Iintop_imm _ | Iintop_atomic _ | Iname_for_debugger _ | Iprobe _ | Iprobe_is_enabled _ | Iopaque - | Ibeginregion | Iendregion + | Ibeginregion | Iendregion | Ipoll _ -> super#class_of_operation op end diff --git a/backend/amd64/cfg_stack_operands.ml b/backend/amd64/cfg_stack_operands.ml index a35b3e56705..9d25827bc34 100644 --- a/backend/amd64/cfg_stack_operands.ml +++ b/backend/amd64/cfg_stack_operands.ml @@ -1,3 +1,5 @@ +# 2 "backend/amd64/cfg_stack_operands.ml" + [@@@ocaml.warning "+a-4-30-40-41-42"] open! Cfg_regalloc_utils @@ -152,10 +154,6 @@ let binary_operation let basic (map : spilled_map) (instr : Cfg.basic Cfg.instruction) = begin match instr.desc with - | Call (P (Checkbound { immediate = None; } )) -> - binary_operation map instr No_result - | Call (P (Checkbound { immediate = Some _; } )) -> - may_use_stack_operand_for_only_argument map instr ~has_result:false | Op (Addf | Subf | Mulf | Divf) | Op (Specific (Ifloat_min | Ifloat_max | Icrc32q)) -> may_use_stack_operand_for_second_argument map instr @@ -185,13 +183,13 @@ let basic (map : spilled_map) (instr : Cfg.basic Cfg.instruction) = may_use_stack_operand_for_result map instr ~num_args:2 | Op(Intop_imm((Iadd | Isub | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr), _)) -> may_use_stack_operand_for_result map instr ~num_args:1 - | Op (Probe _) -> - may_use_stack_operands_everywhere map instr + | Op (Csel _) (* CR gyorsh: optimize *) | Op (Specific (Ilfence | Isfence | Imfence)) | Op (Intop(Imulh _ | Imul | Idiv | Imod)) | Op (Intop_imm ((Imulh _ | Imul | Idiv | Imod), _)) | Op (Specific (Irdtsc | Irdpmc)) | Op (Intop (Ipopcnt | Iclz _| Ictz _)) + | Op (Intop_atomic _) | Op (Move | Spill | Reload | Negf | Absf | Const_float _ | Compf _ | Stackoffset _ | Load _ | Store _ | Name_for_debugger _ | Probe_is_enabled _ | Valueofint | Intofvalue | Opaque | Begin_region | End_region ) @@ -201,7 +199,6 @@ let basic (map : spilled_map) (instr : Cfg.basic Cfg.instruction) = | Ipause | Iprefetch _ | Ibswap _| Ifloatsqrtf _)) - | Call (P (External _ | Alloc _) | F (Indirect | Direct _)) | Reloadretaddr | Pushtrap _ | Poptrap @@ -210,7 +207,7 @@ let basic (map : spilled_map) (instr : Cfg.basic Cfg.instruction) = May_still_have_spilled_registers | Op (Intop Icheckbound) | Op (Intop_imm ((Ipopcnt | Iclz _ | Ictz _ | Icheckbound), _)) -> - (* should no happen *) + (* should not happen *) fatal "unexpected instruction" end @@ -218,12 +215,13 @@ let terminator (map : spilled_map) (term : Cfg.terminator Cfg.instruction) = ignore map; match (term : Cfg.terminator Cfg.instruction).desc with | Never -> fatal "unexpected terminator" - - | Int_test { lt = _; eq = _; gt =_; is_signed = _; imm = None; } -> + | Int_test { lt = _; eq = _; gt =_; is_signed = _; imm = None; } + | Prim {op = Checkbound { immediate = None; }; _} -> binary_operation map term No_result | Int_test { lt = _; eq = _; gt =_; is_signed = _; imm = Some _; } | Parity_test { ifso = _; ifnot = _; } - | Truth_test { ifso = _; ifnot = _; } -> + | Truth_test { ifso = _; ifnot = _; } + | Prim {op = Checkbound { immediate = Some _; }; _} -> may_use_stack_operand_for_only_argument ~has_result:false map term | Float_test _ -> (* CR-someday xclerc for xclerc: this could be optimized, but the representation @@ -236,7 +234,14 @@ let terminator (map : spilled_map) (term : Cfg.terminator Cfg.instruction) = | Return | Raise _ | Switch _ - | Tailcall _ - | Call_no_return _ -> + | Tailcall_self _ + | Tailcall_func _ + | Call_no_return _ + | Poll_and_jump _ + | Prim {op = External _ | Alloc _; _ } | Call {op = Indirect | Direct _; _} -> (* no rewrite *) May_still_have_spilled_registers + | Prim {op = Probe _; _} -> + may_use_stack_operands_everywhere map term + | Specific_can_raise _ -> + fatal "no instructions specific for this architecture can raise" diff --git a/backend/amd64/emit.mlp b/backend/amd64/emit.mlp index 2d43e7a54e3..0f61f109c9d 100644 --- a/backend/amd64/emit.mlp +++ b/backend/amd64/emit.mlp @@ -361,6 +361,52 @@ let emit_call_bound_errors () = emit_call "caml_ml_array_bound_error" end +(* Record function info for dwarf and emit label if needed. *) +let emit_dwarf_for_fundecl fun_name fun_dbg = + match Emitaux.Dwarf_helpers.record_dwarf_for_fundecl ~fun_name fun_dbg with + | None -> () + | Some label -> def_label label + +let build_asm_directives () : (module Asm_targets.Asm_directives_intf.S) = ( + module Asm_targets.Asm_directives.Make(struct + + let emit_line str = X86_dsl.D.comment str + + let get_file_num file_name = + Emitaux.get_file_num ~file_emitter:X86_dsl.D.file file_name + + let debugging_comments_in_asm_files = + !Flambda_backend_flags.dasm_comments + + module D = struct + open X86_ast + + include X86_dsl.D + + type data_type = + | NONE | DWORD | QWORD + + type nonrec constant = constant + let const_int64 num = Const num + let const_label str = ConstLabel str + let const_add c1 c2 = ConstAdd (c1, c2) + let const_sub c1 c2 = ConstSub (c1, c2) + + let label ?data_type str = + let typ = + Option.map + (function + | NONE -> X86_ast.NONE + | DWORD -> X86_ast.DWORD + | QWORD -> X86_ast.QWORD) + data_type + in + label ?typ str + end + end) + ) + + (* Names for instructions *) let instr_for_intop = function @@ -412,7 +458,7 @@ let output_test_zero arg = (* Output a floating-point compare and branch *) -let emit_float_test cmp i lbl = +let emit_float_test cmp i ~(taken:X86_ast.condition -> unit) = (* Effect of comisd on flags and conditional branches: ZF PF CF cond. branches taken unordered 1 1 1 je, jb, jbe, jp @@ -425,44 +471,70 @@ let emit_float_test cmp i lbl = match cmp with | CFeq when arg i 1 = arg i 0 -> I.ucomisd (arg i 1) (arg i 0); - I.j NP lbl + taken NP | CFeq -> let next = new_label() in I.ucomisd (arg i 1) (arg i 0); - I.jp (label next); (* skip if unordered *) - I.je lbl; (* branch taken if x=y *) + I.jp (label next); (* skip if unordered *) + taken E; (* branch taken if x=y *) def_label next | CFneq when arg i 1 = arg i 0 -> I.ucomisd (arg i 1) (arg i 0); - I.jp lbl + taken P | CFneq -> I.ucomisd (arg i 1) (arg i 0); - I.jp lbl; (* branch taken if unordered *) - I.jne lbl (* branch taken if xy *) + taken P; (* branch taken if unordered *) + taken NE (* branch taken if xy *) | CFlt -> I.comisd (arg i 0) (arg i 1); - I.ja lbl (* branch taken if y>x i.e. xx i.e. x I.comisd (arg i 0) (arg i 1); - I.jbe lbl (* taken if unordered or y<=x i.e. !(x I.comisd (arg i 0) (arg i 1);(* swap compare *) - I.jae lbl (* branch taken if y>=x i.e. x<=y *) + taken AE (* branch taken if y>=x i.e. x<=y *) | CFnle -> I.comisd (arg i 0) (arg i 1);(* swap compare *) - I.jb lbl (* taken if unordered or y I.comisd (arg i 1) (arg i 0); - I.ja lbl (* branch taken if x>y *) + taken A (* branch taken if x>y *) | CFngt -> I.comisd (arg i 1) (arg i 0); - I.jbe lbl (* taken if unordered or x<=y i.e. !(x>y) *) + taken BE (* taken if unordered or x<=y i.e. !(x>y) *) | CFge -> I.comisd (arg i 1) (arg i 0);(* swap compare *) - I.jae lbl (* branch taken if x>=y *) + taken AE (* branch taken if x>=y *) | CFnge -> I.comisd (arg i 1) (arg i 0);(* swap compare *) - I.jb lbl (* taken if unordered or x=y) *) + taken B (* taken if unordered or x=y) *) + +let emit_test i ~(taken:X86_ast.condition -> unit) = function + | Itruetest -> + output_test_zero i.arg.(0); + taken NE + | Ifalsetest -> + output_test_zero i.arg.(0); + taken E + | Iinttest cmp -> + I.cmp (arg i 1) (arg i 0); + taken (cond cmp) + | Iinttest_imm((Isigned Ceq | Isigned Cne | + Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> + output_test_zero i.arg.(0); + taken (cond cmp) + | Iinttest_imm(cmp, n) -> + I.cmp (int n) (arg i 0); + taken (cond cmp) + | Ifloattest cmp -> + emit_float_test cmp i ~taken + | Ioddtest -> + I.test (int 1) (arg8 i 0); + taken NE + | Ieventest -> + I.test (int 1) (arg8 i 0); + taken E (* Deallocate the stack frame before a return or tail call *) @@ -499,13 +571,16 @@ let emit_float_constant f lbl = _label (emit_label lbl); D.qword (Const f) -let emit_global_label s = - let lbl = Cmm_helpers.make_symbol s in +let emit_global_label_for_symbol lbl = add_def_symbol lbl; let lbl = emit_symbol lbl in D.global lbl; _label lbl +let emit_global_label s = + let lbl = Cmm_helpers.make_symbol s in + emit_global_label_for_symbol lbl + let move (src : Reg.t) (dst : Reg.t) = if src.loc <> dst.loc then begin match src.typ, src.loc, dst.typ, dst.loc with @@ -672,6 +747,21 @@ let emit_push_trap_label handler = traps.push_traps <- lbl::traps.push_traps; traps.enter_traps <- Int.Set.add handler traps.enter_traps +let emit_atomic instr op (size : Cmm.atomic_bitwidth) addr = + let src, dst = match op, size with + | Fetch_and_add, Thirtytwo -> arg32 instr 0, addressing addr DWORD instr 1 + | Fetch_and_add, (Sixtyfour|Word) -> arg instr 0, addressing addr QWORD instr 1 + | Compare_and_swap, Thirtytwo -> arg32 instr 1, addressing addr DWORD instr 2 + | Compare_and_swap, (Sixtyfour|Word) -> arg instr 1, addressing addr QWORD instr 2 in + match op with + | Fetch_and_add -> I.lock_xadd src dst + | Compare_and_swap -> + (* compare_with is already in rax, set_to is src *) + let res8, res = res8 instr 0, res instr 0 in + I.lock_cmpxchg src dst; + I.set E res8; + I.movzx res8 res + (* Emit an instruction *) let emit_instr fallthrough i = emit_debug_info_linear i; @@ -850,6 +940,27 @@ let emit_instr fallthrough i = local_realloc_sites := { lr_lbl = lbl_call; lr_return_lbl = lbl_after_alloc } :: !local_realloc_sites + | Lop(Ipoll { return_label }) -> + I.cmp (domain_field Domainstate.Domain_young_limit) r15; + let gc_call_label = new_label () in + let lbl_after_poll = match return_label with + | None -> new_label() + | Some(lbl) -> lbl in + let lbl_frame = + record_frame_label i.live (Dbg_alloc []) + in + begin match return_label with + | None -> I.jbe (label gc_call_label) + | Some return_label -> I.ja (label return_label) + end; + call_gc_sites := + { gc_lbl = gc_call_label; + gc_return_lbl = lbl_after_poll; + gc_frame = lbl_frame; } :: !call_gc_sites; + begin match return_label with + | None -> def_label lbl_after_poll + | Some _ -> I.jmp (label gc_call_label) + end | Lop(Iintop(Icomp cmp)) -> I.cmp (arg i 1) (arg i 0); I.set (cond cmp) al; @@ -892,6 +1003,8 @@ let emit_instr fallthrough i = | Lop(Iintop_imm(op, n)) -> (* We have i.arg.(0) = i.res.(0) *) instr_for_intop op (int n) (res i 0) + | Lop(Iintop_atomic{op; size; addr}) -> + emit_atomic i op size addr | Lop(Icompf cmp) -> let cond, need_swap = float_cond_and_need_swap cmp in let a0, a1 = if need_swap then arg i 1, arg i 0 else arg i 0, arg i 1 in @@ -984,6 +1097,15 @@ let emit_instr fallthrough i = | Lop(Iintop Ipopcnt) -> assert (!popcnt_support); I.popcnt (arg i 0) (res i 0) + | Lop(Icsel tst) -> + let len = Array.length i.arg in + let ifso = i.arg.(len - 2) in + let ifnot = i.arg.(len - 1) in + assert (Reg.same_loc ifnot i.res.(0)); + let taken c = + I.cmov c (reg ifso) (res i 0) + in + emit_test i tst ~taken | Lop(Ispecific Irdtsc) -> I.rdtsc (); let rdx = Reg64 RDX in @@ -1078,32 +1200,7 @@ let emit_instr fallthrough i = I.jmp (label lbl) | Lcondbranch(tst, lbl) -> let lbl = label lbl in - begin match tst with - | Itruetest -> - output_test_zero i.arg.(0); - I.jne lbl - | Ifalsetest -> - output_test_zero i.arg.(0); - I.je lbl - | Iinttest cmp -> - I.cmp (arg i 1) (arg i 0); - I.j (cond cmp) lbl - | Iinttest_imm((Isigned Ceq | Isigned Cne | - Iunsigned Ceq | Iunsigned Cne) as cmp, 0) -> - output_test_zero i.arg.(0); - I.j (cond cmp) lbl - | Iinttest_imm(cmp, n) -> - I.cmp (int n) (arg i 0); - I.j (cond cmp) lbl - | Ifloattest cmp -> - emit_float_test cmp i lbl - | Ioddtest -> - I.test (int 1) (arg8 i 0); - I.jne lbl - | Ieventest -> - I.test (int 1) (arg8 i 0); - I.je lbl - end + emit_test i tst ~taken:(fun c -> I.j c lbl) | Lcondbranch3(lbl0, lbl1, lbl2) -> I.cmp (int 1) (arg i 0); begin match lbl0 with @@ -1138,7 +1235,8 @@ let emit_instr fallthrough i = begin match system with | S_mingw64 | S_cygwin -> D.section [".rdata"] (Some "dr") [] - | S_macosx | S_win64 -> () (* with LLVM/OS X and MASM, use the text segment *) + | S_macosx | S_win64 -> () + (* with LLVM/OS X and MASM, use the text segment *) | _ -> D.section [".rodata"] None [] end; D.align ~data:true 4; @@ -1254,7 +1352,7 @@ let fundecl fundecl = cfi_adjust_cfa_offset (-n); end; end; - def_label fundecl.fun_end_label; + emit_dwarf_for_fundecl fundecl.fun_name fundecl.fun_dbg; cfi_endproc (); emit_function_type_and_size fundecl.fun_name @@ -1292,10 +1390,17 @@ let reset_all () = float_constants := []; all_functions := [] -let begin_assembly ~init_dwarf = +let begin_assembly unix = reset_all (); - init_dwarf (); + if !Flambda_backend_flags.internal_assembler && + !Emitaux.binary_backend_available then + X86_proc.register_internal_assembler (Internal_assembler.assemble unix); + + let code_begin = Cmm_helpers.make_symbol "code_begin" in + let code_end = Cmm_helpers.make_symbol "code_end" in + Emitaux.Dwarf_helpers.begin_dwarf ~build_asm_directives ~code_begin ~code_end + ~file_emitter:D.file; if system = S_win64 then begin D.extrn "caml_call_gc" NEAR; @@ -1329,8 +1434,8 @@ let begin_assembly ~init_dwarf = D.data (); emit_global_label "data_begin"; - emit_named_text_section (Cmm_helpers.make_symbol "code_begin"); - emit_global_label "code_begin"; + emit_named_text_section code_begin; + emit_global_label_for_symbol code_begin; if system = S_macosx then I.nop (); (* PR#4690 *) () @@ -1628,7 +1733,7 @@ let emit_trap_notes () = D.data () end -let end_assembly dwarf = +let end_assembly () = if !float_constants <> [] then begin begin match system with | S_macosx -> D.section ["__TEXT";"__literal8"] None ["8byte_literals"] @@ -1643,11 +1748,12 @@ let end_assembly dwarf = (* Emit probe handler wrappers *) List.iter emit_probe_handler_wrapper !probes; - emit_named_text_section (Cmm_helpers.make_symbol "code_end"); + let code_end = Cmm_helpers.make_symbol "code_end" in + emit_named_text_section code_end; if system = S_macosx then I.nop (); (* suppress "ld warning: atom sorting error" *) - emit_global_label "code_end"; + emit_global_label_for_symbol code_end; emit_imp_table(); @@ -1720,6 +1826,6 @@ let end_assembly dwarf = else None in - Option.iter Dwarf_ocaml.Dwarf.emit dwarf; + Emitaux.Dwarf_helpers.emit_dwarf (); X86_proc.generate_code asm; reset_all () diff --git a/backend/amd64/proc.ml b/backend/amd64/proc.ml index 4180961bb10..dcafd506cff 100644 --- a/backend/amd64/proc.ml +++ b/backend/amd64/proc.ml @@ -72,9 +72,9 @@ let win64 = Arch.win64 3. C callee-saved registers. This translates to the set { r10, r11 }. These registers hence cannot be used for OCaml parameter passing and must also be marked as - destroyed across [Ialloc] (otherwise a call to caml_call_gc@PLT might - clobber these two registers before the assembly stub saves them into - the GC regs block). + destroyed across [Ialloc] and [Ipoll] (otherwise a call to + caml_call_gc@PLT might clobber these two registers before the assembly + stub saves them into the GC regs block). *) let int_reg_name = @@ -313,7 +313,7 @@ let destroyed_at_c_call = 100;101;102;103;104;105;106;107; 108;109;110;111;112;113;114;115]) -let destroyed_at_alloc = +let destroyed_at_alloc_or_poll = if X86_proc.use_plt then destroyed_by_plt_stub else @@ -333,7 +333,7 @@ let destroyed_at_oper = function | Iop(Iintop(Idiv | Imod)) | Iop(Iintop_imm((Idiv | Imod), _)) -> [| rax; rdx |] | Iop(Istore(Single, _, _)) -> [| rxmm15 |] - | Iop(Ialloc _) -> destroyed_at_alloc + | Iop(Ialloc _ | Ipoll _) -> destroyed_at_alloc_or_poll | Iop(Iintop(Imulh _ | Icomp _) | Iintop_imm((Icomp _), _)) -> [| rax |] | Iswitch(_, _) -> [| rax; rdx |] @@ -354,11 +354,13 @@ let destroyed_at_oper = function | Iop(Iintop_imm((Iadd | Isub | Imul | Imulh _ | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Ipopcnt | Iclz _ | Ictz _ | Icheckbound),_)) + | Iop(Iintop_atomic _) | Iop(Istore((Byte_unsigned | Byte_signed | Sixteen_unsigned | Sixteen_signed | Thirtytwo_unsigned | Thirtytwo_signed | Word_int | Word_val | Double ), _, _)) | Iop(Imove | Ispill | Ireload | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf | Icompf _ + | Icsel _ | Ifloatofint | Iintoffloat | Ivalueofint | Iintofvalue | Iconst_int _ | Iconst_float _ | Iconst_symbol _ @@ -382,8 +384,6 @@ let destroyed_at_reloadretaddr = [| |] (* note: keep this function in sync with `destroyed_at_oper` above. *) let destroyed_at_basic (basic : Cfg_intf.S.basic) = match basic with - | Call (P (Alloc _)) -> - destroyed_at_alloc | Reloadretaddr -> destroyed_at_reloadretaddr | Pushtrap _ -> @@ -409,11 +409,12 @@ let destroyed_at_basic (basic : Cfg_intf.S.basic) = | Iasr | Ipopcnt | Iclz _ | Ictz _) | Intop_imm ((Iadd | Isub | Imul | Imulh _ | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Ipopcnt | Iclz _ | Ictz _),_) + | Intop_atomic _ | Negf | Absf | Addf | Subf | Mulf | Divf | Compf _ + | Csel _ | Floatofint | Intoffloat | Valueofint | Intofvalue - | Probe _ | Probe_is_enabled _ | Opaque | Begin_region @@ -425,39 +426,52 @@ let destroyed_at_basic (basic : Cfg_intf.S.basic) = | Isextend32 | Izextend32 | Icrc32q | Ipause | Iprefetch _ | Ilfence | Isfence | Imfence) | Name_for_debugger _) - | Call (P (Checkbound _)) | Poptrap | Prologue -> if fp then [| rbp |] else [||] - | Call (P (External { func_symbol = _; alloc; ty_res = _; ty_args = _; })) -> - if alloc then all_phys_regs else destroyed_at_c_call - | Call (F (Indirect | Direct _)) -> - all_phys_regs (* note: keep this function in sync with `destroyed_at_oper`. above *) let destroyed_at_terminator (terminator : Cfg_intf.S.terminator) = match terminator with | Never -> assert false + | Prim {op = Alloc _; _} -> + destroyed_at_alloc_or_poll | Always _ | Parity_test _ | Truth_test _ | Float_test _ | Int_test _ - | Return | Raise _ | Tailcall _ -> + | Return | Raise _ | Tailcall_self _ | Tailcall_func _ + | Prim {op = Checkbound _ | Probe _; _} + -> if fp then [| rbp |] else [||] | Switch _ -> [| rax; rdx |] - | Call_no_return { func_symbol = _; alloc; ty_res = _; ty_args = _; } -> + | Call_no_return { func_symbol = _; alloc; ty_res = _; ty_args = _; } + | Prim {op = External { func_symbol = _; alloc; ty_res = _; ty_args = _; }; _} -> if alloc then all_phys_regs else destroyed_at_c_call + | Call {op = Indirect | Direct _; _} -> + all_phys_regs + | Specific_can_raise { op = (Ilea _ | Ibswap _ | Isqrtf | Isextend32 | Izextend32 + | Ifloatarithmem _ | Ifloatsqrtf _ + | Ifloat_iround | Ifloat_round _ | Ifloat_min | Ifloat_max + | Icrc32q | Irdtsc | Irdpmc | Ipause + | Ilfence | Isfence | Imfence + | Istore_int (_, _, _) | Ioffset_loc (_, _) + | Iprefetch _); _ } -> + Misc.fatal_error "no instructions specific for this architecture can raise" + | Poll_and_jump _ -> destroyed_at_alloc_or_poll (* Maximal register pressure *) let safe_register_pressure = function Iextcall _ -> if win64 then if fp then 7 else 8 else 0 - | Ialloc _ | Imove | Ispill | Ireload + | Ialloc _ | Ipoll _ | Imove | Ispill | Ireload | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf | Ifloatofint | Iintoffloat | Ivalueofint | Iintofvalue | Icompf _ + | Icsel _ | Iconst_int _ | Iconst_float _ | Iconst_symbol _ | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ | Istackoffset _ | Iload (_, _, _) | Istore (_, _, _) - | Iintop _ | Iintop_imm (_, _) | Ispecific _ | Iname_for_debugger _ + | Iintop _ | Iintop_imm (_, _) | Iintop_atomic _ + | Ispecific _ | Iname_for_debugger _ | Iprobe _ | Iprobe_is_enabled _ | Iopaque | Ibeginregion | Iendregion -> if fp then 10 else 11 @@ -474,7 +488,7 @@ let max_register_pressure = else consumes ~int:9 ~float:16 | Iintop(Idiv | Imod) | Iintop_imm((Idiv | Imod), _) -> consumes ~int:2 ~float:0 - | Ialloc _ -> + | Ialloc _ | Ipoll _ -> consumes ~int:(1 + num_destroyed_by_plt_stub) ~float:0 | Iintop(Icomp _) | Iintop_imm((Icomp _), _) -> consumes ~int:1 ~float:0 @@ -484,11 +498,13 @@ let max_register_pressure = | Ipopcnt|Iclz _| Ictz _|Icheckbound) | Iintop_imm((Iadd | Isub | Imul | Imulh _ | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Ipopcnt | Iclz _| Ictz _|Icheckbound), _) + | Iintop_atomic _ | Istore((Byte_unsigned | Byte_signed | Sixteen_unsigned | Sixteen_signed | Thirtytwo_unsigned | Thirtytwo_signed | Word_int | Word_val | Double ), _, _) | Imove | Ispill | Ireload | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf + | Icsel _ | Ifloatofint | Iintoffloat | Ivalueofint | Iintofvalue | Iconst_int _ | Iconst_float _ | Iconst_symbol _ | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ @@ -526,10 +542,11 @@ let init () = let operation_supported = function | Cpopcnt -> !popcnt_support - | Cprefetch _ + | Cprefetch _ | Catomic _ | Capply _ | Cextcall _ | Cload _ | Calloc _ | Cstore _ | Caddi | Csubi | Cmuli | Cmulhi _ | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr + | Ccsel _ | Cbswap _ | Cclz _ | Cctz _ | Ccmpi _ | Caddv | Cadda | Ccmpa _ diff --git a/backend/amd64/reload.ml b/backend/amd64/reload.ml index 37598d7b339..740f22c438b 100644 --- a/backend/amd64/reload.ml +++ b/backend/amd64/reload.ml @@ -146,7 +146,34 @@ method! reload_operation op arg res = if !Clflags.pic_code || !Clflags.dlcode || Arch.win64 then super#reload_operation op arg res else (arg, res) + | Icsel tst -> + (* Last argument and result must be in the same register. + Result must be in register. The last two arguments are used + for emitting cmov, the remaining for [Mach.test]. *) + (* CR gyorsh: we already use Array.sub here, + so no reason for this convoluted arrangement, + using the first two args for cmov would simplify most of the + code as it won't need to have [len], it will be able to have indexes + directly, but then in Emit we will have to do Array.sub again + to call emit_test (unless emit_test takes an index, which is also + weird). *) + if stackp res.(0) + then begin + (* CR-soon gyorsh: [reload_test] may lose some sharing + between the arguments of the test and the last two arguments + and the result of the move. *) + let r = self#makereg res.(0) in + let len = Array.length arg in + let arg' = Array.copy arg in + let test_arg = self#reload_test tst (Array.sub arg 0 (len - 2)) in + for i = 0 to len - 2 - 1 do + arg'.(i) <- test_arg.(i) + done; + arg'.(len - 1) <- r; + (arg', [|r|]) + end else (arg, res) | Iintop (Ipopcnt | Iclz _| Ictz _) + | Iintop_atomic _ | Ispecific (Isqrtf | Isextend32 | Izextend32 | Ilea _ | Istore_int (_, _, _) | Ioffset_loc (_, _) | Ifloatarithmem (_, _) @@ -159,7 +186,7 @@ method! reload_operation op arg res = | Itailcall_ind|Itailcall_imm _|Iextcall _|Istackoffset _|Iload (_, _, _) | Istore (_, _, _)|Ialloc _|Iname_for_debugger _|Iprobe _|Iprobe_is_enabled _ | Ivalueofint | Iintofvalue | Iopaque - | Ibeginregion | Iendregion + | Ibeginregion | Iendregion | Ipoll _ -> (* Other operations: all args and results in registers, except moves and probes. *) super#reload_operation op arg res diff --git a/backend/amd64/selection.ml b/backend/amd64/selection.ml index e8e50c13021..b0c4d32040b 100644 --- a/backend/amd64/selection.ml +++ b/backend/amd64/selection.ml @@ -94,8 +94,18 @@ let rdx = phys_reg 4 let pseudoregs_for_operation op arg res = match op with (* Two-address binary operations: arg.(0) and res.(0) must be the same *) - Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) | Iaddf|Isubf|Imulf|Idivf -> + Iintop(Iadd|Isub|Imul|Iand|Ior|Ixor) | Iaddf|Isubf|Imulf|Idivf -> ([|res.(0); arg.(1)|], res) + | Iintop_atomic {op = Compare_and_swap; size = _; addr = _} -> + (* first arg must be rax *) + let arg = Array.copy arg in + arg.(0) <- rax; + (arg, res) + | Iintop_atomic {op = Fetch_and_add; size = _; addr = _} -> + (* first arg must be the same as res.(0) *) + let arg = Array.copy arg in + arg.(0) <- res.(0); + (arg, res) (* One-address unary operations: arg.(0) and res.(0) must be the same *) | Iintop_imm((Iadd|Isub|Imul|Iand|Ior|Ixor|Ilsl|Ilsr|Iasr), _) | Iabsf | Inegf @@ -145,6 +155,12 @@ let pseudoregs_for_operation op arg res = | Ispecific Icrc32q -> (* arg.(0) and res.(0) must be the same *) ([|res.(0); arg.(1)|], res) + | Icsel _ -> + (* last arg must be the same as res.(0) *) + let len = Array.length arg in + let arg = Array.copy arg in + arg.(len-1) <- res.(0); + (arg, res) (* Other instructions are regular *) | Iintop (Ipopcnt|Iclz _|Ictz _|Icomp _|Icheckbound) | Iintop_imm ((Imulh _|Idiv|Imod|Icomp _|Icheckbound @@ -158,7 +174,7 @@ let pseudoregs_for_operation op arg res = | Iconst_symbol _|Icall_ind|Icall_imm _|Itailcall_ind|Itailcall_imm _ | Iextcall _|Istackoffset _|Iload (_, _, _) | Istore (_, _, _)|Ialloc _ | Iname_for_debugger _|Iprobe _|Iprobe_is_enabled _ | Iopaque - | Ibeginregion | Iendregion + | Ibeginregion | Iendregion | Ipoll _ -> raise Use_default let select_locality (l : Cmm.prefetch_temporal_locality_hint) @@ -418,4 +434,5 @@ method! insert_op_debug env op dbg rs rd = end -let fundecl f = (new selector)#emit_fundecl f +let fundecl ~future_funcnames f = + (new selector)#emit_fundecl ~future_funcnames f diff --git a/backend/arm64/arch.ml b/backend/arm64/arch.ml index f8523dbb370..f61ed7fa36f 100644 --- a/backend/arm64/arch.ml +++ b/backend/arm64/arch.ml @@ -44,6 +44,7 @@ type cmm_label = int type bswap_bitwidth = Sixteen | Thirtytwo | Sixtyfour type specific_operation = + | Ifar_poll of { return_label: cmm_label option } | Ifar_alloc of { bytes : int; dbginfo : Debuginfo.alloc_dbginfo } | Ifar_intop_checkbound | Ifar_intop_imm_checkbound of { bound : int; } @@ -112,6 +113,8 @@ let int_of_bswap_bitwidth = function let print_specific_operation printreg op ppf arg = match op with + | Ifar_poll _ -> + fprintf ppf "(far) poll" | Ifar_alloc { bytes; } -> fprintf ppf "(far) alloc %i" bytes | Ifar_intop_checkbound -> @@ -228,7 +231,7 @@ let equal_specific_operation left right = Int.equal (int_of_bswap_bitwidth left) (int_of_bswap_bitwidth right) | Imove32, Imove32 -> true | Isignext left, Isignext right -> Int.equal left right - | (Ifar_alloc _ | Ifar_intop_checkbound | Ifar_intop_imm_checkbound _ + | (Ifar_alloc _ | Ifar_poll _ | Ifar_intop_checkbound | Ifar_intop_imm_checkbound _ | Ishiftarith _ | Ishiftcheckbound _ | Ifar_shiftcheckbound _ | Imuladd | Imulsub | Inegmulf | Imuladdf | Inegmuladdf | Imulsubf | Inegmulsubf | Isqrtf | Ibswap _ | Imove32 | Isignext _), _ -> false @@ -304,7 +307,7 @@ let is_logical_immediate x = (* Specific operations that are pure *) let operation_is_pure : specific_operation -> bool = function - | Ifar_alloc _ -> false + | Ifar_alloc _ | Ifar_poll _ -> false | Ifar_intop_checkbound -> false | Ifar_intop_imm_checkbound _ -> false | Ishiftarith _ -> true @@ -326,6 +329,7 @@ let operation_is_pure : specific_operation -> bool = function let operation_can_raise = function | Ifar_alloc _ + | Ifar_poll _ | Ifar_intop_checkbound | Ifar_intop_imm_checkbound _ | Ishiftcheckbound _ @@ -345,6 +349,7 @@ let operation_can_raise = function let operation_allocates = function | Ifar_alloc _ -> true + | Ifar_poll _ | Ifar_intop_checkbound | Ifar_intop_imm_checkbound _ | Ishiftcheckbound _ diff --git a/backend/arm64/cfg_stack_operands.ml b/backend/arm64/cfg_stack_operands.ml index 81b1ac75b76..82a06a4a7df 100644 --- a/backend/arm64/cfg_stack_operands.ml +++ b/backend/arm64/cfg_stack_operands.ml @@ -6,8 +6,6 @@ let debug = true let basic (map : spilled_map) (instr : Cfg.basic Cfg.instruction) = match instr.desc with - | Op (Probe _) -> - may_use_stack_operands_everywhere map instr | Op (Specific Imove32) -> if debug then check_lengths instr ~of_arg:1 ~of_res:1; begin match is_spilled instr.arg.(0), is_spilled instr.res.(0) with @@ -31,6 +29,10 @@ let basic (map : spilled_map) (instr : Cfg.basic Cfg.instruction) = (* no rewrite *) May_still_have_spilled_registers -let terminator _ _ = - (* no rewrite *) - May_still_have_spilled_registers +let terminator (map : spilled_map) (term : Cfg.terminator Cfg.instruction) = + match term.desc with + | Prim {op = Probe _; _} -> + may_use_stack_operands_everywhere map term + | _ -> + (* no rewrite *) + May_still_have_spilled_registers diff --git a/backend/arm64/emit.mlp b/backend/arm64/emit.mlp index a22b9c8ccf5..d29b23d9d1b 100644 --- a/backend/arm64/emit.mlp +++ b/backend/arm64/emit.mlp @@ -397,6 +397,8 @@ let num_call_gc_and_check_bound_points instr = | Lend -> totals | Lop (Ialloc _) when !fastcode_flag -> loop instr.next (call_gc + 1, check_bound) + | Lop (Ipoll _) -> + loop instr.next (call_gc + 1, check_bound) | Lop (Iintop Icheckbound) | Lop (Iintop_imm (Icheckbound, _)) | Lop (Ispecific (Ishiftcheckbound _)) -> @@ -409,6 +411,7 @@ let num_call_gc_and_check_bound_points instr = (* The following four should never be seen, since this function is run before branch relaxation. *) | Lop (Ispecific (Ifar_alloc _)) + | Lop (Ispecific (Ifar_poll _)) | Lop (Ispecific Ifar_intop_checkbound) | Lop (Ispecific (Ifar_intop_imm_checkbound _)) | Lop (Ispecific (Ifar_shiftcheckbound _)) -> assert false @@ -455,6 +458,7 @@ module BR = Branch_relaxation.Make (struct let classify_instr = function | Lop (Ialloc _) + | Lop (Ipoll _) | Lop (Iintop Icheckbound) | Lop (Iintop_imm (Icheckbound, _)) | Lop (Ispecific (Ishiftcheckbound _)) -> Some Bcc @@ -489,6 +493,9 @@ module BR = Branch_relaxation.Make (struct num_instructions_for_intconst n | Lop (Iconst_float _) -> 2 | Lop (Iconst_symbol _) -> 2 + | Lop (Iintop_atomic _) -> + (* Never generated; builtins are not yet translated to atomics *) + assert false | Lop (Icall_ind) -> 1 | Lop (Icall_imm _) -> 1 | Lop (Itailcall_ind) -> epilogue_size () @@ -502,12 +509,15 @@ module BR = Branch_relaxation.Make (struct based + begin match size with Single -> 2 | _ -> 1 end | Lop (Ialloc _) when !fastcode_flag -> 5 | Lop (Ispecific (Ifar_alloc _)) when !fastcode_flag -> 6 + | Lop (Ipoll _) -> 3 + | Lop (Ispecific (Ifar_poll _)) -> 4 | Lop (Ialloc { bytes = num_bytes; _ }) | Lop (Ispecific (Ifar_alloc { bytes = num_bytes; _ })) -> begin match num_bytes with | 16 | 24 | 32 -> 1 | _ -> 1 + num_instructions_for_intconst (Nativeint.of_int num_bytes) end + | Lop (Icsel _) -> 4 | Lop (Ibeginregion | Iendregion) -> Misc.fatal_error "Local allocations not supported on this architecture" | Lop (Iintop (Icomp _)) -> 2 @@ -567,6 +577,9 @@ module BR = Branch_relaxation.Make (struct | Lambda.Raise_notrace -> 4 end + let relax_poll ~return_label = + Lop (Ispecific (Ifar_poll { return_label })) + let relax_allocation ~num_bytes ~dbginfo = Lop (Ispecific (Ifar_alloc { bytes = num_bytes; dbginfo })) @@ -624,6 +637,40 @@ let assembly_code_for_allocation i ~n ~far ~dbginfo = `{emit_label lbl_frame}: add {emit_reg i.res.(0)}, {emit_reg reg_alloc_ptr}, #8\n` end +let assembly_code_for_poll i ~far ~return_label = + let lbl_frame = record_frame_label i.live (Dbg_alloc []) in + let lbl_call_gc = new_label() in + let lbl_after_poll = match return_label with + | None -> new_label() + | Some lbl -> lbl in + let offset = Domainstate.(idx_of_field Domain_young_limit) * 8 in + ` ldr {emit_reg reg_tmp1}, [{emit_reg reg_domain_state_ptr}, #{emit_int offset}]\n`; + ` cmp {emit_reg reg_alloc_ptr}, {emit_reg reg_tmp1}\n`; + if not far then begin + match return_label with + | None -> + ` b.ls {emit_label lbl_call_gc}\n`; + `{emit_label lbl_after_poll}:\n` + | Some return_label -> + ` b.hi {emit_label return_label}\n`; + ` b {emit_label lbl_call_gc}\n`; + end else begin + match return_label with + | None -> + ` b.hi {emit_label lbl_after_poll}\n`; + ` b {emit_label lbl_call_gc}\n`; + `{emit_label lbl_after_poll}:\n` + | Some return_label -> + let lbl = new_label () in + ` b.ls {emit_label lbl}\n`; + ` b {emit_label return_label}\n`; + `{emit_label lbl}: b {emit_label lbl_call_gc}\n` + end; + call_gc_sites := + { gc_lbl = lbl_call_gc; + gc_return_lbl = lbl_after_poll; + gc_frame_lbl = lbl_frame; } :: !call_gc_sites + (* Output .text section directive, or named .text.caml. if enabled. *) let emit_named_text_section func_name = @@ -657,6 +704,20 @@ let name_for_float_comparison = function | CFge -> "ge" | CFnge -> "lt" +let move src dst = + if src.loc <> dst.loc then begin + match (src, dst) with + | {loc = Reg _; typ = Float}, {loc = Reg _} -> + ` fmov {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg _}, {loc = Reg _} -> + ` mov {emit_reg dst}, {emit_reg src}\n` + | {loc = Reg _}, {loc = Stack _} -> + ` str {emit_reg src}, {emit_stack dst}\n` + | {loc = Stack _}, {loc = Reg _} -> + ` ldr {emit_reg dst}, {emit_stack src}\n` + | _ -> + assert false + end (* Output the assembly code for an instruction *) let emit_instr i = @@ -672,21 +733,11 @@ let emit_instr i = cfi_offset ~reg:30 (* return address *) ~offset:(-8); ` str x30, [sp, #{emit_int (n-8)}]\n` end + | Lop(Iintop_atomic _) -> + (* Never generated; builtins are not yet translated to atomics *) + assert false | Lop(Imove | Ispill | Ireload) -> - let src = i.arg.(0) and dst = i.res.(0) in - if src.loc <> dst.loc then begin - match (src, dst) with - | {loc = Reg _; typ = Float}, {loc = Reg _} -> - ` fmov {emit_reg dst}, {emit_reg src}\n` - | {loc = Reg _}, {loc = Reg _} -> - ` mov {emit_reg dst}, {emit_reg src}\n` - | {loc = Reg _}, {loc = Stack _} -> - ` str {emit_reg src}, {emit_stack dst}\n` - | {loc = Stack _}, {loc = Reg _} -> - ` ldr {emit_reg dst}, {emit_stack src}\n` - | _ -> - assert false - end + move i.arg.(0) i.res.(0) | Lop(Ispecific Imove32) -> let src = i.arg.(0) and dst = i.res.(0) in if src.loc <> dst.loc then begin @@ -794,6 +845,10 @@ let emit_instr i = assembly_code_for_allocation i ~n ~far:true ~dbginfo | Lop(Ialloc { mode = Alloc_local } | Ibeginregion | Iendregion) -> Misc.fatal_error "Local allocations not supported on this architecture" + | Lop(Ipoll { return_label }) -> + assembly_code_for_poll i ~far:false ~return_label + | Lop(Ispecific (Ifar_poll { return_label })) -> + assembly_code_for_poll i ~far:true ~return_label | Lop(Iintop_imm(Iadd, n)) -> emit_addimm i.res.(0) i.arg.(0) n | Lop(Iintop_imm(Isub, n)) -> @@ -925,6 +980,39 @@ let emit_instr i = | Lop (Iname_for_debugger _) -> () | Lop (Iprobe _ | Iprobe_is_enabled _) -> fatal_error ("Probes not supported.") + | Lop (Icsel tst) -> + let len = Array.length i.arg in + let ifso = i.arg.(len - 2) in + let ifnot = i.arg.(len - 1) in + if Reg.same_loc ifso ifnot then + move ifso i.res.(0) + else + begin match tst with + | Itruetest -> + ` cmp {emit_reg i.arg.(0)}, #0\n`; + ` csel {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}, ne\n` + | Ifalsetest -> + ` cmp {emit_reg i.arg.(0)}, #0\n`; + ` csel {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}, eq\n` + | Iinttest cmp -> + let comp = name_for_comparison cmp in + ` cmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` csel {emit_reg i.res.(0)}, {emit_reg i.arg.(2)}, {emit_reg i.arg.(3)}, {emit_string comp}\n` + | Iinttest_imm(cmp, n) -> + let comp = name_for_comparison cmp in + emit_cmpimm i.arg.(0) n; + ` csel {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}, {emit_string comp}\n` + | Ifloattest cmp -> + let comp = name_for_float_comparison cmp in + ` fcmp {emit_reg i.arg.(0)}, {emit_reg i.arg.(1)}\n`; + ` csel {emit_reg i.res.(0)}, {emit_reg i.arg.(2)}, {emit_reg i.arg.(3)}, {emit_string comp}\n` + | Ioddtest -> + ` tst {emit_reg i.arg.(0)}, #1\n`; + ` csel {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}, ne\n` + | Ieventest -> + ` tst {emit_reg i.arg.(0)}, #1\n`; + ` csel {emit_reg i.res.(0)}, {emit_reg i.arg.(1)}, {emit_reg i.arg.(2)}, eq\n` + end | Lreloadretaddr -> () | Lreturn -> @@ -1063,7 +1151,10 @@ let fundecl fundecl = List.iter emit_call_bound_error !bound_error_sites; assert (List.length !call_gc_sites = num_call_gc); assert (List.length !bound_error_sites = num_check_bound); - `{emit_label fundecl.fun_end_label}:\n`; + (match Emitaux.Dwarf_helpers.record_dwarf_for_fundecl + ~fun_name:fundecl.fun_name fundecl.fun_dbg with + | None -> () + | Some label -> `{emit_label label}:\n`); cfi_endproc(); emit_symbol_type emit_symbol fundecl.fun_name "function"; emit_symbol_size fundecl.fun_name; @@ -1100,7 +1191,7 @@ let data l = (* Beginning / end of an assembly file *) -let begin_assembly ~init_dwarf:_ = +let begin_assembly _unix = reset_debug_info(); ` .file \"\"\n`; (* PR#7037 *) let lbl_begin = Cmm_helpers.make_symbol "data_begin" in diff --git a/backend/arm64/proc.ml b/backend/arm64/proc.ml index df57ef514c5..f3bf49adf68 100644 --- a/backend/arm64/proc.ml +++ b/backend/arm64/proc.ml @@ -275,7 +275,7 @@ let destroyed_at_oper = function all_phys_regs | Iop(Iextcall { alloc = false; }) -> destroyed_at_c_call - | Iop(Ialloc _) -> + | Iop(Ialloc _) | Iop(Ipoll _) -> [| reg_x8 |] | Iop( Iintoffloat | Ifloatofint | Iload(Single, _, _) | Istore(Single, _, _)) -> @@ -288,15 +288,11 @@ let destroyed_at_reloadretaddr = [| |] let destroyed_at_pushtrap = [| |] +let destroyed_at_alloc_or_poll = [| reg_x8 |] + (* note: keep this function in sync with `destroyed_at_oper` above. *) let destroyed_at_basic (basic : Cfg_intf.S.basic) = match basic with - | Call (P (External { func_symbol = _; alloc; ty_res = _; ty_args = _; })) -> - if alloc then all_phys_regs else destroyed_at_c_call - | Call (F (Indirect | Direct _)) -> - all_phys_regs - | Call (P (Alloc _)) -> - [| reg_x8 |] | Reloadretaddr -> destroyed_at_reloadretaddr | Pushtrap _ -> @@ -306,29 +302,37 @@ let destroyed_at_basic (basic : Cfg_intf.S.basic) = | Op( Intoffloat | Floatofint | Load(Single, _, _) | Store(Single, _, _)) -> [| reg_d7 |] - | Op _ | Call (P (Checkbound _)) | Poptrap | Prologue -> + | Op _ | Poptrap | Prologue -> [||] (* note: keep this function in sync with `destroyed_at_oper` above. *) let destroyed_at_terminator (terminator : Cfg_intf.S.terminator) = match terminator with | Never -> assert false + | Call {op = Indirect | Direct _; _} -> + all_phys_regs + | Prim {op = Alloc _; _} -> + [| reg_x8 |] | Always _ | Parity_test _ | Truth_test _ | Float_test _ - | Int_test _ | Switch _ | Return | Raise _ | Tailcall _ -> + | Int_test _ | Switch _ | Return | Raise _ | Tailcall_self _ + | Tailcall_func _ | Prim {op = Checkbound _ | Probe _; _} + | Specific_can_raise _ -> [||] - | Call_no_return { func_symbol = _; alloc; ty_res = _; ty_args = _; } -> + | Call_no_return { func_symbol = _; alloc; ty_res = _; ty_args = _; } + | Prim {op = External { func_symbol = _; alloc; ty_res = _; ty_args = _; }; _} -> if alloc then all_phys_regs else destroyed_at_c_call + | Poll_and_jump _ -> destroyed_at_alloc_or_poll (* Maximal register pressure *) let safe_register_pressure = function | Iextcall _ -> 7 - | Ialloc _ -> 22 + | Ialloc _ | Ipoll _ -> 22 | _ -> 23 let max_register_pressure = function | Iextcall _ -> [| 7; 8 |] (* 7 integer callee-saves, 8 FP callee-saves *) - | Ialloc _ -> [| 22; 32 |] + | Ialloc _ | Ipoll _ -> [| 22; 32 |] | Iintoffloat | Ifloatofint | Iload(Single, _, _) | Istore(Single, _, _) -> [| 23; 31 |] | _ -> [| 23; 32 |] @@ -354,7 +358,7 @@ let init () = () let operation_supported = function | Cclz _ | Cctz _ | Cpopcnt - | Cprefetch _ + | Cprefetch _ | Catomic _ -> false (* Not implemented *) | Cbswap _ | Capply _ | Cextcall _ | Cload _ | Calloc _ | Cstore _ @@ -364,6 +368,7 @@ let operation_supported = function | Cnegf | Cabsf | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Cintofvalue | Cvalueofint | Ccmpf _ + | Ccsel _ | Craise _ | Ccheckbound | Cprobe _ | Cprobe_is_enabled _ | Copaque diff --git a/backend/arm64/selection.ml b/backend/arm64/selection.ml index 748844ee9e7..ac9f4f0512a 100644 --- a/backend/arm64/selection.ml +++ b/backend/arm64/selection.ml @@ -214,4 +214,5 @@ method! insert_move_extcall_arg env ty_arg src dst = else self#insert_moves env src dst end -let fundecl f = (new selector)#emit_fundecl f +let fundecl ~future_funcnames f = (new selector)#emit_fundecl + ~future_funcnames f diff --git a/backend/asmgen.ml b/backend/asmgen.ml index a0e15f7a974..0a7a5c461b9 100644 --- a/backend/asmgen.ml +++ b/backend/asmgen.ml @@ -23,7 +23,7 @@ open Clflags open Misc open Cmm -open Dwarf_ocaml +module String = Misc.Stdlib.String type error = | Assembler_error of string @@ -90,16 +90,16 @@ let reset () = start_from_emit := false; Compiler_pass_map.iter (fun pass (cfg_unit_info : Cfg_format.cfg_unit_info) -> if should_save_ir_after pass then begin - cfg_unit_info.unit <- Compilation_unit.get_current_exn (); + cfg_unit_info.unit <- Compilation_unit.get_current_or_dummy (); cfg_unit_info.items <- []; end) pass_to_cfg; if should_save_before_emit () then begin - linear_unit_info.unit <- Compilation_unit.get_current_exn (); + linear_unit_info.unit <- Compilation_unit.get_current_or_dummy (); linear_unit_info.items <- []; end; if should_save_cfg_before_emit () then begin - cfg_unit_info.unit <- Compilation_unit.get_current_exn (); + cfg_unit_info.unit <- Compilation_unit.get_current_or_dummy (); cfg_unit_info.items <- []; end @@ -152,6 +152,8 @@ let write_ir prefix = Linear_format.save filename linear_unit_info end; if should_save_cfg_before_emit () then begin + if not !Flambda_backend_flags.use_ocamlcfg then + Misc.fatal_error "Flag '-save-ir-after simplify_cfg' requires '-ocamlcfg'"; let filename = Compiler_pass.(to_output_filename Simplify_cfg ~prefix) in cfg_unit_info.items <- List.rev cfg_unit_info.items; Cfg_format.save filename cfg_unit_info @@ -165,37 +167,23 @@ let should_use_linscan fd = List.mem Cmm.Use_linscan_regalloc fd.Mach.fun_codegen_options let if_emit_do f x = if should_emit () then f x else () -let emit_begin_assembly ~init_dwarf:init_dwarf = - if_emit_do (fun init_dwarf -> Emit.begin_assembly ~init_dwarf) init_dwarf -let emit_end_assembly filename = - if_emit_do - (fun dwarf -> - try - Emit.end_assembly dwarf +let emit_begin_assembly unix = if_emit_do Emit.begin_assembly unix +let emit_end_assembly filename () = + if_emit_do (fun () -> + try Emit.end_assembly () with Emitaux.Error e -> raise (Error (Asm_generation(filename, e)))) + () -let emit_data = if_emit_do Emit.data -let emit_fundecl ~dwarf = +let emit_data dl = if_emit_do Emit.data dl +let emit_fundecl f = if_emit_do (fun (fundecl : Linear.fundecl) -> try - let () = Profile.record ~accumulate:true "emit" Emit.fundecl fundecl in - match dwarf with - | None -> () - | Some dwarf -> - let fun_end_label = - Asm_targets.Asm_label.create_int Text fundecl.fun_end_label - in - let fundecl : Dwarf_concrete_instances.fundecl = - { fun_name = fundecl.fun_name; - fun_dbg = fundecl.fun_dbg; - fun_end_label; - } - in - Dwarf.dwarf_for_fundecl dwarf fundecl + Profile.record ~accumulate:true "emit" Emit.fundecl fundecl with Emitaux.Error e -> raise (Error (Asm_generation(fundecl.Linear.fun_name, e)))) + f let rec regalloc ~ppf_dump round fd = if round > 50 then @@ -234,79 +222,6 @@ let ocamlcfg_verbose = | Some "1" -> true | Some _ | None -> false -let recompute_liveness_on_cfg (cfg_with_layout : Cfg_with_layout.t) : Cfg_with_layout.t = - let cfg = Cfg_with_layout.cfg cfg_with_layout in - let init = { Cfg_liveness.before = Reg.Set.empty; across = Reg.Set.empty; } in - begin match Cfg_liveness.Liveness.run cfg ~init ~map:Cfg_liveness.Liveness.Instr () with - | Ok (liveness : Cfg_liveness.Liveness.domain Cfg_dataflow.Instr.Tbl.t) -> - let with_liveness (instr : _ Cfg.instruction) = - match Cfg_dataflow.Instr.Tbl.find_opt liveness instr.id with - | None -> - Misc.fatal_errorf "Missing liveness information for instruction %d in function %s@." - instr.id - cfg.Cfg.fun_name - | Some { Cfg_liveness.before = _; across } -> - Cfg.set_live instr across - in - Cfg.iter_blocks cfg ~f:(fun _label block -> - block.body <- ListLabels.map block.body ~f:with_liveness; - block.terminator <- with_liveness block.terminator; - ); - | Aborted _ -> . - | Max_iterations_reached -> - Misc.fatal_errorf "Unable to compute liveness from CFG for function %s@." - cfg.Cfg.fun_name; - end; - Cfg.iter_blocks cfg ~f:(fun _label block -> - block.body <- ListLabels.filter block.body ~f:(fun instr -> - not (Cfg.is_noop_move instr))); - let layout : Label.t list = - ListLabels.filter (Cfg_with_layout.layout cfg_with_layout) ~f:(fun label -> - Cfg.mem_block (Cfg_with_layout.cfg cfg_with_layout) label) - in - let result = - Cfg_with_layout.create - cfg - ~layout - ~preserve_orig_labels:false - ~new_labels:Label.Set.empty - in - Eliminate_fallthrough_blocks.run result; - Merge_straightline_blocks.run result; - Eliminate_dead_code.run_dead_block result; - Simplify_terminator.run cfg; - result - -let test_cfgize (f : Mach.fundecl) (res : Linear.fundecl) : unit = - if ocamlcfg_verbose then begin - Format.eprintf "processing function %s...\n%!" f.Mach.fun_name; - end; - (* We do not simplify terminators here because it interferes with liveness - when we have a terminator with: - (i) all its edges leading to the same block; - (ii) a condition making a pseudo-register live. - In such a case, the terminator would be simplified to a mere jump, the - condition would disappear, and the pseudo-register would no longer be - live. Is it fine in itself, but would break the equivalence check. *) - let result = - Cfgize.fundecl - f - ~before_register_allocation:false - ~preserve_orig_labels:false - ~simplify_terminators:false - in - let expected = Linear_to_cfg.run res ~preserve_orig_labels:false in - Eliminate_fallthrough_blocks.run expected; - Merge_straightline_blocks.run expected; - Eliminate_dead_code.run_dead_block expected; - Simplify_terminator.run (Cfg_with_layout.cfg expected); - let result = recompute_liveness_on_cfg result in - Cfg_equivalence.check_cfg_with_layout ~mach:f expected result; - if ocamlcfg_verbose then begin - Format.eprintf "the CFG on both code paths are equivalent for function %s.\n%!" - f.Mach.fun_name; - end - let reorder_blocks_random ppf_dump cl = match !Flambda_backend_flags.reorder_blocks_random with | None -> cl @@ -345,15 +260,20 @@ let register_allocator : register_allocator = | "" | "upstream" -> Upstream | _ -> Misc.fatal_errorf "unknown register allocator %S" id -let compile_fundecl ?dwarf ~ppf_dump fd_cmm = +let compile_fundecl ~ppf_dump ~funcnames fd_cmm = Proc.init (); Reg.reset(); fd_cmm ++ Profile.record ~accumulate:true "cmm_invariants" (cmm_invariants ppf_dump) - ++ Profile.record ~accumulate:true "selection" Selection.fundecl + ++ Profile.record ~accumulate:true "selection" + (Selection.fundecl ~future_funcnames:funcnames) ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Mach_sel ++ pass_dump_if ppf_dump dump_selection "After instruction selection" - ++ Profile.record ~accumulate:true "save_mach_as_cfg" (save_mach_as_cfg Compiler_pass.Selection) + ++ Profile.record ~accumulate:true "save_mach_as_cfg" + (save_mach_as_cfg Compiler_pass.Selection) + ++ Profile.record ~accumulate:true "polling" + (Polling.instrument_fundecl ~future_funcnames:funcnames) + ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Mach_polling ++ Profile.record ~accumulate:true "comballoc" Comballoc.fundecl ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Mach_combine ++ pass_dump_if ppf_dump dump_combine "After allocation combining" @@ -382,73 +302,91 @@ let compile_fundecl ?dwarf ~ppf_dump fd_cmm = ++ Cfg_with_liveness.cfg_with_layout ++ Profile.record ~accumulate:true "cfg_validate_description" (Cfg_regalloc_validate.run cfg_description) ++ Profile.record ~accumulate:true "cfg_simplify" Cfg_regalloc_utils.simplify_cfg + ++ Profile.record ~accumulate:true "save_cfg" save_cfg + ++ Profile.record ~accumulate:true "cfg_reorder_blocks" + (reorder_blocks_random ppf_dump) ++ Profile.record ~accumulate:true "cfg_to_linear" Cfg_to_linear.run) | true, _ | false, Upstream -> fd ++ Profile.record ~accumulate:true "default" (fun fd -> - let res = - fd - ++ Profile.record ~accumulate:true "liveness" liveness - ++ Profile.record ~accumulate:true "deadcode" Deadcode.fundecl - ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Mach_live - ++ pass_dump_if ppf_dump dump_live "Liveness analysis" - ++ Profile.record ~accumulate:true "spill" Spill.fundecl - ++ Profile.record ~accumulate:true "liveness" liveness - ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Mach_spill - ++ pass_dump_if ppf_dump dump_spill "After spilling" - ++ Profile.record ~accumulate:true "split" Split.fundecl - ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Mach_split - ++ pass_dump_if ppf_dump dump_split "After live range splitting" - ++ Profile.record ~accumulate:true "liveness" liveness - ++ Profile.record ~accumulate:true "regalloc" (regalloc ~ppf_dump 1) - ++ Profile.record ~accumulate:true "available_regs" Available_regs.fundecl - in - res - ++ Profile.record ~accumulate:true "linearize" (fun (f : Mach.fundecl) -> - let res = Linearize.fundecl f in - if !Flambda_backend_flags.cfg_equivalence_check then begin - test_cfgize f res; - end; - res) - ++ pass_dump_linear_if ppf_dump dump_linear "Linearized code")) + fd + ++ Profile.record ~accumulate:true "liveness" liveness + ++ Profile.record ~accumulate:true "deadcode" Deadcode.fundecl + ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Mach_live + ++ pass_dump_if ppf_dump dump_live "Liveness analysis" + ++ Profile.record ~accumulate:true "spill" Spill.fundecl + ++ Profile.record ~accumulate:true "liveness" liveness + ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Mach_spill + ++ pass_dump_if ppf_dump dump_spill "After spilling" + ++ Profile.record ~accumulate:true "split" Split.fundecl + ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Mach_split + ++ pass_dump_if ppf_dump dump_split "After live range splitting" + ++ Profile.record ~accumulate:true "liveness" liveness + ++ Profile.record ~accumulate:true "regalloc" (regalloc ~ppf_dump 1) + ++ Profile.record ~accumulate:true "available_regs" Available_regs.fundecl + ++ Profile.record ~accumulate:true "mach to linear" (fun (fd : Mach.fundecl) -> + if !Flambda_backend_flags.use_ocamlcfg then begin + fd + ++ Profile.record ~accumulate:true "cfgize" + (Cfgize.fundecl + ~before_register_allocation:false + ~preserve_orig_labels:false + ~simplify_terminators:true) + ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Cfg + ++ pass_dump_cfg_if ppf_dump Flambda_backend_flags.dump_cfg "After linear_to_cfg" + ++ Profile.record ~accumulate:true "save_cfg" save_cfg + ++ Profile.record ~accumulate:true "cfg_reorder_blocks" + (reorder_blocks_random ppf_dump) + ++ Profile.record ~accumulate:true "cfg_to_linear" Cfg_to_linear.run + end else begin + fd + ++ Profile.record ~accumulate:true "linearize" Linearize.fundecl + end)) + ++ pass_dump_linear_if ppf_dump dump_linear "Linearized code") ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Linear - ++ Profile.record ~accumulate:true "reorder_blocks" (fun (fd : Linear.fundecl) -> - if !Flambda_backend_flags.use_ocamlcfg then begin - fd - ++ Profile.record ~accumulate:true "linear_to_cfg" - (Linear_to_cfg.run ~preserve_orig_labels:true) - ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Cfg - ++ pass_dump_cfg_if ppf_dump Flambda_backend_flags.dump_cfg "After linear_to_cfg" - ++ Profile.record ~accumulate:true "save_cfg" save_cfg - ++ Profile.record ~accumulate:true "cfg_reorder_blocks" (reorder_blocks_random ppf_dump) - ++ Profile.record ~accumulate:true "cfg_to_linear" Cfg_to_linear.run - ++ pass_dump_linear_if ppf_dump dump_linear "After cfg_to_linear" - end else - fd) ++ Profile.record ~accumulate:true "scheduling" Scheduling.fundecl ++ pass_dump_linear_if ppf_dump dump_scheduling "After instruction scheduling" ++ Profile.record ~accumulate:true "save_linear" save_linear - ++ Profile.record ~accumulate:true "emit_fundecl" (emit_fundecl ~dwarf) + ++ Profile.record ~accumulate:true "emit_fundecl" emit_fundecl let compile_data dl = dl ++ save_data ++ emit_data -let compile_phrase ?dwarf ~ppf_dump p = - if !dump_cmm then fprintf ppf_dump "%a@." Printcmm.phrase p; - match p with - | Cfunction fd -> compile_fundecl ?dwarf ~ppf_dump fd - | Cdata dl -> compile_data dl +let compile_phrases ~ppf_dump ps = + let funcnames = + List.fold_left (fun s p -> + match p with + | Cfunction fd -> String.Set.add fd.fun_name s + | Cdata _ -> s) + String.Set.empty ps + in + let rec compile ~funcnames ps = + match ps with + | [] -> () + | p :: ps -> + if !dump_cmm then fprintf ppf_dump "%a@." Printcmm.phrase p; + match p with + | Cfunction fd -> + compile_fundecl ~ppf_dump ~funcnames fd; + compile ~funcnames:(String.Set.remove fd.fun_name funcnames) ps + | Cdata dl -> + compile_data dl; + compile ~funcnames ps + in + compile ~funcnames ps +let compile_phrase ~ppf_dump p = + compile_phrases ~ppf_dump [p] (* For the native toplevel: generates generic functions unless they are already available in the process *) -let compile_genfuns ?dwarf ~ppf_dump f = +let compile_genfuns ~ppf_dump f = List.iter (function | (Cfunction {fun_name = name}) as ph when f name -> - compile_phrase ?dwarf ~ppf_dump ph + compile_phrase ~ppf_dump ph | _ -> ()) (Cmm_helpers.generic_functions true (Cmm_helpers.Generic_fns_tbl.of_fns @@ -493,103 +431,12 @@ let compile_unit ~output_prefix ~asm_filename ~keep_asm ~obj_filename ~may_reduc if create_asm && not keep_asm then remove_file asm_filename ) -let build_dwarf ~asm_directives:(module Asm_directives : Asm_targets.Asm_directives_intf.S) sourcefile = - let unit_name = - (* CR lmaurer: This doesn't actually need to be an [Ident.t] *) - Symbol.for_current_unit () - |> Symbol.linkage_name - |> Linkage_name.to_string - |> Ident.create_persistent - in - let code_begin = - Cmm_helpers.make_symbol "code_begin" |> Asm_targets.Asm_symbol.create - in - let code_end = - Cmm_helpers.make_symbol "code_end" |> Asm_targets.Asm_symbol.create - in - Dwarf.create - ~sourcefile - ~unit_name - ~asm_directives:(module Asm_directives) - ~get_file_id:(Emitaux.get_file_num ~file_emitter:X86_dsl.D.file) - ~code_begin ~code_end - -let build_asm_directives () : (module Asm_targets.Asm_directives_intf.S) = ( - module Asm_targets.Asm_directives.Make(struct - - let emit_line str = X86_dsl.D.comment str - - let get_file_num file_name = - Emitaux.get_file_num ~file_emitter:X86_dsl.D.file file_name - - let debugging_comments_in_asm_files = - !Flambda_backend_flags.dasm_comments - - module D = struct - open X86_ast - - include X86_dsl.D - - type data_type = - | NONE | DWORD | QWORD - - type nonrec constant = constant - let const_int64 num = Const num - let const_label str = ConstLabel str - let const_add c1 c2 = ConstAdd (c1, c2) - let const_sub c1 c2 = ConstSub (c1, c2) - - let label ?data_type str = - let typ = - Option.map - (function - | NONE -> X86_ast.NONE - | DWORD -> X86_ast.DWORD - | QWORD -> X86_ast.QWORD) - data_type - in - label ?typ str - end - end) - ) - -let emit_begin_assembly_with_dwarf unix ~disable_dwarf ~emit_begin_assembly ~sourcefile () = - if !Flambda_backend_flags.internal_assembler then - (X86_proc.register_internal_assembler (Internal_assembler.assemble unix); - Emitaux.binary_backend_available := true; - Emitaux.create_asm_file := !Clflags.keep_asm_file) - else (); - let no_dwarf () = - emit_begin_assembly ~init_dwarf:(fun () -> ()); - None - in - let can_emit = - !Clflags.debug - && not !Dwarf_flags.restrict_to_upstream_dwarf - && not disable_dwarf - in - match can_emit, Target_system.architecture (), Target_system.derived_system () with - | true, X86_64, _ -> - let asm_directives = build_asm_directives () in - let (module Asm_directives : Asm_targets.Asm_directives_intf.S) = asm_directives in - let dwarf = ref None in - emit_begin_assembly ~init_dwarf:(fun () -> - Asm_targets.Asm_label.initialize ~new_label:Cmm.new_label; - Asm_directives.initialize (); - dwarf := Some (build_dwarf ~asm_directives sourcefile) - ); - !dwarf - | true, _, _ -> no_dwarf () - | false, _, _ -> no_dwarf () - let end_gen_implementation0 unix ?toplevel ~ppf_dump ~sourcefile make_cmm = - let dwarf = - emit_begin_assembly_with_dwarf unix ~disable_dwarf:false ~emit_begin_assembly - ~sourcefile () - in + Emitaux.Dwarf_helpers.init ~disable_dwarf:false sourcefile; + emit_begin_assembly unix; make_cmm () ++ Compiler_hooks.execute_and_pipe Compiler_hooks.Cmm - ++ Profile.record "compile_phrases" (List.iter (compile_phrase ?dwarf ~ppf_dump)) + ++ Profile.record "compile_phrases" (compile_phrases ~ppf_dump) ++ (fun () -> ()); (match toplevel with None -> () | Some f -> compile_genfuns ~ppf_dump f); (* We add explicit references to external primitive symbols. This @@ -597,13 +444,13 @@ let end_gen_implementation0 unix ?toplevel ~ppf_dump ~sourcefile make_cmm = when part of a C library, won't be discarded by the linker. This is important if a module that uses such a symbol is later dynlinked. *) - compile_phrase ~ppf_dump ?dwarf + compile_phrase ~ppf_dump (Cmm_helpers.reference_symbols (List.filter_map (fun prim -> if not (Primitive.native_name_is_external prim) then None else Some (Primitive.native_name prim)) !Translmod.primitive_declarations)); - emit_end_assembly sourcefile dwarf + emit_end_assembly sourcefile () let end_gen_implementation unix ?toplevel ~ppf_dump ~sourcefile clambda = end_gen_implementation0 unix ?toplevel ~ppf_dump ~sourcefile (fun () -> @@ -629,7 +476,8 @@ let compile_implementation unix ?toplevel ~backend ~filename ~prefixname ~obj_filename:(prefixname ^ ext_obj) ~may_reduce_heap:(Option.is_none toplevel) (fun () -> - Ident.Set.iter Compilenv.require_global program.required_globals; + Compilation_unit.Set.iter Compilenv.require_global + program.required_globals; let clambda_with_constants = middle_end ~backend ~filename ~prefixname ~ppf_dump program in @@ -637,16 +485,17 @@ let compile_implementation unix ?toplevel ~backend ~filename ~prefixname clambda_with_constants) let compile_implementation_flambda2 unix ?toplevel ?(keep_symbol_tables=true) - ~filename ~prefixname ~size:module_block_size_in_words ~module_ident + ~filename ~prefixname ~size:module_block_size_in_words ~compilation_unit ~module_initializer ~flambda2 ~ppf_dump ~required_globals () = compile_unit ~ppf_dump ~output_prefix:prefixname ~asm_filename:(asm_filename prefixname) ~keep_asm:!keep_asm_file ~obj_filename:(prefixname ^ ext_obj) ~may_reduce_heap:(Option.is_none toplevel) (fun () -> - Ident.Set.iter Compilenv.require_global required_globals; + Compilation_unit.Set.iter Compilenv.require_global + required_globals; let cmm_phrases = - flambda2 ~ppf_dump ~prefixname ~filename ~module_ident + flambda2 ~ppf_dump ~prefixname ~filename ~compilation_unit ~module_block_size_in_words ~module_initializer ~keep_symbol_tables in @@ -662,17 +511,15 @@ let linear_gen_implementation unix filename = in if not (Compilation_unit.Prefix.equal current_package saved_package) then raise(Error(Mismatched_for_pack saved_package)); - let emit_item ~dwarf = function + let emit_item = function | Data dl -> emit_data dl - | Func f -> emit_fundecl ~dwarf f + | Func f -> emit_fundecl f in start_from_emit := true; - let dwarf = - emit_begin_assembly_with_dwarf unix ~disable_dwarf:false - ~emit_begin_assembly ~sourcefile:filename () - in - Profile.record "Emit" (List.iter (emit_item ~dwarf)) linear_unit_info.items; - emit_end_assembly filename dwarf + Emitaux.Dwarf_helpers.init ~disable_dwarf:false filename; + emit_begin_assembly unix; + Profile.record "Emit" (List.iter emit_item) linear_unit_info.items; + emit_end_assembly filename () let compile_implementation_linear unix output_prefix ~progname = compile_unit ~may_reduce_heap:true ~output_prefix diff --git a/backend/asmgen.mli b/backend/asmgen.mli index e01608f37e3..d7b10201d25 100644 --- a/backend/asmgen.mli +++ b/backend/asmgen.mli @@ -46,19 +46,19 @@ val compile_implementation_flambda2 -> filename:string -> prefixname:string -> size:int - -> module_ident:Ident.t + -> compilation_unit:Compilation_unit.t -> module_initializer:Lambda.lambda -> flambda2:( ppf_dump:Format.formatter -> prefixname:string -> filename:string -> - module_ident:Ident.t -> + compilation_unit:Compilation_unit.t -> module_block_size_in_words:int -> module_initializer:Lambda.lambda -> keep_symbol_tables:bool -> Cmm.phrase list) -> ppf_dump:Format.formatter - -> required_globals:Ident.Set.t + -> required_globals:Compilation_unit.Set.t -> unit -> unit @@ -70,8 +70,7 @@ val compile_implementation_linear -> unit val compile_phrase - : ?dwarf:Dwarf_ocaml.Dwarf.t - -> ppf_dump:Format.formatter + : ppf_dump:Format.formatter -> Cmm.phrase -> unit @@ -92,20 +91,3 @@ val compile_unit -> ppf_dump:Format.formatter -> (unit -> unit) -> unit - -(* First-class module building for DWARF *) - -(* Sets up assembly emitting. - Calls [emit_begin_assembly] (which in most case - should be something similar to [Emit.begin_assembly]). - Might return an instance of [Dwarf_ocaml.Dwarf.t] that can be used to generate - dwarf information for the target system. *) -val emit_begin_assembly_with_dwarf - : (module Compiler_owee.Unix_intf.S) - -> disable_dwarf:bool - -> emit_begin_assembly:(init_dwarf:(unit -> unit) -> unit) - -> sourcefile:string - -> unit - -> Dwarf_ocaml.Dwarf.t option - -val build_asm_directives : unit -> (module Asm_targets.Asm_directives_intf.S) diff --git a/backend/asmlibrarian.ml b/backend/asmlibrarian.ml index 1dd89b1cf3c..8da9cee2e3d 100644 --- a/backend/asmlibrarian.ml +++ b/backend/asmlibrarian.ml @@ -63,17 +63,28 @@ let create_archive file_list lib_name = (fun file_name (unit, crc) -> Asmlink.check_consistency file_name unit crc) file_list descr_list; - let cmis = Asmlink.extract_crc_interfaces () |> Array.of_list in - let cmxs = Asmlink.extract_crc_implementations () |> Array.of_list in - let cmi_index = String.Tbl.create 42 in - Array.iteri (fun i (name, _crc) -> String.Tbl.add cmi_index name i) cmis; - let cmx_index = String.Tbl.create 42 in - Array.iteri (fun i (name, _crc) -> String.Tbl.add cmx_index name i) cmxs; + let cmis = Asmlink.extract_crc_interfaces () in + let cmxs = Asmlink.extract_crc_implementations () in + (* CR mshinwell: see comment in compilenv.ml + let cmxs = + Compilenv.ensure_sharing_between_cmi_and_cmx_imports cmis cmxs + in + *) + let cmis = Array.of_list cmis in + let cmxs = Array.of_list cmxs in + let cmi_index = Compilation_unit.Name.Tbl.create 42 in + Array.iteri (fun i import -> + Compilation_unit.Name.Tbl.add cmi_index (Import_info.name import) i) + cmis; + let cmx_index = Compilation_unit.Tbl.create 42 in + Array.iteri (fun i import -> + Compilation_unit.Tbl.add cmx_index (Import_info.cu import) i) + cmxs; let genfns = Cmm_helpers.Generic_fns_tbl.make () in - let mk_bitmap arr ix entries = + let mk_bitmap arr ix entries ~find ~get_name = let module B = Misc.Bitmap in let b = B.make (Array.length arr) in - entries |> List.iter (fun (name, _crc) -> B.set b (String.Tbl.find ix name)); + List.iter (fun import -> B.set b (find ix (get_name import))) entries; b in let units = @@ -83,8 +94,14 @@ let create_archive file_list lib_name = li_crc = crc; li_defines = unit.ui_defines; li_force_link = unit.ui_force_link; - li_imports_cmi = mk_bitmap cmis cmi_index unit.ui_imports_cmi; - li_imports_cmx = mk_bitmap cmxs cmx_index unit.ui_imports_cmx }) + li_imports_cmi = + mk_bitmap cmis cmi_index unit.ui_imports_cmi + ~find:Compilation_unit.Name.Tbl.find + ~get_name:Import_info.name; + li_imports_cmx = + mk_bitmap cmxs cmx_index unit.ui_imports_cmx + ~find:Compilation_unit.Tbl.find + ~get_name:Import_info.cu }) descr_list in let infos = diff --git a/backend/asmlink.ml b/backend/asmlink.ml index a85a77729ec..c0fff2e9802 100644 --- a/backend/asmlink.ml +++ b/backend/asmlink.ml @@ -26,13 +26,13 @@ module CU = Compilation_unit type error = | File_not_found of filepath | Not_an_object_file of filepath - | Missing_implementations of (Linkage_name.t * string list) list + | Missing_implementations of (CU.t * string list) list | Inconsistent_interface of CU.Name.t * filepath * filepath - | Inconsistent_implementation of CU.Name.t * filepath * filepath + | Inconsistent_implementation of CU.t * filepath * filepath | Assembler_error of filepath | Linking_error of int | Multiple_definition of CU.Name.t * filepath * filepath - | Missing_cmx of filepath * CU.Name.t + | Missing_cmx of filepath * CU.t exception Error of error @@ -47,26 +47,27 @@ type unit_link_info = { (* Consistency check between interfaces and implementations *) -module Cmi_consistbl = Consistbl.Make (CU.Name) +module Cmi_consistbl = Consistbl.Make (CU.Name) (CU) let crc_interfaces = Cmi_consistbl.create () let interfaces = CU.Name.Tbl.create 100 -module Cmx_consistbl = Consistbl.Make (CU.Name) +module Cmx_consistbl = Consistbl.Make (CU) (Unit) let crc_implementations = Cmx_consistbl.create () -let implementations = ref ([] : CU.Name.t list) -let implementations_defined = CU.Name.Tbl.create 100 -let cmx_required = ref ([] : CU.Name.t list) +let implementations = ref ([] : CU.t list) +let implementations_defined = CU.Tbl.create 100 +let cmx_required = ref ([] : CU.t list) let check_cmi_consistency file_name cmis = try Array.iter - (fun (name, crco) -> - let name = name |> CU.Name.of_string in + (fun import -> + let name = Import_info.name import in + let crco = Import_info.crc_with_unit import in CU.Name.Tbl.replace interfaces name (); match crco with None -> () - | Some crc -> - Cmi_consistbl.check crc_interfaces name crc file_name) + | Some (full_name, crc) -> + Cmi_consistbl.check crc_interfaces name full_name crc file_name) cmis with Cmi_consistbl.Inconsistency { unit_name = name; @@ -78,15 +79,16 @@ let check_cmi_consistency file_name cmis = let check_cmx_consistency file_name cmxs = try Array.iter - (fun (name, crco) -> - let name = name |> CU.Name.of_string in + (fun import -> + let name = Import_info.cu import in + let crco = Import_info.crc import in implementations := name :: !implementations; match crco with None -> if List.mem name !cmx_required then raise(Error(Missing_cmx(file_name, name))) | Some crc -> - Cmx_consistbl.check crc_implementations name crc file_name) + Cmx_consistbl.check crc_implementations name () crc file_name) cmxs with Cmx_consistbl.Inconsistency { unit_name = name; @@ -100,26 +102,28 @@ let check_consistency ~unit cmis cmxs = check_cmx_consistency unit.file_name cmxs; let ui_unit = CU.name unit.name in begin try - let source = CU.Name.Tbl.find implementations_defined ui_unit in + let source = CU.Tbl.find implementations_defined unit.name in raise (Error(Multiple_definition(ui_unit, unit.file_name, source))) with Not_found -> () end; - implementations := ui_unit :: !implementations; - Cmx_consistbl.check crc_implementations ui_unit unit.crc unit.file_name; - CU.Name.Tbl.replace implementations_defined ui_unit unit.file_name; + implementations := unit.name :: !implementations; + Cmx_consistbl.check crc_implementations unit.name () unit.crc unit.file_name; + CU.Tbl.replace implementations_defined unit.name unit.file_name; if CU.is_packed unit.name then - cmx_required := ui_unit :: !cmx_required + cmx_required := unit.name :: !cmx_required let extract_crc_interfaces () = CU.Name.Tbl.fold (fun name () crcs -> - (name |> CU.Name.to_string, Cmi_consistbl.find crc_interfaces name) - :: crcs) + let crc_with_unit = Cmi_consistbl.find crc_interfaces name in + Import_info.create name ~crc_with_unit :: crcs) interfaces [] let extract_crc_implementations () = Cmx_consistbl.extract !implementations crc_implementations - |> List.map (fun (name, crc) -> (name |> CU.Name.to_string, crc)) + |> List.map (fun (cu, crc) -> + let crc = Option.map (fun ((), crc) -> crc) crc in + Import_info.create_normal cu ~crc) (* Add C objects and options and "custom" info from a library descriptor. See bytecomp/bytelink.ml for comments on the order of C objects. *) @@ -148,13 +152,14 @@ let runtime_lib () = let missing_globals = (Hashtbl.create 17 : - (Linkage_name.t, (string * CU.Name.t option) list ref) Hashtbl.t) + (CU.t, (string * CU.Name.t option) list ref) Hashtbl.t) let is_required name = try ignore (Hashtbl.find missing_globals name); true with Not_found -> false -let add_required by (name, _crc) = +let add_required by import = + let name = Import_info.cu import in try let rq = Hashtbl.find missing_globals name in rq := by :: !rq @@ -199,33 +204,26 @@ let read_file obj_name = end else raise(Error(Not_an_object_file file_name)) -let linkage_name_of_modname modname = +let assume_no_prefix modname = (* We're the linker, so we assume that everything's already been packed, so no module needs its prefix considered. *) - modname |> Linkage_name.of_string + CU.create CU.Prefix.empty modname let scan_file ~shared genfns file (objfiles, tolink) = match read_file file with | Unit (file_name,info,crc) -> (* This is a .cmx file. It must be linked in any case. *) - let linkage_name = - info.ui_unit - |> Compilation_unit.name - |> Compilation_unit.Name.to_string - |> linkage_name_of_modname - in - remove_required linkage_name; - List.iter (fun (name, crc) -> - let name = name |> linkage_name_of_modname in - add_required (file_name, None) (name, crc)) + remove_required info.ui_unit; + List.iter (fun import -> + add_required (file_name, None) import) info.ui_imports_cmx; let dynunit : Cmxs_format.dynunit option = if not shared then None else - Some { dynu_name = info.ui_unit |> Compilation_unit.name; + Some { dynu_name = info.ui_unit; dynu_crc = crc; dynu_defines = info.ui_defines; - dynu_imports_cmi = info.ui_imports_cmi; - dynu_imports_cmx = info.ui_imports_cmx } + dynu_imports_cmi = info.ui_imports_cmi |> Array.of_list; + dynu_imports_cmx = info.ui_imports_cmx |> Array.of_list } in let unit = { name = info.ui_unit; @@ -264,19 +262,15 @@ let scan_file ~shared genfns file (objfiles, tolink) = List.fold_right (fun info reqd -> let li_name = CU.name info.li_name in - let linkage_name = - li_name |> CU.Name.to_string |> linkage_name_of_modname - in if info.li_force_link || !Clflags.link_everything - || is_required linkage_name + || is_required info.li_name then begin - remove_required linkage_name; + remove_required info.li_name; let req_by = (file_name, Some li_name) in info.li_imports_cmx |> Misc.Bitmap.iter (fun i -> - let modname, digest = infos.lib_imports_cmx.(i) in - let linkage_name = modname |> Linkage_name.of_string in - add_required req_by (linkage_name, digest)); + let import = infos.lib_imports_cmx.(i) in + add_required req_by import); let imports_list tbl bits = List.init (Array.length tbl) (fun i -> if Misc.Bitmap.get bits i then Some tbl.(i) else None) @@ -285,13 +279,15 @@ let scan_file ~shared genfns file (objfiles, tolink) = let dynunit : Cmxs_format.dynunit option = if not shared then None else Some { - dynu_name = li_name; + dynu_name = info.li_name; dynu_crc = info.li_crc; dynu_defines = info.li_defines; dynu_imports_cmi = - imports_list infos.lib_imports_cmi info.li_imports_cmi; + imports_list infos.lib_imports_cmi info.li_imports_cmi + |> Array.of_list; dynu_imports_cmx = - imports_list infos.lib_imports_cmx info.li_imports_cmx } + imports_list infos.lib_imports_cmx info.li_imports_cmx + |> Array.of_list } in let unit = { name = info.li_name; @@ -320,41 +316,41 @@ let make_globals_map units_list = (see the natdynlink code). We can corrupt [interfaces] since it won't be used again until the next compilation. *) + let find_crc name = + Cmi_consistbl.find crc_interfaces name + |> Option.map (fun (_unit, crc) -> crc) + in let defined = List.map (fun unit -> let name = CU.name unit.name in - let intf_crc = Cmi_consistbl.find crc_interfaces name in + let intf_crc = find_crc name in CU.Name.Tbl.remove interfaces name; let syms = List.map Symbol.for_compilation_unit unit.defines in - (CU.name unit.name, intf_crc, Some unit.crc, syms)) + (unit.name, intf_crc, Some unit.crc, syms)) units_list in CU.Name.Tbl.fold (fun name () globals_map -> - let intf_crc = Cmi_consistbl.find crc_interfaces name in - (name, intf_crc, None, []) :: globals_map) + let intf_crc = find_crc name in + (assume_no_prefix name, intf_crc, None, []) :: globals_map) interfaces defined -let make_startup_file unix ~ppf_dump ~named_startup_file ~filename genfns units = +let sourcefile_for_dwarf ~named_startup_file filename = + (* Ensure the name emitted into the DWARF is stable, for build + reproducibility purposes. *) + if named_startup_file then filename + else ".startup" + +let make_startup_file unix ~ppf_dump ~sourcefile_for_dwarf genfns units = Location.input_name := "caml_startup"; (* set name of "current" input *) let startup_comp_unit = CU.create CU.Prefix.empty (CU.Name.of_string "_startup") in Compilenv.reset startup_comp_unit; - let dwarf = - let filename = - (* Ensure the name emitted into the DWARF is stable, for build - reproducibility purposes. *) - if named_startup_file then filename - else ".startup" - in - Asmgen.emit_begin_assembly_with_dwarf unix - ~disable_dwarf:(not !Dwarf_flags.dwarf_for_startup_file) - ~emit_begin_assembly:Emit.begin_assembly - ~sourcefile:filename - () - in - let compile_phrase p = Asmgen.compile_phrase ~ppf_dump ?dwarf p in + Emitaux.Dwarf_helpers.init ~disable_dwarf:(not !Dwarf_flags.dwarf_for_startup_file) + sourcefile_for_dwarf; + Emit.begin_assembly unix; + let compile_phrase p = Asmgen.compile_phrase ~ppf_dump p in let name_list = List.flatten (List.map (fun u -> u.defines) units) in compile_phrase (Cmm_helpers.entry_point name_list); @@ -384,16 +380,18 @@ let make_startup_file unix ~ppf_dump ~named_startup_file ~filename genfns units compile_phrase (Cmm_helpers.frame_table all_comp_units); if !Clflags.output_complete_object then force_linking_of_startup ~ppf_dump; - Emit.end_assembly dwarf + Emit.end_assembly () -let make_shared_startup_file ~ppf_dump genfns units = +let make_shared_startup_file unix ~ppf_dump ~sourcefile_for_dwarf genfns units = let compile_phrase p = Asmgen.compile_phrase ~ppf_dump p in Location.input_name := "caml_startup"; let shared_startup_comp_unit = CU.create CU.Prefix.empty (CU.Name.of_string "_shared_startup") in Compilenv.reset shared_startup_comp_unit; - Emit.begin_assembly ~init_dwarf:(fun () -> ()); + Emitaux.Dwarf_helpers.init ~disable_dwarf:(not !Dwarf_flags.dwarf_for_startup_file) + sourcefile_for_dwarf; + Emit.begin_assembly unix; List.iter compile_phrase (Cmm_helpers.generic_functions true genfns); let dynunits = List.map (fun u -> Option.get u.dynunit) units in @@ -404,35 +402,45 @@ let make_shared_startup_file ~ppf_dump genfns units = force_linking_of_startup ~ppf_dump; (* this is to force a reference to all units, otherwise the linker might drop some of them (in case of libraries) *) - Emit.end_assembly None + Emit.end_assembly () let call_linker_shared file_list output_name = let exitcode = Ccomp.call_linker Ccomp.Dll output_name file_list "" in if not (exitcode = 0) then raise(Error(Linking_error exitcode)) -let link_shared ~ppf_dump objfiles output_name = +let link_shared unix ~ppf_dump objfiles output_name = Profile.record_call output_name (fun () -> + if !Flambda_backend_flags.internal_assembler then + (* CR-soon gyorsh: workaround to turn off internal assembler temporarily, + until it is properly tested for shared library linking. *) + Emitaux.binary_backend_available := false; let genfns = Cmm_helpers.Generic_fns_tbl.make () in let ml_objfiles, units_tolink = List.fold_right (scan_file ~shared:true genfns) objfiles ([],[]) in Clflags.ccobjs := !Clflags.ccobjs @ !lib_ccobjs; Clflags.all_ccopts := !lib_ccopts @ !Clflags.all_ccopts; let objfiles = List.rev ml_objfiles @ List.rev !Clflags.ccobjs in + let named_startup_file = named_startup_file () in let startup = - if named_startup_file () + if named_startup_file then output_name ^ ".startup" ^ ext_asm else Filename.temp_file "camlstartup" ext_asm in let startup_obj = output_name ^ ".startup" ^ ext_obj in + let sourcefile_for_dwarf = sourcefile_for_dwarf ~named_startup_file startup in Asmgen.compile_unit ~output_prefix:output_name ~asm_filename:startup ~keep_asm:!Clflags.keep_startup_file ~obj_filename:startup_obj ~may_reduce_heap:true ~ppf_dump (fun () -> - make_shared_startup_file ~ppf_dump genfns units_tolink + make_shared_startup_file unix ~ppf_dump ~sourcefile_for_dwarf + genfns units_tolink ); call_linker_shared (startup_obj :: objfiles) output_name; + if !Flambda_backend_flags.internal_assembler then + (* CR gyorsh: restore after workaround. *) + Emitaux.binary_backend_available := true; remove_file startup_obj ) @@ -462,7 +470,7 @@ let call_linker file_list_rev startup_file output_name = let reset () = Cmi_consistbl.clear crc_interfaces; Cmx_consistbl.clear crc_implementations; - CU.Name.Tbl.reset implementations_defined; + CU.Tbl.reset implementations_defined; cmx_required := []; CU.Name.Tbl.reset interfaces; implementations := []; @@ -482,8 +490,6 @@ let link unix ~ppf_dump objfiles output_name = let genfns = Cmm_helpers.Generic_fns_tbl.make () in let ml_objfiles, units_tolink = List.fold_right (scan_file ~shared:false genfns) objfiles ([],[]) in - Array.iter (fun name -> remove_required (name |> Linkage_name.of_string)) - Runtimedef.builtin_exceptions; begin match extract_missing_globals() with [] -> () | mg -> raise(Error(Missing_implementations mg)) @@ -496,14 +502,15 @@ let link unix ~ppf_dump objfiles output_name = if named_startup_file then output_name ^ ".startup" ^ ext_asm else Filename.temp_file "camlstartup" ext_asm in + let sourcefile_for_dwarf = sourcefile_for_dwarf ~named_startup_file startup in let startup_obj = Filename.temp_file "camlstartup" ext_obj in Asmgen.compile_unit ~output_prefix:output_name ~asm_filename:startup ~keep_asm:!Clflags.keep_startup_file ~obj_filename:startup_obj ~may_reduce_heap:true ~ppf_dump - (fun () -> make_startup_file unix ~ppf_dump ~named_startup_file - ~filename:startup genfns units_tolink); + (fun () -> make_startup_file unix ~ppf_dump + ~sourcefile_for_dwarf genfns units_tolink); Emitaux.reduce_heap_size ~reset:(fun () -> reset ()); Misc.try_finally (fun () -> call_linker ml_objfiles startup_obj output_name) @@ -542,7 +549,7 @@ let report_error ppf = function List.iter (fun (md, rq) -> fprintf ppf "@ @[%a referenced from %a@]" - Linkage_name.print md + CU.print md print_references rq) in fprintf ppf "@[No implementations provided for the following modules:%a@]" @@ -560,7 +567,7 @@ let report_error ppf = function over implementation %a@]" Location.print_filename file1 Location.print_filename file2 - CU.Name.print intf + CU.print intf | Assembler_error file -> fprintf ppf "Error while assembling %a" Location.print_filename file | Linking_error exitcode -> @@ -579,9 +586,9 @@ let report_error ppf = function Please recompile %a@ with the correct `-I' option@ \ so that %a.cmx@ is found.@]" Location.print_filename filename - CU.Name.print name + CU.print name Location.print_filename filename - CU.Name.print name + CU.print name let () = Location.register_error_of_exn diff --git a/backend/asmlink.mli b/backend/asmlink.mli index f23faa90448..cf982631c94 100644 --- a/backend/asmlink.mli +++ b/backend/asmlink.mli @@ -21,25 +21,26 @@ open Format val link: (module Compiler_owee.Unix_intf.S) -> ppf_dump:formatter -> string list -> string -> unit -val link_shared: ppf_dump:formatter -> string list -> string -> unit +val link_shared: (module Compiler_owee.Unix_intf.S) -> + ppf_dump:formatter -> string list -> string -> unit val call_linker_shared: string list -> string -> unit val reset : unit -> unit val check_consistency: filepath -> Cmx_format.unit_infos -> Digest.t -> unit -val extract_crc_interfaces: unit -> crcs -val extract_crc_implementations: unit -> crcs +val extract_crc_interfaces: unit -> Import_info.t list +val extract_crc_implementations: unit -> Import_info.t list type error = | File_not_found of filepath | Not_an_object_file of filepath - | Missing_implementations of (Linkage_name.t * string list) list + | Missing_implementations of (Compilation_unit.t * string list) list | Inconsistent_interface of Compilation_unit.Name.t * filepath * filepath - | Inconsistent_implementation of Compilation_unit.Name.t * filepath * filepath + | Inconsistent_implementation of Compilation_unit.t * filepath * filepath | Assembler_error of filepath | Linking_error of int | Multiple_definition of Compilation_unit.Name.t * filepath * filepath - | Missing_cmx of filepath * Compilation_unit.Name.t + | Missing_cmx of filepath * Compilation_unit.t exception Error of error diff --git a/backend/asmpackager.ml b/backend/asmpackager.ml index 5ff48597478..5e433e761ec 100644 --- a/backend/asmpackager.ml +++ b/backend/asmpackager.ml @@ -23,7 +23,7 @@ module CU = Compilation_unit type error = Illegal_renaming of CU.Name.t * string * CU.Name.t - | Forward_reference of string * string + | Forward_reference of string * CU.Name.t | Wrong_for_pack of string * CU.t | Linking_error | Assembler_error of string @@ -71,9 +71,11 @@ let check_units members = | PM_intf -> () | PM_impl infos -> List.iter - (fun (unit, _) -> - if List.mem (unit |> Compilation_unit.Name.of_string) forbidden - then raise(Error(Forward_reference(mb.pm_file, unit)))) + (fun import -> + let unit = Import_info.cu import in + let name = CU.name unit in + if List.mem name forbidden + then raise(Error(Forward_reference(mb.pm_file, name)))) infos.ui_imports_cmx end; check (list_remove mb.pm_name forbidden) tl in @@ -102,11 +104,13 @@ let make_package_object unix ~ppf_dump members targetobj targetname coercion (fun m -> match m.pm_kind with | PM_intf -> None - | PM_impl _ -> Some(CU.Name.persistent_ident m.pm_name)) + | PM_impl _ -> Some(CU.create_child (CU.get_current_exn ()) m.pm_name)) members in - let module_ident = Ident.create_persistent targetname in + let for_pack_prefix = CU.Prefix.from_clflags () in + let modname = CU.Name.of_string targetname in + let compilation_unit = CU.create for_pack_prefix modname in let prefixname = Filename.remove_extension objtemp in - let required_globals = Ident.Set.empty in + let required_globals = Compilation_unit.Set.empty in if Config.flambda2 then begin let main_module_block_size, module_initializer = Translmod.transl_package_flambda components coercion @@ -116,7 +120,7 @@ let make_package_object unix ~ppf_dump members targetobj targetname coercion ~filename:targetname ~prefixname ~size:main_module_block_size - ~module_ident + ~compilation_unit ~module_initializer ~flambda2 ~ppf_dump @@ -134,7 +138,7 @@ let make_package_object unix ~ppf_dump members targetobj targetname coercion { Lambda. code; main_module_block_size; - module_ident; + compilation_unit; required_globals; } in @@ -142,14 +146,14 @@ let make_package_object unix ~ppf_dump members targetobj targetname coercion else let main_module_block_size, code = Translmod.transl_store_package components - (Ident.create_persistent targetname) coercion + compilation_unit coercion in let code = Simplif.simplify_lambda code in let program = { Lambda. code; main_module_block_size; - module_ident; + compilation_unit; required_globals; } in @@ -200,8 +204,8 @@ let build_package_cmx members cmxfile = let unit_names = List.map (fun m -> m.pm_name) members in let filter lst = - List.filter (fun (name, _crc) -> - not (List.mem (name |> CU.Name.of_string) unit_names)) lst in + List.filter (fun import -> + not (List.mem (Import_info.name import) unit_names)) lst in let union lst = List.fold_left (List.fold_left @@ -212,54 +216,23 @@ let build_package_cmx members cmxfile = (fun m accu -> match m.pm_kind with PM_intf -> accu | PM_impl info -> info :: accu) members [] in - let pack_units : Compilation_unit.Set.t lazy_t = - lazy (List.map (fun info -> info.ui_unit) units - |> Compilation_unit.Set.of_list) - in let ui = Compilenv.current_unit_infos() in - let pack = - (* CR-soon lmaurer: This is horrific, but the whole [import_for_pack] - business is about to go away. *) - Compilation_unit.Prefix.parse_for_pack - (Some (Compilation_unit.full_path_as_string ui.ui_unit)) - in - let units : Cmx_format.unit_infos list = - if Config.flambda then - List.map (fun info -> - { info with - ui_export_info = - Flambda1 - (Export_info_for_pack.import_for_pack ~pack_units:(Lazy.force pack_units) - ~pack - (get_export_info_flambda1 info)) }) - units - else - units - in let ui_export_info = if Config.flambda then let ui_export_info = List.fold_left (fun acc info -> Export_info.merge acc - (Export_info_for_pack.import_for_pack ~pack_units:(Lazy.force pack_units) - ~pack - (get_export_info_flambda1 info))) + (get_export_info_flambda1 info)) (get_export_info_flambda1 ui) units in Flambda1 ui_export_info else if Config.flambda2 then - let pack = Compilation_unit.get_current_exn () in let flambda_export_info = List.fold_left (fun acc info -> Flambda2_cmx.Flambda_cmx_format.merge - (Flambda2_cmx.Flambda_cmx_format.update_for_pack - ~pack_units:(Lazy.force pack_units) ~pack - (get_export_info_flambda2 info)) - acc) - (Flambda2_cmx.Flambda_cmx_format.update_for_pack - ~pack_units:(Lazy.force pack_units) ~pack - (get_export_info_flambda2 ui)) + (get_export_info_flambda2 info) acc) + (get_export_info_flambda2 ui) units in Flambda2 flambda_export_info @@ -268,16 +241,16 @@ let build_package_cmx members cmxfile = in let ui_checks = Compilenv.Checks.create () in List.iter (fun info -> Compilenv.Checks.merge info.ui_checks ~into:ui_checks) units; - Export_info_for_pack.clear_import_state (); - let ui_unit_as_string = CU.Name.to_string (CU.name ui.ui_unit) in + let modname = Compilation_unit.name ui.ui_unit in let pkg_infos = { ui_unit = ui.ui_unit; ui_defines = List.flatten (List.map (fun info -> info.ui_defines) units) @ [ui.ui_unit]; ui_imports_cmi = - (ui_unit_as_string, Some (Env.crc_of_unit ui_unit_as_string)) :: - filter(Asmlink.extract_crc_interfaces()); + (Import_info.create modname + ~crc_with_unit:(Some (ui.ui_unit, Env.crc_of_unit modname))) :: + filter (Asmlink.extract_crc_interfaces ()); ui_imports_cmx = filter(Asmlink.extract_crc_implementations()); ui_generic_fns = @@ -333,7 +306,7 @@ let package_files unix ~ppf_dump initial_env files targetcmx ~backend Compilenv.reset comp_unit; Misc.try_finally (fun () -> let coercion = - Typemod.package_units initial_env files targetcmi targetname in + Typemod.package_units initial_env files targetcmi comp_unit in package_object_files unix ~ppf_dump files targetcmx targetobj targetname coercion ~backend ~flambda2 ) @@ -349,7 +322,7 @@ let report_error ppf = function @ %a when %a was expected" Location.print_filename file CU.Name.print name CU.Name.print id | Forward_reference(file, ident) -> - fprintf ppf "Forward reference to %s in file %a" ident + fprintf ppf "Forward reference to %a in file %a" CU.Name.print ident Location.print_filename file | Wrong_for_pack(file, path) -> fprintf ppf "File %a@ was not compiled with the `-for-pack %a' option" diff --git a/backend/asmpackager.mli b/backend/asmpackager.mli index 7b63ffe5e47..58c1c9dfcd0 100644 --- a/backend/asmpackager.mli +++ b/backend/asmpackager.mli @@ -27,7 +27,7 @@ val package_files ppf_dump:Format.formatter -> prefixname:string -> filename:string -> - module_ident:Ident.t -> + compilation_unit:Compilation_unit.t -> module_block_size_in_words:int -> module_initializer:Lambda.lambda -> keep_symbol_tables:bool -> @@ -36,7 +36,7 @@ val package_files type error = Illegal_renaming of Compilation_unit.Name.t * string * Compilation_unit.Name.t - | Forward_reference of string * string + | Forward_reference of string * Compilation_unit.Name.t | Wrong_for_pack of string * Compilation_unit.t | Linking_error | Assembler_error of string diff --git a/backend/branch_relaxation.ml b/backend/branch_relaxation.ml index c91fb32b3dc..d4f1a0ef575 100644 --- a/backend/branch_relaxation.ml +++ b/backend/branch_relaxation.ml @@ -51,6 +51,7 @@ module Make (T : Branch_relaxation_intf.S) = struct in match instr.desc with | Lop (Ialloc _) + | Lop (Ipoll { return_label = None }) | Lop (Iintop (Icheckbound)) | Lop (Iintop_imm (Icheckbound, _)) | Lop (Ispecific _) -> @@ -64,6 +65,11 @@ module Make (T : Branch_relaxation_intf.S) = struct opt_branch_overflows map pc lbl0 max_branch_offset || opt_branch_overflows map pc lbl1 max_branch_offset || opt_branch_overflows map pc lbl2 max_branch_offset + | Lop (Ipoll { return_label = Some lbl }) -> + (* A poll-and-branch instruction can branch to the label lbl, + but also to an out-of-line code block. *) + code_size + max_out_of_line_code_offset - pc >= max_branch_offset + || branch_overflows map pc lbl max_branch_offset | _ -> Misc.fatal_error "Unsupported instruction for branch relaxation" @@ -86,6 +92,9 @@ module Make (T : Branch_relaxation_intf.S) = struct fixup did_fix (pc + T.instr_size instr.desc) instr.next else match instr.desc with + | Lop (Ipoll { return_label }) -> + instr.desc <- T.relax_poll ~return_label; + fixup true (pc + T.instr_size instr.desc) instr.next | Lop (Ialloc { bytes = num_bytes; dbginfo }) -> instr.desc <- T.relax_allocation ~num_bytes ~dbginfo; fixup true (pc + T.instr_size instr.desc) instr.next diff --git a/backend/branch_relaxation_intf.ml b/backend/branch_relaxation_intf.ml index 57127e5153e..073d39ef77e 100644 --- a/backend/branch_relaxation_intf.ml +++ b/backend/branch_relaxation_intf.ml @@ -39,6 +39,7 @@ module type S = sig N.B. The only instructions supported are the following: - Lop (Ialloc _) + - Lop (Ipoll _) - Lop (Iintop Icheckbound) - Lop (Iintop_imm (Icheckbound, _)) - Lop (Ispecific _) @@ -64,6 +65,11 @@ module type S = sig : num_bytes:int -> dbginfo:Debuginfo.alloc_dbginfo -> Linear.instruction_desc + + val relax_poll + : return_label:Cmm.label option + -> Linear.instruction_desc + val relax_intop_checkbound : unit -> Linear.instruction_desc diff --git a/backend/cfg/cfg.ml b/backend/cfg/cfg.ml index c53d07591a2..001329b5fd9 100644 --- a/backend/cfg/cfg.ml +++ b/backend/cfg/cfg.ml @@ -29,9 +29,78 @@ let verbose = ref false include Cfg_intf.S +module BasicInstructionList = struct + type instr = basic instruction + + type cell = + { instr : instr; + mutable before_rev : instr list; + mutable after : instr list + } + + let insert_before cell instr = cell.before_rev <- instr :: cell.before_rev + + let insert_after cell instr = cell.after <- instr :: cell.after + + let instr cell = cell.instr + + type t = instr list ref + + let make_empty () = ref [] + + let make_single instr = ref [instr] + + let of_list l = ref l + + let hd t = match !t with [] -> None | hd :: _ -> Some hd + + let last t = + let rec loop = function + | [] -> None + | [last] -> Some last + | _ :: tl -> loop tl + in + loop !t + + let add_begin t instr = t := instr :: !t + + let add_end t instr = t := !t @ [instr] + + let is_empty t = match !t with [] -> true | _ :: _ -> false + + let length t = ListLabels.length !t + + let filter_left t ~f = t := ListLabels.filter ~f !t + + let filter_right t ~f = + t + := ListLabels.fold_right + ~f:(fun elem acc -> if f elem then elem :: acc else acc) + !t ~init:[] + + let iter t ~f = ListLabels.iter ~f !t + + let iter_cell t ~f = + t + := ListLabels.concat_map !t ~f:(fun instr -> + let cell = { instr; before_rev = []; after = [] } in + f cell; + List.rev cell.before_rev @ [instr] @ cell.after) + + let iter2 t t' ~f = ListLabels.iter2 ~f !t !t' + + let fold_left t ~f ~init = ListLabels.fold_left ~f ~init !t + + let fold_right t ~f ~init = ListLabels.fold_right ~f !t ~init + + let transfer ~to_:t ~from:t' () = + t := !t @ !t'; + t' := [] +end + type basic_block = { start : Label.t; - mutable body : basic instruction list; + body : BasicInstructionList.t; mutable terminator : terminator instruction; mutable predecessors : Label.Set.t; mutable stack_offset : int; @@ -69,9 +138,9 @@ let mem_block t label = Label.Tbl.mem t.blocks label let successor_labels_normal ti = match ti.desc with - | Tailcall (Self { destination }) -> Label.Set.singleton destination + | Tailcall_self { destination } -> Label.Set.singleton destination | Switch labels -> Array.to_seq labels |> Label.Set.of_seq - | Return | Raise _ | Tailcall (Func _) -> Label.Set.empty + | Return | Raise _ | Tailcall_func _ -> Label.Set.empty | Call_no_return _ -> Label.Set.empty | Never -> Label.Set.empty | Always l -> Label.Set.singleton l @@ -82,6 +151,11 @@ let successor_labels_normal ti = |> Label.Set.add uo | Int_test { lt; gt; eq; imm = _; is_signed = _ } -> Label.Set.singleton lt |> Label.Set.add gt |> Label.Set.add eq + | Call { op = _; label_after } + | Prim { op = _; label_after } + | Specific_can_raise { op = _; label_after } -> + Label.Set.singleton label_after + | Poll_and_jump return_label -> Label.Set.singleton return_label let successor_labels ~normal ~exn block = match normal, exn with @@ -126,21 +200,38 @@ let replace_successor_labels t ~normal ~exn block ~f = | Float_test { lt; eq; gt; uo } -> Float_test { lt = f lt; eq = f eq; gt = f gt; uo = f uo } | Switch labels -> Switch (Array.map f labels) - | Tailcall (Self { destination }) -> - Tailcall (Self { destination = f destination }) - | Tailcall (Func Indirect) - | Tailcall (Func (Direct _)) + | Tailcall_self { destination } -> + Tailcall_self { destination = f destination } + | Tailcall_func Indirect + | Tailcall_func (Direct _) | Return | Raise _ | Call_no_return _ -> block.terminator.desc + | Poll_and_jump return_label -> Poll_and_jump (f return_label) + | Call { op; label_after } -> Call { op; label_after = f label_after } + | Prim { op; label_after } -> Prim { op; label_after = f label_after } + | Specific_can_raise { op; label_after } -> + Specific_can_raise { op; label_after = f label_after } in block.terminator <- { block.terminator with desc } +let add_block_exn t block = + if Label.Tbl.mem t.blocks block.start + then + Misc.fatal_errorf "Cfg.add_block_exn: block %d is already present" + block.start; + Label.Tbl.add t.blocks block.start block + let remove_block_exn t label = match Label.Tbl.find t.blocks label with | exception Not_found -> Misc.fatal_errorf "Cfg.remove_block_exn: block %d not found" label | _ -> Label.Tbl.remove t.blocks label +let remove_blocks t labels_to_remove = + Label.Tbl.filter_map_inplace + (fun l b -> if Label.Set.mem l labels_to_remove then None else Some b) + t.blocks + let get_block t label = Label.Tbl.find_opt t.blocks label let get_block_exn t label = @@ -151,6 +242,11 @@ let get_block_exn t label = let can_raise_interproc block = block.can_raise && Option.is_none block.exn +let first_instruction_id (block : basic_block) : int = + match BasicInstructionList.hd block.body with + | None -> block.terminator.id + | Some first_instr -> first_instr.id + let fun_name t = t.fun_name let entry_label t = t.entry_label @@ -185,6 +281,9 @@ let intcomp (comp : Mach.integer_comparison) = | Isigned c -> Printf.sprintf " %ss " (Printcmm.integer_comparison c) | Iunsigned c -> Printf.sprintf " %su " (Printcmm.integer_comparison c) +let intop_atomic (op : Cmm.atomic_op) = + match op with Fetch_and_add -> " += " | Compare_and_swap -> " cas " + let intop (op : Mach.integer_operation) = match op with | Iadd -> " + " @@ -205,8 +304,7 @@ let intop (op : Mach.integer_operation) = | Icomp cmp -> intcomp cmp | Icheckbound -> assert false -let dump_op ?(specific = fun ppf _ -> Format.fprintf ppf "specific") ppf = - function +let dump_op ppf = function | Move -> Format.fprintf ppf "mov" | Spill -> Format.fprintf ppf "spill" | Reload -> Format.fprintf ppf "reload" @@ -218,6 +316,8 @@ let dump_op ?(specific = fun ppf _ -> Format.fprintf ppf "specific") ppf = | Store _ -> Format.fprintf ppf "store" | Intop op -> Format.fprintf ppf "intop %s" (intop op) | Intop_imm (op, n) -> Format.fprintf ppf "intop %s %d" (intop op) n + | Intop_atomic { op; size = _; addr = _ } -> + Format.fprintf ppf "intop atomic %s" (intop_atomic op) | Negf -> Format.fprintf ppf "negf" | Absf -> Format.fprintf ppf "absf" | Addf -> Format.fprintf ppf "addf" @@ -225,44 +325,30 @@ let dump_op ?(specific = fun ppf _ -> Format.fprintf ppf "specific") ppf = | Mulf -> Format.fprintf ppf "mulf" | Divf -> Format.fprintf ppf "divf" | Compf _ -> Format.fprintf ppf "compf" + | Csel _ -> Format.fprintf ppf "csel" | Floatofint -> Format.fprintf ppf "floattoint" | Intoffloat -> Format.fprintf ppf "intoffloat" | Valueofint -> Format.fprintf ppf "valueofint" | Intofvalue -> Format.fprintf ppf "intofvalue" - | Specific op -> specific ppf op - | Probe { name; handler_code_sym } -> - Format.fprintf ppf "probe %s %s" name handler_code_sym + | Specific _ -> Format.fprintf ppf "specific" | Probe_is_enabled { name } -> Format.fprintf ppf "probe_is_enabled %s" name | Opaque -> Format.fprintf ppf "opaque" | Begin_region -> Format.fprintf ppf "beginregion" | End_region -> Format.fprintf ppf "endregion" | Name_for_debugger _ -> Format.fprintf ppf "name_for_debugger" -let dump_call ppf = function - | P prim_call -> ( - match prim_call with - | External { func_symbol : string; _ } -> - Format.fprintf ppf "external %s" func_symbol - | Alloc { bytes : int; _ } -> Format.fprintf ppf "alloc %d" bytes - | Checkbound _ -> Format.fprintf ppf "checkbound") - | F func_call -> ( - match func_call with - | Indirect -> Format.fprintf ppf "indirect" - | Direct { func_symbol : string; _ } -> - Format.fprintf ppf "direct %s" func_symbol) - let dump_basic ppf (basic : basic) = let open Format in match basic with | Op op -> dump_op ppf op - | Call call -> fprintf ppf "Call %a" dump_call call | Reloadretaddr -> fprintf ppf "Reloadretaddr" | Pushtrap { lbl_handler } -> fprintf ppf "Pushtrap handler=%d" lbl_handler | Poptrap -> fprintf ppf "Poptrap" | Prologue -> fprintf ppf "Prologue" -let dump_terminator' ?(print_reg = Printmach.reg) ?(args = [||]) ?(sep = "\n") - ppf (terminator : terminator) = +let dump_terminator' ?(print_reg = Printmach.reg) ?(res = [||]) ?(args = [||]) + ?(specific_can_raise = fun ppf _ -> Format.fprintf ppf "specific_can_raise") + ?(sep = "\n") ppf (terminator : terminator) = let first_arg = if Array.length args >= 1 then Format.fprintf Format.str_formatter " %a" print_reg args.(0); @@ -278,6 +364,11 @@ let dump_terminator' ?(print_reg = Printmach.reg) ?(args = [||]) ?(sep = "\n") then () else Format.fprintf ppf " %a" (Printmach.regs' ~print_reg) args in + let print_res ppf = + if Array.length res > 0 + then Format.fprintf ppf "%a := " (Printmach.regs' ~print_reg) res + in + let dump_mach_op ppf op = Printmach.operation' ~print_reg op args ppf [||] in let open Format in match terminator with | Never -> fprintf ppf "deadend" @@ -314,8 +405,36 @@ let dump_terminator' ?(print_reg = Printmach.reg) ?(args = [||]) ?(sep = "\n") fprintf ppf "Call_no_return %s%a" func_symbol print_args args | Return -> fprintf ppf "Return%a" print_args args | Raise _ -> fprintf ppf "Raise%a" print_args args - | Tailcall (Self _) -> fprintf ppf "Tailcall self%a" print_args args - | Tailcall (Func _) -> fprintf ppf "Tailcall%a" print_args args + | Tailcall_self { destination } -> + dump_mach_op ppf + (Mach.Itailcall_imm { func = Printf.sprintf "self(%d)" destination }) + | Tailcall_func call -> + dump_mach_op ppf + (match call with + | Indirect -> Mach.Itailcall_ind + | Direct { func_symbol = func } -> Mach.Itailcall_imm { func }) + | Call { op = call; label_after } -> + Format.fprintf ppf "%t%a" print_res dump_mach_op + (match call with + | Indirect -> Mach.Icall_ind + | Direct { func_symbol = func } -> Mach.Icall_imm { func }); + Format.fprintf ppf "%sgoto %d" sep label_after + | Prim { op = prim; label_after } -> + Format.fprintf ppf "%t%a" print_res dump_mach_op + (match prim with + | External { func_symbol = func; ty_res; ty_args; alloc } -> + Mach.Iextcall { func; ty_res; ty_args; returns = true; alloc } + | Alloc { bytes; dbginfo; mode } -> Mach.Ialloc { bytes; dbginfo; mode } + | Checkbound { immediate = Some x } -> Mach.Iintop_imm (Icheckbound, x) + | Checkbound { immediate = None } -> Mach.Iintop Icheckbound + | Probe { name; handler_code_sym } -> + Mach.Iprobe { name; handler_code_sym }); + Format.fprintf ppf "%sgoto %d" sep label_after + | Specific_can_raise { op; label_after } -> + Format.fprintf ppf "%a" specific_can_raise op; + Format.fprintf ppf "%sgoto %d" sep label_after + | Poll_and_jump return_label -> + Format.fprintf ppf "Poll_and_jump %a" Label.print return_label let dump_terminator ?sep ppf terminator = dump_terminator' ?sep ppf terminator @@ -336,9 +455,11 @@ let print_basic' ?print_reg ppf (instruction : basic instruction) = let print_basic ppf i = print_basic' ppf i let print_terminator' ?print_reg ppf (ti : terminator instruction) = - if Array.length ti.res > 0 - then Format.fprintf ppf "%a := " (Printmach.regs' ?print_reg) ti.res; - dump_terminator' ?print_reg ~args:ti.arg ~sep:"\n" ppf ti.desc + dump_terminator' ?print_reg + ~specific_can_raise:(fun ppf op -> + (* Print this as basic instruction. *) + print_basic' ?print_reg ppf { ti with desc = Op (Specific op) }) + ~res:ti.res ~args:ti.arg ~sep:"\n" ppf ti.desc let print_terminator ppf ti = print_terminator' ppf ti @@ -351,58 +472,27 @@ let print_instruction ppf i = print_instruction' ppf i let can_raise_terminator (i : terminator) = match i with - | Raise _ | Tailcall (Func _) | Call_no_return _ -> true + | Raise _ | Tailcall_func _ | Call_no_return _ | Call _ | Prim _ -> true + | Specific_can_raise { op; _ } -> + assert (Arch.operation_can_raise op); + true + | Poll_and_jump _ -> true | Never | Always _ | Parity_test _ | Truth_test _ | Float_test _ | Int_test _ - | Switch _ | Return - | Tailcall (Self _) -> + | Switch _ | Return | Tailcall_self _ -> false -let can_raise_operation : operation -> bool = function - | Move -> false - | Spill -> false - | Reload -> false - | Const_int _ -> false - | Const_float _ -> false - | Const_symbol _ -> false - | Stackoffset _ -> false - | Load _ -> false - | Store _ -> false - | Intop _ -> false - | Intop_imm _ -> false - | Negf -> false - | Absf -> false - | Addf -> false - | Subf -> false - | Mulf -> false - | Divf -> false - | Compf _ -> false - | Floatofint -> false - | Intoffloat -> false - | Valueofint -> false - | Intofvalue -> false - | Probe _ -> true - | Probe_is_enabled _ -> false - | Specific op -> Arch.operation_can_raise op - | Opaque -> false - | Name_for_debugger _ -> false - | Begin_region -> false - | End_region -> false - -let can_raise_basic : basic -> bool = function - | Op op -> can_raise_operation op - | Call (P (Alloc _)) -> false - | Call (P (External _ | Checkbound _)) | Call (F _) -> true - | Reloadretaddr -> false - | Pushtrap _ -> false - | Poptrap -> false - | Prologue -> false - (* CR gyorsh: [is_pure_terminator] is not the same as [can_raise_terminator] because of [Tailcal Self] which is not pure but marked as cannot raise at the moment, which we might want to reconsider later. *) let is_pure_terminator desc = match (desc : terminator) with - | Raise _ | Call_no_return _ | Tailcall _ | Return -> false + | Return | Raise _ | Call_no_return _ | Tailcall_func _ | Tailcall_self _ + | Call _ | Prim _ -> + false + | Specific_can_raise { op; _ } -> + assert (Arch.operation_can_raise op); + false + | Poll_and_jump _ -> false | Never | Always _ | Parity_test _ | Truth_test _ | Float_test _ | Int_test _ | Switch _ -> (* CR gyorsh: fix for memory operands *) @@ -420,6 +510,7 @@ let is_pure_operation : operation -> bool = function | Store _ -> false | Intop _ -> true | Intop_imm _ -> true + | Intop_atomic _ -> false | Negf -> true | Absf -> true | Addf -> true @@ -427,23 +518,24 @@ let is_pure_operation : operation -> bool = function | Mulf -> true | Divf -> true | Compf _ -> true + | Csel _ -> true | Floatofint -> true | Intoffloat -> true (* Conservative to ensure valueofint/intofvalue are not eliminated before emit. *) | Valueofint -> false | Intofvalue -> false - | Probe _ -> false | Probe_is_enabled _ -> true | Opaque -> false | Begin_region -> false | End_region -> false - | Specific s -> Arch.operation_is_pure s + | Specific s -> + assert (not (Arch.operation_can_raise s)); + Arch.operation_is_pure s | Name_for_debugger _ -> true let is_pure_basic : basic -> bool = function | Op op -> is_pure_operation op - | Call _ -> false | Reloadretaddr -> (* This is a no-op on supported backends but on some others like "power" it wouldn't be. Saying it's not pure doesn't decrease the generated code @@ -467,13 +559,21 @@ let is_noop_move instr = | Unknown -> false | Reg _ | Stack _ -> Reg.same_loc instr.arg.(0) instr.res.(0)) && Proc.register_class instr.arg.(0) = Proc.register_class instr.res.(0) + | Op (Csel _) -> ( + match instr.res.(0).loc with + | Unknown -> false + | Reg _ | Stack _ -> + let len = Array.length instr.arg in + let ifso = instr.arg.(len - 2) in + let ifnot = instr.arg.(len - 1) in + Reg.same_loc instr.res.(0) ifso && Reg.same_loc instr.res.(0) ifnot) | Op ( Const_int _ | Const_float _ | Const_symbol _ | Stackoffset _ | Load _ - | Store _ | Intop _ | Intop_imm _ | Negf | Absf | Addf | Subf | Mulf - | Divf | Compf _ | Floatofint | Intoffloat | Intofvalue | Valueofint - | Probe _ | Opaque | Probe_is_enabled _ | Specific _ | Name_for_debugger _ - | Begin_region | End_region ) - | Call _ | Reloadretaddr | Pushtrap _ | Poptrap | Prologue -> + | Store _ | Intop _ | Intop_imm _ | Intop_atomic _ | Negf | Absf | Addf + | Subf | Mulf | Divf | Compf _ | Floatofint | Intoffloat | Opaque + | Valueofint | Intofvalue | Probe_is_enabled _ | Specific _ + | Name_for_debugger _ | Begin_region | End_region ) + | Reloadretaddr | Pushtrap _ | Poptrap | Prologue -> false let set_stack_offset (instr : _ instruction) stack_offset = @@ -481,12 +581,7 @@ let set_stack_offset (instr : _ instruction) stack_offset = then Misc.fatal_errorf "Cfg.set_stack_offset: expected non-negative got %d" stack_offset; - if instr.stack_offset = stack_offset - then instr - else { instr with stack_offset } - -let set_live (instr : _ instruction) live = - if Reg.Set.equal instr.live live then instr else { instr with live } + instr.stack_offset <- stack_offset let string_of_irc_work_list = function | Unknown_list -> "unknown_list" diff --git a/backend/cfg/cfg.mli b/backend/cfg/cfg.mli index 1e456825bc4..e4bfc74545a 100644 --- a/backend/cfg/cfg.mli +++ b/backend/cfg/cfg.mli @@ -31,9 +31,58 @@ include module type of struct include Cfg_intf.S end +module BasicInstructionList : sig + type instr = basic instruction + + type cell + + val insert_before : cell -> instr -> unit + + val insert_after : cell -> instr -> unit + + val instr : cell -> instr + + type t + + val make_empty : unit -> t + + val make_single : instr -> t + + val of_list : instr list -> t + + val hd : t -> instr option + + val last : t -> instr option + + val add_begin : t -> instr -> unit + + val add_end : t -> instr -> unit + + val is_empty : t -> bool + + val length : t -> int + + val filter_left : t -> f:(instr -> bool) -> unit + + val filter_right : t -> f:(instr -> bool) -> unit + + val iter : t -> f:(instr -> unit) -> unit + + val iter_cell : t -> f:(cell -> unit) -> unit + + val iter2 : t -> t -> f:(instr -> instr -> unit) -> unit + + val fold_left : t -> f:('a -> instr -> 'a) -> init:'a -> 'a + + val fold_right : t -> f:(instr -> 'a -> 'a) -> init:'a -> 'a + + (* Adds all of the elements of `from` to `to_`, and clears `from`. *) + val transfer : to_:t -> from:t -> unit -> unit +end + type basic_block = { start : Label.t; - mutable body : basic instruction list; + body : BasicInstructionList.t; mutable terminator : terminator instruction; mutable predecessors : Label.Set.t; (** All predecessors, both normal and exceptional paths. *) @@ -109,10 +158,16 @@ val replace_successor_labels : vice versa. *) val can_raise_interproc : basic_block -> bool +val first_instruction_id : basic_block -> int + val mem_block : t -> Label.t -> bool +val add_block_exn : t -> basic_block -> unit + val remove_block_exn : t -> Label.t -> unit +val remove_blocks : t -> Label.Set.t -> unit + val get_block : t -> Label.t -> basic_block option val get_block_exn : t -> Label.t -> basic_block @@ -158,19 +213,13 @@ val print_instruction : val can_raise_terminator : terminator -> bool -val can_raise_basic : basic -> bool - -val can_raise_operation : operation -> bool - val is_pure_terminator : terminator -> bool val is_pure_basic : basic -> bool val is_noop_move : basic instruction -> bool -val set_stack_offset : 'a instruction -> int -> 'a instruction - -val set_live : 'a instruction -> Reg.Set.t -> 'a instruction +val set_stack_offset : 'a instruction -> int -> unit val string_of_irc_work_list : irc_work_list -> string diff --git a/backend/cfg/cfg_dataflow.ml b/backend/cfg/cfg_dataflow.ml index 2b94f2dc0c5..04810868ac8 100644 --- a/backend/cfg/cfg_dataflow.ml +++ b/backend/cfg/cfg_dataflow.ml @@ -1,4 +1,4 @@ -[@@@ocaml.warning "+a-4-30-40-41-42"] +[@@@ocaml.warning "+a-4-30-40-41-42-69"] open! Int_replace_polymorphic_compare module Instr = Numbers.Int @@ -277,7 +277,7 @@ module type Forward_transfer = sig exceptional : domain } - val basic : domain -> Cfg.basic Cfg.instruction -> image + val basic : domain -> Cfg.basic Cfg.instruction -> domain val terminator : domain -> Cfg.terminator Cfg.instruction -> image end @@ -333,18 +333,16 @@ module Forward (D : Domain_S) (T : Forward_transfer with type domain = D.t) : Cfg.basic_block -> transfer_image = fun ~update_instr value block -> - let transfer f (acc_normal, acc_exceptional) (instr : _ Cfg.instruction) = - let { T.normal; exceptional } = f acc_normal instr in - update_instr instr.id normal; - normal, D.join exceptional acc_exceptional + let transfer f g acc (instr : _ Cfg.instruction) = + let res = f acc instr in + update_instr instr.id (g res); + res in - let normal, exceptional = - transfer T.terminator - (ListLabels.fold_left block.body ~init:(value, value) - ~f:(transfer T.basic)) - block.terminator - in - { normal; exceptional } + transfer T.terminator + (fun { normal; exceptional = _ } -> normal) + (Cfg.BasicInstructionList.fold_left block.body ~init:value + ~f:(transfer T.basic (fun d -> d))) + block.terminator end module Dataflow_impl = Make_dataflow (Direction) @@ -382,8 +380,7 @@ module type Backward_transfer = sig type error - val basic : - domain -> exn:domain -> Cfg.basic Cfg.instruction -> (domain, error) result + val basic : domain -> Cfg.basic Cfg.instruction -> (domain, error) result val terminator : domain -> @@ -479,8 +476,8 @@ module Backward (D : Domain_S) (T : Backward_transfer with type domain = D.t) : transfer block.terminator (T.terminator normal ~exn block.terminator) in let value = - ListLabels.fold_right block.body ~init:value ~f:(fun instr value -> - transfer instr (T.basic value ~exn instr)) + Cfg.BasicInstructionList.fold_right block.body ~init:value + ~f:(fun instr value -> transfer instr (T.basic value instr)) in let value = if block.is_trap_handler diff --git a/backend/cfg/cfg_dataflow.mli b/backend/cfg/cfg_dataflow.mli index 57286666bab..d1d26d0d2ab 100644 --- a/backend/cfg/cfg_dataflow.mli +++ b/backend/cfg/cfg_dataflow.mli @@ -29,7 +29,7 @@ module type Forward_transfer = sig exceptional : domain } - val basic : domain -> Cfg.basic Cfg.instruction -> image + val basic : domain -> Cfg.basic Cfg.instruction -> domain val terminator : domain -> Cfg.terminator Cfg.instruction -> image end @@ -63,8 +63,7 @@ module type Backward_transfer = sig type error - val basic : - domain -> exn:domain -> Cfg.basic Cfg.instruction -> (domain, error) result + val basic : domain -> Cfg.basic Cfg.instruction -> (domain, error) result val terminator : domain -> diff --git a/backend/cfg/cfg_deadcode.ml b/backend/cfg/cfg_deadcode.ml index c04e45450bc..8a9d0a96529 100644 --- a/backend/cfg/cfg_deadcode.ml +++ b/backend/cfg/cfg_deadcode.ml @@ -8,37 +8,30 @@ let live_before : type a. a Cfg.instruction -> liveness -> Reg.Set.t = | None -> fatal "no liveness information for instruction %d" instr.id | Some { Cfg_liveness.before; across = _ } -> before -let remove_deadcode (body : Instruction.t list) liveness used_after : - Instruction.t list * bool = - let body, _, changed = - List.fold_right body ~init:([], used_after, false) - ~f:(fun (instr : Instruction.t) (acc, used_after, changed) -> - let before = live_before instr liveness in - let is_deadcode = - match instr.desc with - | Op _ as op -> - Cfg.is_pure_basic op - && Reg.disjoint_set_array used_after instr.res - && (not (Proc.regs_are_volatile instr.arg)) - && not (Proc.regs_are_volatile instr.res) - | Call _ | Reloadretaddr | Pushtrap _ | Poptrap | Prologue -> false - in - let acc = if is_deadcode then acc else instr :: acc in - acc, before, changed || is_deadcode) - in - body, changed +let remove_deadcode (body : Cfg.BasicInstructionList.t) changed liveness + used_after : unit = + let used_after = ref used_after in + Cfg.BasicInstructionList.filter_right body ~f:(fun (instr : Instruction.t) -> + let before = live_before instr liveness in + let is_deadcode = + match instr.desc with + | Op _ as op -> + Cfg.is_pure_basic op + && Reg.disjoint_set_array !used_after instr.res + && (not (Proc.regs_are_volatile instr.arg)) + && not (Proc.regs_are_volatile instr.res) + | Reloadretaddr | Pushtrap _ | Poptrap | Prologue -> false + in + used_after := before; + changed := !changed || is_deadcode; + not is_deadcode) let run cfg_with_liveness = let liveness = Cfg_with_liveness.liveness cfg_with_liveness in - let invalidate = - Cfg.fold_blocks (Cfg_with_liveness.cfg cfg_with_liveness) ~init:false - ~f:(fun _label block changed -> - let new_body, body_changed = - remove_deadcode block.body liveness - (live_before block.terminator liveness) - in - block.body <- new_body; - changed || body_changed) - in - if invalidate then Cfg_with_liveness.invalidate_liveness cfg_with_liveness; + let changed = ref false in + Cfg.iter_blocks (Cfg_with_liveness.cfg cfg_with_liveness) + ~f:(fun _label block -> + remove_deadcode block.body changed liveness + (live_before block.terminator liveness)); + if !changed then Cfg_with_liveness.invalidate_liveness cfg_with_liveness; cfg_with_liveness diff --git a/backend/cfg/cfg_equivalence.ml b/backend/cfg/cfg_equivalence.ml index 723d9b9ace7..dd81c61983c 100644 --- a/backend/cfg/cfg_equivalence.ml +++ b/backend/cfg/cfg_equivalence.ml @@ -239,12 +239,6 @@ let check_operation : location -> Cfg.operation -> Cfg.operation -> unit = | Intoffloat, Intoffloat -> () | Valueofint, Valueofint -> () | Intofvalue, Intofvalue -> () - | ( Probe - { name = expected_name; handler_code_sym = expected_handler_code_sym }, - Probe { name = result_name; handler_code_sym = result_handler_code_sym } ) - when String.equal expected_name result_name - && String.equal expected_handler_code_sym result_handler_code_sym -> - () | ( Probe_is_enabled { name = expected_name }, Probe_is_enabled { name = result_name } ) when String.equal expected_name result_name -> @@ -297,6 +291,12 @@ let check_prim_call_operation : Checkbound { immediate = result_immediate } ) when Option.equal Int.equal expected_immediate result_immediate -> () + | ( Probe + { name = expected_name; handler_code_sym = expected_handler_code_sym }, + Probe { name = result_name; handler_code_sym = result_handler_code_sym } ) + when String.equal expected_name result_name + && String.equal expected_handler_code_sym result_handler_code_sym -> + () | _ -> different location "primitive call operation" [@@ocaml.warning "-4"] @@ -312,37 +312,10 @@ let check_func_call_operation : | _ -> different location "function call operation" [@@ocaml.warning "-4"] -let check_tail_call_operation : - State.t -> - location -> - Cfg.tail_call_operation -> - Cfg.tail_call_operation -> - unit = - fun state location expected result -> - match expected, result with - | ( Self { destination = expected_destination }, - Self { destination = result_destination } ) -> - State.add_labels_to_check state location expected_destination - result_destination - | Func expected_func, Func result_func -> - check_func_call_operation location expected_func result_func - | _ -> different location "tail call operation" - [@@ocaml.warning "-4"] - -let check_call_operation : - location -> Cfg.call_operation -> Cfg.call_operation -> unit = - fun location expected result -> - match expected, result with - | P expected, P result -> check_prim_call_operation location expected result - | F expected, F result -> check_func_call_operation location expected result - | _ -> different location "call operation" - [@@ocaml.warning "-4"] - let check_basic : State.t -> location -> Cfg.basic -> Cfg.basic -> unit = fun state location expected result -> match expected, result with | Op expected, Op result -> check_operation location expected result - | Call expected, Call result -> check_call_operation location expected result | Reloadretaddr, Reloadretaddr -> () | ( Pushtrap { lbl_handler = expected_lbl_handler }, Pushtrap { lbl_handler = result_lbl_handler } ) -> @@ -399,7 +372,6 @@ let check_basic_instruction : let check_live = match result.desc with | Op _ -> true - | Call _ -> true | Reloadretaddr -> true | Pushtrap _ -> false | Poptrap -> false @@ -408,23 +380,24 @@ let check_basic_instruction : check_instruction ~check_live ~check_dbg ~check_arg:true idx location expected result -let rec check_basic_instruction_list : +let check_basic_instruction_list : State.t -> location -> - int -> - Cfg.basic Cfg.instruction list -> - Cfg.basic Cfg.instruction list -> + Cfg.BasicInstructionList.t -> + Cfg.BasicInstructionList.t -> unit = - fun state location idx expected result -> - match expected, result with - | [], [] -> () - | _ :: _, [] -> - different location "bodies with different sizes (expected is longer)" - | [], _ :: _ -> - different location "bodies with different sizes (result is longer)" - | expected_hd :: expected_tl, result_hd :: result_tl -> - check_basic_instruction state location idx expected_hd result_hd; - check_basic_instruction_list state location (succ idx) expected_tl result_tl + fun state location expected result -> + let expected_len = Cfg.BasicInstructionList.length expected in + let result_len = Cfg.BasicInstructionList.length result in + if expected_len = result_len + then + let i = ref 0 in + Cfg.BasicInstructionList.iter2 expected result ~f:(fun expected result -> + check_basic_instruction state location !i expected result; + incr i) + else if expected_len > result_len + then different location "bodies with different sizes (expected is longer)" + else different location "bodies with different sizes (result is longer)" let check_terminator_instruction : State.t -> @@ -483,18 +456,40 @@ let check_terminator_instruction : Array.iter2 (fun l1 l2 -> State.add_to_explore state l1 l2) a1 a2 | Return, Return -> () | Raise rk1, Raise rk2 when equal_raise_kind rk1 rk2 -> () - | Tailcall tc1, Tailcall tc2 -> + | ( Tailcall_self { destination = expected_destination }, + Tailcall_self { destination = result_destination } ) -> let location = location ^ " (terminator)" in - check_tail_call_operation state location tc1 tc2 + State.add_labels_to_check state location expected_destination + result_destination + | Tailcall_func tc1, Tailcall_func tc2 -> + let location = location ^ " (terminator)" in + check_func_call_operation location tc1 tc2 | Call_no_return cn1, Call_no_return cn2 -> check_external_call_operation location cn1 cn2 + | Call { op = cn1; label_after = lbl1 }, Call { op = cn2; label_after = lbl2 } + -> + check_func_call_operation location cn1 cn2; + State.add_to_explore state lbl1 lbl2 + | Prim { op = cn1; label_after = lbl1 }, Prim { op = cn2; label_after = lbl2 } + -> + check_prim_call_operation location cn1 cn2; + State.add_to_explore state lbl1 lbl2 + | ( Specific_can_raise { op = op1; label_after = lbl1 }, + Specific_can_raise { op = op2; label_after = lbl2 } ) + when Arch.equal_specific_operation op1 op2 -> + State.add_to_explore state lbl1 lbl2 + | Poll_and_jump return_label1, Poll_and_jump return_label2 + when Label.equal return_label1 return_label2 -> + () | _ -> different location "terminator"); (* CR xclerc for xclerc: temporary, for testing *) let check_arg = match expected.desc with | Always _ -> false | Never | Parity_test _ | Truth_test _ | Float_test _ | Int_test _ - | Switch _ | Return | Raise _ | Tailcall _ | Call_no_return _ -> + | Switch _ | Return | Raise _ | Tailcall_self _ | Tailcall_func _ + | Call_no_return _ | Call _ | Prim _ | Specific_can_raise _ + | Poll_and_jump _ -> true in check_instruction ~check_live:false ~check_dbg:false ~check_arg (-1) location @@ -508,7 +503,7 @@ let check_basic_block : State.t -> Cfg.basic_block -> Cfg.basic_block -> unit = (Label.to_string expected.start) (Label.to_string result.start) in - check_basic_instruction_list state location 0 expected.body result.body; + check_basic_instruction_list state location expected.body result.body; check_terminator_instruction state location expected.terminator result.terminator; (* State.add_label_sets_to_check state (location ^ " (predecessors)") diff --git a/backend/cfg/cfg_intf.ml b/backend/cfg/cfg_intf.ml index bc2224f67ef..e44145815a2 100644 --- a/backend/cfg/cfg_intf.ml +++ b/backend/cfg/cfg_intf.ml @@ -34,10 +34,6 @@ module S = struct | Indirect | Direct of { func_symbol : string } - type tail_call_operation = - | Self of { destination : Label.t } - | Func of func_call_operation - type external_call_operation = { func_symbol : string; alloc : bool; @@ -53,6 +49,10 @@ module S = struct mode : Lambda.alloc_mode } | Checkbound of { immediate : int option } + | Probe of + { name : string; + handler_code_sym : string + } type operation = | Move @@ -66,6 +66,11 @@ module S = struct | Store of Cmm.memory_chunk * Arch.addressing_mode * bool | Intop of Mach.integer_operation | Intop_imm of Mach.integer_operation * int + | Intop_atomic of + { op : Cmm.atomic_op; + size : Cmm.atomic_bitwidth; + addr : Arch.addressing_mode + } | Negf | Absf | Addf @@ -73,14 +78,11 @@ module S = struct | Mulf | Divf | Compf of Mach.float_comparison (* CR gyorsh: can merge with float_test? *) + | Csel of Mach.test | Floatofint | Intoffloat | Valueofint | Intofvalue - | Probe of - { name : string; - handler_code_sym : string - } | Probe_is_enabled of { name : string } | Opaque | Begin_region @@ -93,10 +95,6 @@ module S = struct is_assignment : bool } - type call_operation = - | P of prim_call_operation - | F of func_call_operation - type bool_test = { ifso : Label.t; (** if test is true goto [ifso] label *) ifnot : Label.t (** if test is false goto [ifnot] label *) @@ -138,17 +136,17 @@ module S = struct { desc : 'a; mutable arg : Reg.t array; mutable res : Reg.t array; - dbg : Debuginfo.t; - fdo : Fdo_info.t; - live : Reg.Set.t; - stack_offset : int; + mutable dbg : Debuginfo.t; + mutable fdo : Fdo_info.t; + mutable live : Reg.Set.t; + mutable stack_offset : int; id : int; mutable irc_work_list : irc_work_list } + (* [basic] instruction cannot raise *) type basic = | Op of operation - | Call of call_operation | Reloadretaddr (** This instruction loads the return address from a predefined hidden address (e.g. bottom of the current frame) and stores it in a @@ -158,6 +156,11 @@ module S = struct | Poptrap | Prologue + type 'a with_label_after = + { op : 'a; + label_after : Label.t + } + (* Properties of the representation of successors: * - Tests of different types are not mixed. For example, a test that * compares between variables of type int cannot be combined with a @@ -180,8 +183,13 @@ module S = struct | Switch of Label.t array | Return | Raise of Lambda.raise_kind - | Tailcall of tail_call_operation + | Tailcall_self of { destination : Label.t } + | Tailcall_func of func_call_operation | Call_no_return of external_call_operation + | Call of func_call_operation with_label_after + | Prim of prim_call_operation with_label_after + | Specific_can_raise of Arch.specific_operation with_label_after + | Poll_and_jump of Label.t end (* CR-someday gyorsh: Switch can be translated to Branch. *) diff --git a/backend/cfg/cfg_irc.ml b/backend/cfg/cfg_irc.ml index eb30d9e8bca..24ee454c08c 100644 --- a/backend/cfg/cfg_irc.ml +++ b/backend/cfg/cfg_irc.ml @@ -54,7 +54,7 @@ let build : State.t -> Cfg_with_liveness.t -> unit = Cfg.iter_blocks (Cfg_with_layout.cfg cfg_with_layout) ~f:(fun _label block -> if block.is_trap_handler then - let first_id = Cfg_regalloc_utils.first_instruction_id block in + let first_id = Cfg.first_instruction_id block in let live = Cfg_dataflow.Instr.Tbl.find liveness first_id in Reg.Set.iter (fun reg1 -> @@ -321,7 +321,14 @@ let assign_colors : State.t -> Cfg_with_layout.t -> unit = let alias = State.find_alias state n in n.Reg.irc_color <- alias.Reg.irc_color) -let rewrite : State.t -> Cfg_with_liveness.t -> Reg.t list -> reset:bool -> unit +type direction = + | Load_before_cell of Cfg.BasicInstructionList.cell + | Store_after_cell of Cfg.BasicInstructionList.cell + | Load_after_list of Cfg.BasicInstructionList.t + | Store_before_list of Cfg.BasicInstructionList.t + +(* Returns `true` if new temporaries have been introduced. *) +let rewrite : State.t -> Cfg_with_liveness.t -> Reg.t list -> reset:bool -> bool = fun state cfg_with_liveness spilled_nodes ~reset -> if irc_debug then log ~indent:1 "rewrite"; @@ -364,20 +371,9 @@ let rewrite : State.t -> Cfg_with_liveness.t -> Reg.t list -> reset:bool -> unit done; !i < len in - let[@inline] instruction_contains_spilled (instr : Instruction.t) : bool = - array_contains_spilled instr.arg || array_contains_spilled instr.res - in - let rec instruction_list_contains_spilled (l : Instruction.t list) : bool = - match l with - | [] -> false - | hd :: tl -> - instruction_contains_spilled hd || instruction_list_contains_spilled tl - in - let rewrite_instruction ~(direction : [`load | `store]) + let rewrite_instruction ~(direction : direction) ~(sharing : (Reg.t * [`load | `store]) Reg.Tbl.t) - (acc : Instruction.t list) (instr : _ Cfg.instruction) : - Instruction.t list = - let res = ref acc in + (instr : _ Cfg.instruction) : unit = let f (reg : Reg.t) : Reg.t = if reg.Reg.irc_work_list = Reg.Spilled then ( @@ -386,95 +382,99 @@ let rewrite : State.t -> Cfg_with_liveness.t -> Reg.t list -> reset:bool -> unit | None -> assert false | Some r -> r in - let move = - match direction with `load -> Move.Load | `store -> Move.Store + let move, move_dir = + match direction with + | Load_before_cell _ | Load_after_list _ -> Move.Load, `load + | Store_after_cell _ | Store_before_list _ -> Move.Store, `store in let add_instr, temp = match Reg.Tbl.find_opt sharing reg with | None -> let new_temp = make_new_temporary ~move reg in - Reg.Tbl.add sharing reg (new_temp, direction); + Reg.Tbl.add sharing reg (new_temp, move_dir); true, new_temp - | Some (r, dir) -> dir <> direction, r - in - let from, to_ = - match direction with - | `load -> spilled, temp - | `store -> temp, spilled + | Some (r, dir) -> dir <> move_dir, r in (if add_instr then + let from, to_ = + match move_dir with + | `load -> spilled, temp + | `store -> temp, spilled + in let new_instr = Move.make_instr move ~id:(State.get_and_incr_instruction_id state) ~copy:instr ~from ~to_ in - res := new_instr :: !res); + match direction with + | Load_before_cell cell -> + Cfg.BasicInstructionList.insert_before cell new_instr + | Store_after_cell cell -> + Cfg.BasicInstructionList.insert_after cell new_instr + | Load_after_list list -> + Cfg.BasicInstructionList.add_end list new_instr + | Store_before_list list -> + Cfg.BasicInstructionList.add_begin list new_instr); temp) else reg in - (match direction with - | `load -> instr.arg <- Array.map instr.arg ~f - | `store -> instr.res <- Array.map instr.res ~f); - !res - in - let rec rewrite_body_and_terminator (acc : Instruction.t list) - (body : Instruction.t list) (terminator : Cfg.terminator Cfg.instruction) - : Instruction.t list = - (* CR xclerc for xclerc: we can discover by calling `Cfg_stack_operands.xyz` - that we actually did not need to reallocate the list; it is a bit - unfortunate, given the efforts made to try to avoid the reallocation. *) - match body with - | [] -> ( - match Cfg_stack_operands.terminator spilled_map terminator with - | All_spilled_registers_rewritten -> List.rev acc - | May_still_have_spilled_registers -> - let acc = - rewrite_instruction ~direction:`load ~sharing:(Reg.Tbl.create 8) acc - terminator - in - List.rev acc) - | hd :: tl -> ( - match Cfg_stack_operands.basic spilled_map hd with - | All_spilled_registers_rewritten -> - let acc = hd :: acc in - rewrite_body_and_terminator acc tl terminator - | May_still_have_spilled_registers -> - let sharing = Reg.Tbl.create 8 in - let acc = rewrite_instruction ~direction:`load ~sharing acc hd in - let acc = hd :: acc in - let acc = rewrite_instruction ~direction:`store ~sharing acc hd in - rewrite_body_and_terminator acc tl terminator) + match direction with + | Load_before_cell _ | Load_after_list _ -> + if array_contains_spilled instr.arg + then instr.arg <- Array.map instr.arg ~f + | Store_after_cell _ | Store_before_list _ -> + if array_contains_spilled instr.res + then instr.res <- Array.map instr.res ~f in + let liveness = Cfg_with_liveness.liveness cfg_with_liveness in Cfg.iter_blocks (Cfg_with_liveness.cfg cfg_with_liveness) ~f:(fun label block -> - (* CR xclerc for xclerc: we currently assume that a terminator does not - "define" a register that may be spilled. Calls are reasonably fine - since their result is in a precolored register. *) - assert (not (array_contains_spilled block.terminator.res)); - let body_needs_rewrite = - instruction_list_contains_spilled block.body - || array_contains_spilled block.terminator.arg - in - if body_needs_rewrite + if irc_debug then ( - let liveness = Cfg_with_liveness.liveness cfg_with_liveness in - if irc_debug - then ( - log ~indent:2 "body of #%d, before:" label; - log_body_and_terminator ~indent:3 block.body block.terminator liveness); - block.body <- rewrite_body_and_terminator [] block.body block.terminator; + log ~indent:2 "body of #%d, before:" label; + log_body_and_terminator ~indent:3 block.body block.terminator liveness); + Cfg.BasicInstructionList.iter_cell block.body ~f:(fun cell -> + let instr = Cfg.BasicInstructionList.instr cell in + match Cfg_stack_operands.basic spilled_map instr with + | All_spilled_registers_rewritten -> () + | May_still_have_spilled_registers -> + let sharing = Reg.Tbl.create 8 in + rewrite_instruction ~direction:(Load_before_cell cell) ~sharing + instr; + rewrite_instruction ~direction:(Store_after_cell cell) ~sharing + instr); + match Cfg_stack_operands.terminator spilled_map block.terminator with + | All_spilled_registers_rewritten -> () + | May_still_have_spilled_registers -> + (let sharing = Reg.Tbl.create 8 in + rewrite_instruction ~direction:(Load_after_list block.body) + ~sharing:(Reg.Tbl.create 8) block.terminator; + let new_instrs = Cfg.BasicInstructionList.make_empty () in + rewrite_instruction ~direction:(Store_before_list new_instrs) ~sharing + block.terminator; + if not (Cfg.BasicInstructionList.is_empty new_instrs) + then + (* insert block *) + Cfg_regalloc_utils.insert_block + (Cfg_with_liveness.cfg_with_layout cfg_with_liveness) + new_instrs ~after:block ~next_instruction_id:(fun () -> + State.get_and_incr_instruction_id state)); if irc_debug then ( log ~indent:2 "and after:"; log_body_and_terminator ~indent:3 block.body block.terminator liveness; - log ~indent:2 "end"))); - if reset - then State.reset state ~new_temporaries:!new_temporaries - else ( + log ~indent:2 "end")); + match !new_temporaries, reset with + | [], _ -> false + | _ :: _, true -> + State.reset state ~new_temporaries:!new_temporaries; + true + | _ :: _, false -> State.add_introduced_temporaries_list state !new_temporaries; State.clear_spilled_nodes state; - State.add_initial_list state !new_temporaries) + State.add_initial_list state !new_temporaries; + true (* CR xclerc for xclerc: could probably be lower; the compiler distribution seems to be fine with 4 *) @@ -544,15 +544,17 @@ let rec main : round:int -> State.t -> Cfg_with_liveness.t -> unit = State.invariant state; match State.spilled_nodes state with | [] -> if irc_debug then log ~indent:1 "(end of main)" - | _ :: _ as spilled_nodes -> + | _ :: _ as spilled_nodes -> ( if irc_debug then List.iter spilled_nodes ~f:(fun reg -> log ~indent:1 "/!\\ register %a needs to be spilled" Printmach.reg reg); - rewrite state cfg_with_liveness spilled_nodes ~reset:true; - State.invariant state; - Cfg_with_liveness.invalidate_liveness cfg_with_liveness; - main ~round:(succ round) state cfg_with_liveness + match rewrite state cfg_with_liveness spilled_nodes ~reset:true with + | false -> () + | true -> + State.invariant state; + Cfg_with_liveness.invalidate_liveness cfg_with_liveness; + main ~round:(succ round) state cfg_with_liveness) let run : Cfg_with_liveness.t -> Cfg_with_liveness.t = fun cfg_with_liveness -> @@ -582,11 +584,7 @@ let run : Cfg_with_liveness.t -> Cfg_with_liveness.t = let spilling_because_split = match Lazy.force Split_mode.env with | Off -> [] - | Naive -> ( - match naive_split_points cfg_with_layout with - | [] -> [] - | _ :: _ as split_points -> - naive_split_cfg state cfg_with_liveness split_points) + | Naive -> naive_split_cfg state cfg_with_liveness in let spilling_because_split_or_unused : Reg.t list = Reg.Set.fold @@ -599,12 +597,13 @@ let run : Cfg_with_liveness.t -> Cfg_with_liveness.t = log ~indent:0 "%a <- spilling_because_split_or_unused" Printmach.reg r); (match spilling_because_split_or_unused with | [] -> () - | _ :: _ as spilling -> + | _ :: _ as spilling -> ( List.iter spilling ~f:(fun reg -> State.add_spilled_nodes state reg); (* note: rewrite will remove the `spilling` registers from the "spilled" work list and set the field to unknown. *) - rewrite state cfg_with_liveness spilling ~reset:false; - Cfg_with_liveness.invalidate_liveness cfg_with_liveness); + match rewrite state cfg_with_liveness spilling ~reset:false with + | false -> () + | true -> Cfg_with_liveness.invalidate_liveness cfg_with_liveness)); main ~round:1 state cfg_with_liveness; (* note: slots need to be updated before prologue removal *) if irc_debug diff --git a/backend/cfg/cfg_irc_split.ml b/backend/cfg/cfg_irc_split.ml index 01c4da25c11..85f2bad8b3a 100644 --- a/backend/cfg/cfg_irc_split.ml +++ b/backend/cfg/cfg_irc_split.ml @@ -4,64 +4,19 @@ open! Cfg_regalloc_utils open! Cfg_irc_utils module State = Cfg_irc_state -let naive_split_points : Cfg_with_layout.t -> Instruction.id list = - fun cfg_with_layout -> - if irc_debug then log ~indent:1 "naive_split_points"; - Cfg_with_layout.fold_instructions cfg_with_layout ~init:[] - ~instruction:(fun acc (instr : Instruction.t) -> - (* CR xclerc for xclerc: we may want to split [heuristically] in more - situations. *) - let split = - match instr.desc with - | Call (P (External _) | F (Direct _)) -> true - | _ -> false - in - if split - then ( - if irc_debug then log ~indent:2 "should split at %d" instr.id; - instr.id :: acc) - else acc) - ~terminator:(fun acc _term -> acc) - |> List.rev +(* CR-soon azewierzejew: With the terminator change all the naive split points + were changed to terminators but current implementation assumes that the split + points are only at [basic instruction]. This function is left with split + points on the new terminators for future reference and actual implementation + is below. *) +(* let is_naive_split_point : Instruction.t -> bool = fun instr -> (* CR xclerc + for xclerc: we may want to split [heuristically] in more situations. *) match + instr.desc with | Call (P (External _) | F (Direct _)) -> true | _ -> + false *) -type naive_split_instr = - { before : Instruction.t; - after : Instruction.t; - new_regs : Reg.t list - } - -let[@inline] naive_split_instr : - State.t -> - Reg.t Reg.Tbl.t -> - Instruction.t -> - Reg.t -> - Reg.t list -> - naive_split_instr = - fun state subst instr reg new_regs -> - let new_reg, new_regs = - match Reg.Tbl.find_opt subst reg with - | Some r -> r, new_regs - | None -> - let new_reg = - make_temporary ~same_class_and_base_name_as:reg ~name_prefix:"split" - in - State.add_introduced_temporaries_one state new_reg; - State.add_initial_one state new_reg; - State.add_spilled_nodes state new_reg; - Reg.Tbl.replace subst reg new_reg; - new_reg, new_reg :: new_regs - in - let before = - Move.make_instr Move.Plain - ~id:(State.get_and_incr_instruction_id state) - ~copy:instr ~from:reg ~to_:new_reg - in - let after = - Move.make_instr Move.Plain - ~id:(State.get_and_incr_instruction_id state) - ~copy:instr ~from:new_reg ~to_:reg - in - { before; after; new_regs } +(* CR-soon azewierzejew: Because of the terminator rework currently there are no + naive split points for basic instructions.*) +let is_naive_split_point : Instruction.t -> bool = fun _ -> false let[@inline] apply_regs : Reg.t Reg.Tbl.t -> Reg.t array -> Reg.t array = fun subst arr -> @@ -74,76 +29,61 @@ let[@inline] apply_instr : Reg.t Reg.Tbl.t -> Instruction.t -> unit = instr.arg <- apply_regs subst instr.arg; instr.res <- apply_regs subst instr.res -type naive_split_body = - { body : Instruction.t list; - split_points : Instruction.id list; - new_regs : Reg.t list - } - -let rec naive_split_body : +let[@inline] naive_split_instr : State.t -> liveness -> + Reg.t list ref -> Reg.t Reg.Tbl.t -> - Instruction.t list -> - Instruction.t list -> - Instruction.id list -> - Reg.t list -> - naive_split_body = - fun state liveness subst acc body split_points new_regs -> - match body, split_points with - | [], _ -> { body = List.rev acc; split_points; new_regs } - | _, [] -> { body = List.rev acc @ body; split_points = []; new_regs } - | hd_body :: tl_body, hd_split_points :: tl_split_points -> - if hd_body.Cfg.id = hd_split_points + Cfg.BasicInstructionList.cell -> + unit = + fun state liveness new_regs subst cell -> + let instr = Cfg.BasicInstructionList.instr cell in + if is_naive_split_point instr + then ( + let live = Cfg_dataflow.Instr.Tbl.find liveness instr.id in + if irc_debug then ( - let live = Cfg_dataflow.Instr.Tbl.find liveness hd_body.Cfg.id in - if irc_debug - then ( - log ~indent:2 "splitting at %d" hd_split_points; - Reg.Set.iter - (fun reg -> log ~indent:3 "register %a is live" Printmach.reg reg) - live.across); - let acc, new_regs, instrs_after = - Reg.Set.fold - (fun reg (acc, new_regs, instrs_after) -> - let { before; after; new_regs } = - naive_split_instr state subst hd_body reg new_regs + log ~indent:2 "splitting at %d" instr.id; + Reg.Set.iter + (fun reg -> log ~indent:3 "register %a is live" Printmach.reg reg) + live.across); + Reg.Set.iter + (fun reg -> + let new_reg = + match Reg.Tbl.find_opt subst reg with + | Some r -> r + | None -> + let new_reg = + make_temporary ~same_class_and_base_name_as:reg + ~name_prefix:"split" in - before :: acc, new_regs, after :: instrs_after) - live.across (acc, new_regs, []) - in - apply_instr subst hd_body; - naive_split_body state liveness subst - (instrs_after @ (hd_body :: acc)) - tl_body tl_split_points new_regs) - else - naive_split_body state liveness subst (hd_body :: acc) tl_body - split_points new_regs + State.add_introduced_temporaries_one state new_reg; + State.add_initial_one state new_reg; + State.add_spilled_nodes state new_reg; + Reg.Tbl.replace subst reg new_reg; + new_regs := new_reg :: !new_regs; + new_reg + in + Cfg.BasicInstructionList.insert_before cell + (Move.make_instr Move.Plain + ~id:(State.get_and_incr_instruction_id state) + ~copy:instr ~from:reg ~to_:new_reg); + Cfg.BasicInstructionList.insert_after cell + (Move.make_instr Move.Plain + ~id:(State.get_and_incr_instruction_id state) + ~copy:instr ~from:new_reg ~to_:reg); + apply_instr subst instr) + live.across) -let naive_split_cfg : - State.t -> Cfg_with_liveness.t -> Instruction.id list -> Reg.t list = - fun state cfg_with_liveness split_points -> +let naive_split_cfg : State.t -> Cfg_with_liveness.t -> Reg.t list = + fun state cfg_with_liveness -> if irc_debug then log ~indent:1 "naive_split"; + let new_regs = ref [] in let subst = Reg.Tbl.create 32 in let liveness = Cfg_with_liveness.liveness cfg_with_liveness in - let split_points, new_regs = - Cfg.fold_blocks (Cfg_with_liveness.cfg cfg_with_liveness) - ~init:(split_points, []) - ~f:(fun label block ((split_points, new_regs) as acc) -> - match split_points with - | [] -> acc - | hd :: _ -> - if irc_debug then log ~indent:2 "splitting in #%d" label; - if List.exists block.body ~f:(fun instr -> instr.Cfg.id = hd) - then ( - let { body; split_points; new_regs } = - naive_split_body state liveness subst [] block.body split_points - new_regs - in - block.body <- body; - split_points, new_regs) - else acc) - in - assert (split_points = []); - Cfg_with_liveness.invalidate_liveness cfg_with_liveness; - new_regs + Cfg.iter_blocks (Cfg_with_liveness.cfg cfg_with_liveness) + ~f:(fun label block -> + if irc_debug then log ~indent:2 "splitting in #%d" label; + Cfg.BasicInstructionList.iter_cell block.body ~f:(fun cell -> + naive_split_instr state liveness new_regs subst cell)); + !new_regs diff --git a/backend/cfg/cfg_irc_split.mli b/backend/cfg/cfg_irc_split.mli index 13aad67a1df..f49563f1078 100644 --- a/backend/cfg/cfg_irc_split.mli +++ b/backend/cfg/cfg_irc_split.mli @@ -1,8 +1,3 @@ [@@@ocaml.warning "+a-4-30-40-41-42"] -open Cfg_regalloc_utils - -val naive_split_points : Cfg_with_layout.t -> Instruction.id list - -val naive_split_cfg : - Cfg_irc_state.t -> Cfg_with_liveness.t -> Instruction.id list -> Reg.t list +val naive_split_cfg : Cfg_irc_state.t -> Cfg_with_liveness.t -> Reg.t list diff --git a/backend/cfg/cfg_irc_utils.ml b/backend/cfg/cfg_irc_utils.ml index 63839104f07..ec23a9f89f9 100644 --- a/backend/cfg/cfg_irc_utils.ml +++ b/backend/cfg/cfg_irc_utils.ml @@ -43,14 +43,15 @@ let log_instruction_suffix (instr : _ Cfg.instruction) (liveness : liveness) : let log_body_and_terminator : indent:int -> - Cfg.basic Cfg.instruction list -> + Cfg.BasicInstructionList.t -> Cfg.terminator Cfg.instruction -> liveness -> unit = fun ~indent body term liveness -> if irc_debug && irc_verbose then ( - List.iter body ~f:(fun (instr : Cfg.basic Cfg.instruction) -> + Cfg.BasicInstructionList.iter body + ~f:(fun (instr : Cfg.basic Cfg.instruction) -> log_instruction_prefix ~indent instr; Cfg.dump_basic Format.err_formatter instr.Cfg.desc; log_instruction_suffix instr liveness); @@ -134,6 +135,7 @@ let is_move_basic : Cfg.basic -> bool = | Store _ -> false | Intop _ -> false | Intop_imm _ -> false + | Intop_atomic _ -> false | Negf -> false | Absf -> false | Addf -> false @@ -141,18 +143,18 @@ let is_move_basic : Cfg.basic -> bool = | Mulf -> false | Divf -> false | Compf _ -> false + | Csel _ -> false | Floatofint -> false | Intoffloat -> false | Valueofint -> false | Intofvalue -> false - | Probe _ -> false | Probe_is_enabled _ -> false | Opaque -> false | Begin_region -> false | End_region -> false | Specific _ -> false | Name_for_debugger _ -> false) - | Call _ | Reloadretaddr | Pushtrap _ | Poptrap | Prologue -> false + | Reloadretaddr | Pushtrap _ | Poptrap | Prologue -> false let is_move_instruction : Cfg.basic Cfg.instruction -> bool = fun instr -> is_move_basic instr.desc @@ -275,8 +277,16 @@ module ArraySet = struct val dummy : t end - (* CR-someday xclerc for xclerc: consider using unsafe versions of blit and - fill. *) + external unsafe_blit : + src:'a array -> + src_pos:int -> + dst:'a array -> + dst_pos:int -> + len:int -> + unit = "caml_array_blit" + + external unsafe_fill : 'a array -> pos:int -> len:int -> 'a -> unit + = "caml_array_fill" module Make (T : OrderedTypeWithDummy) : S with type e = T.t = struct type e = T.t @@ -292,7 +302,7 @@ module ArraySet = struct { array; length } let clear t = - Array.fill t.array ~pos:0 ~len:t.length T.dummy; + unsafe_fill t.array ~pos:0 ~len:t.length T.dummy; t.length <- 0 let is_empty t = Int.equal t.length 0 @@ -324,12 +334,12 @@ module ArraySet = struct let len_before = idx in if len_before > 0 then - Array.blit ~src:t.array ~src_pos:0 ~dst:new_array ~dst_pos:0 + unsafe_blit ~src:t.array ~src_pos:0 ~dst:new_array ~dst_pos:0 ~len:len_before; let len_after = t.length - idx in if len_after > 0 then - Array.blit ~src:t.array ~src_pos:idx ~dst:new_array + unsafe_blit ~src:t.array ~src_pos:idx ~dst:new_array ~dst_pos:(succ idx) ~len:len_after; Array.unsafe_set new_array idx e; t.array <- new_array; @@ -339,7 +349,7 @@ module ArraySet = struct let len = t.length - idx in if len > 0 then - Array.blit ~src:t.array ~src_pos:idx ~dst:t.array + unsafe_blit ~src:t.array ~src_pos:idx ~dst:t.array ~dst_pos:(succ idx) ~len; Array.unsafe_set t.array idx e; t.length <- succ t.length) @@ -352,7 +362,7 @@ module ArraySet = struct let len = t.length - idx - 1 in if len > 0 then - Array.blit ~src:t.array ~src_pos:(succ idx) ~dst:t.array ~dst_pos:idx + unsafe_blit ~src:t.array ~src_pos:(succ idx) ~dst:t.array ~dst_pos:idx ~len; t.length <- pred t.length; Array.unsafe_set t.array t.length T.dummy) diff --git a/backend/cfg/cfg_irc_utils.mli b/backend/cfg/cfg_irc_utils.mli index 4b75ea5aab2..9b8c05b00d2 100644 --- a/backend/cfg/cfg_irc_utils.mli +++ b/backend/cfg/cfg_irc_utils.mli @@ -12,7 +12,7 @@ val log : indent:int -> ('a, Format.formatter, unit) format -> 'a val log_body_and_terminator : indent:int -> - Cfg.basic Cfg.instruction list -> + Cfg.BasicInstructionList.t -> Cfg.terminator Cfg.instruction -> liveness -> unit diff --git a/backend/cfg/cfg_liveness.ml b/backend/cfg/cfg_liveness.ml index 6455fb7aab8..f23e7297cd4 100644 --- a/backend/cfg/cfg_liveness.ml +++ b/backend/cfg/cfg_liveness.ml @@ -44,16 +44,12 @@ module Transfer : let before = Reg.add_set_array across instr.arg in { before; across } - let basic : - domain -> - exn:domain -> - Cfg.basic Cfg.instruction -> - (domain, error) result = - fun ({ before; across = _ } as domain) ~exn instr -> + let basic : domain -> Cfg.basic Cfg.instruction -> (domain, error) result = + fun ({ before; across = _ } as domain) instr -> Result.ok @@ match instr.desc with - | Op _ | Call _ | Reloadretaddr | Pushtrap _ | Poptrap | Prologue -> + | Op _ | Reloadretaddr | Pushtrap _ | Poptrap | Prologue -> if Cfg.is_pure_basic instr.desc && Reg.disjoint_set_array before instr.res && (not (Proc.regs_are_volatile instr.arg)) @@ -63,10 +59,7 @@ module Transfer : then don't mark the arguments as used because this instruction could be removed. *) { before; across = before } - else - instruction - ~can_raise:(Cfg.can_raise_basic instr.desc) - ~exn domain instr + else instruction ~can_raise:false ~exn:Domain.bot domain instr let terminator : domain -> @@ -78,7 +71,7 @@ module Transfer : @@ match instr.desc with | Never -> assert false - | Tailcall (Self _) -> + | Tailcall_self _ -> (* CR-someday azewierzejew: If the stamps for the tail call DomainState argument and parameter were the same and Tailcall (Self _) had [instr.arg = instr.res] (either by removing the args or adding results @@ -90,9 +83,8 @@ module Transfer : ~can_raise:(Cfg.can_raise_terminator instr.desc) ~exn Domain.bot instr | Always _ | Parity_test _ | Truth_test _ | Float_test _ | Int_test _ - | Switch _ | Return | Raise _ - | Tailcall (Func _) - | Call_no_return _ -> + | Switch _ | Return | Raise _ | Tailcall_func _ | Call_no_return _ | Call _ + | Poll_and_jump _ | Prim _ | Specific_can_raise _ -> instruction ~can_raise:(Cfg.can_raise_terminator instr.desc) ~exn domain instr diff --git a/backend/cfg/cfg_regalloc_utils.ml b/backend/cfg/cfg_regalloc_utils.ml index 2073001ed54..6a4aefc2a55 100644 --- a/backend/cfg/cfg_regalloc_utils.ml +++ b/backend/cfg/cfg_regalloc_utils.ml @@ -40,11 +40,6 @@ module Instruction = struct module IdMap = MoreLabels.Map.Make (Int) end -let first_instruction_id (block : Cfg.basic_block) : int = - match block.body with - | [] -> block.terminator.id - | first_instr :: _ -> first_instr.id - let[@inline] int_max (left : int) (right : int) = if left >= right then left else right @@ -157,8 +152,8 @@ let simplify_cfg : Cfg_with_layout.t -> Cfg_with_layout.t = fun cfg_with_layout -> let cfg = Cfg_with_layout.cfg cfg_with_layout in Cfg.iter_blocks cfg ~f:(fun _label block -> - block.body - <- List.filter block.body ~f:(fun instr -> not (Cfg.is_noop_move instr))); + Cfg.BasicInstructionList.filter_left block.body ~f:(fun instr -> + not (Cfg.is_noop_move instr))); Eliminate_fallthrough_blocks.run cfg_with_layout; Merge_straightline_blocks.run cfg_with_layout; Eliminate_dead_code.run_dead_block cfg_with_layout; @@ -185,6 +180,7 @@ let precondition : Cfg_with_layout.t -> unit = | Store _ -> () | Intop _ -> () | Intop_imm _ -> () + | Intop_atomic _ -> () | Negf -> () | Absf -> () | Addf -> () @@ -192,18 +188,24 @@ let precondition : Cfg_with_layout.t -> unit = | Mulf -> () | Divf -> () | Compf _ -> () + | Csel _ -> () | Floatofint -> () | Intoffloat -> () | Valueofint -> () | Intofvalue -> () - | Probe _ -> () | Probe_is_enabled _ -> () | Opaque -> () | Begin_region -> () | End_region -> () - | Specific _ -> () + | Specific op -> + if Arch.operation_can_raise op + then + fatal + "architecture specific instruction %d that can raise but isn't a \ + terminator" + id | Name_for_debugger _ -> ()) - | Call _ | Reloadretaddr | Pushtrap _ | Poptrap | Prologue -> () + | Reloadretaddr | Pushtrap _ | Poptrap | Prologue -> () in let register_must_not_be_on_stack (id : Instruction.id) (reg : Reg.t) : unit = match reg.Reg.loc with @@ -378,22 +380,21 @@ let remove_prologue_if_not_required : Cfg_with_layout.t -> unit = then (* note: `Cfize` has put the prologue in the entry block *) let block = Cfg.get_block_exn cfg cfg.entry_label in - block.body - <- List.filter block.body ~f:(fun instr -> - match instr.Cfg.desc with Cfg.Prologue -> false | _ -> true) + Cfg.BasicInstructionList.filter_left block.body ~f:(fun instr -> + match instr.Cfg.desc with Cfg.Prologue -> false | _ -> true) let update_live_fields : Cfg_with_layout.t -> liveness -> unit = fun cfg_with_layout liveness -> (* CR xclerc for xclerc: partial duplicate of `Asmgen.recompute_liveness_on_cfg` *) - let with_liveness (instr : _ Cfg.instruction) = + let set_liveness (instr : _ Cfg.instruction) = match Cfg_dataflow.Instr.Tbl.find_opt liveness instr.id with | None -> fatal "Missing liveness information for instruction %d" instr.id - | Some { Cfg_liveness.before = _; across } -> Cfg.set_live instr across + | Some { Cfg_liveness.before = _; across } -> instr.live <- across in Cfg.iter_blocks (Cfg_with_layout.cfg cfg_with_layout) ~f:(fun _label block -> - block.body <- ListLabels.map block.body ~f:with_liveness; - block.terminator <- with_liveness block.terminator) + Cfg.BasicInstructionList.iter block.body ~f:set_liveness; + set_liveness block.terminator) let update_spill_cost : Cfg_with_layout.t -> unit = fun cfg_with_layout -> @@ -409,7 +410,15 @@ let update_spill_cost : Cfg_with_layout.t -> unit = update_array instr.res in Cfg_with_layout.iter_instructions cfg_with_layout ~instruction:update_instr - ~terminator:update_instr + ~terminator:(fun (term : Cfg.terminator Cfg.instruction) -> + (* Ignore probes *) + match term.desc with + | Prim { op = Probe _; _ } -> () + | Never | Always _ | Parity_test _ | Truth_test _ | Float_test _ + | Int_test _ | Switch _ | Return | Raise _ | Tailcall_self _ + | Tailcall_func _ | Call_no_return _ | Call _ | Prim _ + | Specific_can_raise _ | Poll_and_jump _ -> + update_instr term) let is_spilled reg = reg.Reg.irc_work_list = Reg.Spilled @@ -456,3 +465,81 @@ let may_use_stack_operands_everywhere : may_use_stack_operands_array map instr.arg; may_use_stack_operands_array map instr.res; All_spilled_registers_rewritten + +let insert_block : + Cfg_with_layout.t -> + Cfg.BasicInstructionList.t -> + after:Cfg.basic_block -> + next_instruction_id:(unit -> Instruction.id) -> + unit = + fun cfg_with_layout body ~after:predecessor_block ~next_instruction_id -> + let cfg = Cfg_with_layout.cfg cfg_with_layout in + let successors = + Cfg.successor_labels ~normal:true ~exn:false predecessor_block + in + if Label.Set.cardinal successors = 0 + then + Misc.fatal_errorf + "Cannot insert a block after block %a: it has no successors" Label.print + predecessor_block.start; + let last_insn = + match Cfg.BasicInstructionList.last body with + | None -> Misc.fatal_error "Inserting an empty block" + | Some i -> i + in + let copy (i : Cfg.basic Cfg.instruction) : Cfg.basic Cfg.instruction = + { i with id = next_instruction_id () } + in + (* copy body if there is more than one successor *) + let first = ref true in + let get_body () = + if !first + then ( + first := false; + body) + else + let new_body = Cfg.BasicInstructionList.make_empty () in + Cfg.BasicInstructionList.iter body ~f:(fun instr -> + Cfg.BasicInstructionList.add_end new_body (copy instr)); + new_body + in + Label.Set.iter + (fun successor_label -> + let successor_block = Cfg.get_block_exn cfg successor_label in + let start = Cmm.new_label () in + let block : Cfg.basic_block = + { start; + body = get_body (); + terminator = + { (* The [successor_block] is the only successor. *) + desc = Cfg.Always successor_label; + arg = [||]; + res = [||]; + dbg = last_insn.dbg; + fdo = last_insn.fdo; + live = last_insn.live; + stack_offset = last_insn.stack_offset; + id = next_instruction_id (); + irc_work_list = Unknown_list + }; + (* The [predecessor_block] is the only predecessor. *) + predecessors = Label.Set.singleton predecessor_block.start; + stack_offset = predecessor_block.terminator.stack_offset; + exn = None; + can_raise = false; + is_trap_handler = false; + dead = predecessor_block.dead + } + in + Cfg_with_layout.add_block cfg_with_layout block + ~after:predecessor_block.start; + (* Change the labels for the terminator in [predecessor_block]. *) + Cfg.replace_successor_labels cfg ~normal:true ~exn:false predecessor_block + ~f:(fun old_label -> + if Label.equal old_label successor_label then start else old_label); + (* Update predecessors for the [successor_block]. *) + successor_block.predecessors + <- successor_block.predecessors + |> Label.Set.remove predecessor_block.start + |> Label.Set.add start) + successors diff --git a/backend/cfg/cfg_regalloc_utils.mli b/backend/cfg/cfg_regalloc_utils.mli index 5effa217269..9df769438b2 100644 --- a/backend/cfg/cfg_regalloc_utils.mli +++ b/backend/cfg/cfg_regalloc_utils.mli @@ -26,8 +26,6 @@ module Instruction : sig module IdMap : MoreLabels.Map.S with type key = id end -val first_instruction_id : Cfg.basic_block -> int - type cfg_infos = { arg : Reg.Set.t; res : Reg.Set.t; @@ -106,3 +104,12 @@ val may_use_stack_operands_array : spilled_map -> Reg.t array -> unit val may_use_stack_operands_everywhere : spilled_map -> 'a Cfg.instruction -> stack_operands_rewrite + +(* Insert specified instructions along all outgoing edges from the block + [after]. *) +val insert_block : + Cfg_with_layout.t -> + Cfg.BasicInstructionList.t -> + after:Cfg.basic_block -> + next_instruction_id:(unit -> Instruction.id) -> + unit diff --git a/backend/cfg/cfg_regalloc_validate.ml b/backend/cfg/cfg_regalloc_validate.ml index 8a9cc0f521f..77e4410059e 100644 --- a/backend/cfg/cfg_regalloc_validate.ml +++ b/backend/cfg/cfg_regalloc_validate.ml @@ -9,7 +9,7 @@ function call are specified as preassigned registers instead of reconstructing the argument locations from the function type. *) -[@@@ocaml.warning "+a-4-30-40-41-42"] +[@@@ocaml.warning "+a-4-30-40-41-42-69"] include Cfg_intf.S @@ -308,13 +308,16 @@ module Description : sig were preassigned before allocation and that they haven't changed after. *) type t - (** Will never raise for instructions from the verified CFG that aren't - regalloc specific (examples of regalloc specific instructions are [Spill] - and [Reload]). *) - val find_basic : t -> basic instruction -> basic Instruction.t + (** Will return [Some _] for the instructions that existed in the CFG before + allocation and [None] otherwise. Currently, only instructions that + register allocation can add are [Spill] and [Reload]. *) + val find_basic : t -> basic instruction -> basic Instruction.t option - (** Will never raise for a terminator from the verified CFG. *) - val find_terminator : t -> terminator instruction -> terminator Instruction.t + (** Will return [Some _] for the terminators that existed in CFG before + allocation and [None] otherwise. Currently, only terminators that register + allocation can add is [Always]. *) + val find_terminator : + t -> terminator instruction -> terminator Instruction.t option val create : Cfg_with_layout.t -> t @@ -322,42 +325,60 @@ module Description : sig val reg_fun_args : t -> Register.t array end = struct + type basic_info = + { successor_id : int; + instr : basic Instruction.t + } + type t = - { instructions : (int, basic Instruction.t) Hashtbl.t; + { instructions : (int, basic_info) Hashtbl.t; terminators : (int, terminator Instruction.t) Hashtbl.t; + first_instruction_in_block : int Label.Tbl.t; reg_fun_args : Register.t array } - let find_basic t instr = Hashtbl.find t.instructions instr.id + let find_basic t instr = + Hashtbl.find_opt t.instructions instr.id + |> Option.map (fun info -> info.instr) - let find_terminator t instr = Hashtbl.find t.terminators instr.id + let find_terminator t instr = Hashtbl.find_opt t.terminators instr.id let reg_fun_args t = t.reg_fun_args - let make_instruction_helper t f instr = - f - ~is_regalloc_specific: - (match instr.desc with Op (Spill | Reload) -> true | _ -> false) - t.instructions instr + let is_regalloc_specific_basic (desc : Cfg.basic) = + match desc with Op (Reload | Spill) -> true | _ -> false - let make_terminator_helper t f instr = - f ~is_regalloc_specific:false t.terminators instr - - let add_instr ~seen_ids ~is_regalloc_specific instructions instr = - let id = instr.id in + let add_instr_id ~seen_ids ~context id = if Hashtbl.mem seen_ids id then - Cfg_regalloc_utils.fatal - "Duplicate instruction no. %d while creating pre-allocation description" - id; - Hashtbl.add seen_ids id (); - if is_regalloc_specific + Cfg_regalloc_utils.fatal "Duplicate instruction no. %d while %s" id + context; + Hashtbl.add seen_ids id () + + let add_basic ~seen_ids ~successor_id t instr = + let id = instr.id in + add_instr_id ~seen_ids + ~context:"adding a basic instruction to the description" id; + if is_regalloc_specific_basic instr.desc then Cfg_regalloc_utils.fatal "Instruction no. %d is specific to the regalloc phase while creating \ pre-allocation description" id; - Hashtbl.add instructions id + Hashtbl.add t.instructions id + { successor_id; + instr = + { Instruction.desc = instr.desc; + arg = Array.map Register.create instr.arg; + res = Array.map Register.create instr.res + } + } + + let add_terminator ~seen_ids t instr = + let id = instr.id in + add_instr_id ~seen_ids + ~context:"adding a terminator instruction to the description" id; + Hashtbl.add t.terminators id { Instruction.desc = instr.desc; arg = Array.map Register.create instr.arg; res = Array.map Register.create instr.res @@ -399,12 +420,23 @@ end = struct let t = { instructions = Hashtbl.create basic_count; terminators = Hashtbl.create terminator_count; + first_instruction_in_block = Label.Tbl.create terminator_count; reg_fun_args } in - Cfg_with_layout.iter_instructions cfg - ~instruction:(make_instruction_helper t (add_instr ~seen_ids)) - ~terminator:(make_terminator_helper t (add_instr ~seen_ids)); + Label.Tbl.iter + (fun _ (block : Cfg.basic_block) -> + add_terminator ~seen_ids t block.terminator; + let first_instruction_id = + Cfg.BasicInstructionList.fold_right + ~f:(fun instr successor_id -> + add_basic ~seen_ids ~successor_id t instr; + instr.id) + block.body ~init:block.terminator.id + in + Label.Tbl.add t.first_instruction_in_block block.start + first_instruction_id) + (Cfg_with_layout.cfg cfg).Cfg.blocks; t let verify_reg_array ~context ~reg_arr ~loc_arr = @@ -428,32 +460,43 @@ end = struct reg_arr loc_arr; () - let verify_instr ~seen_ids ~is_regalloc_specific instructions instr = + let verify_reg_arrays (type a) ~id (instr : a Cfg.instruction) + (old_instr : a Instruction.t) = + verify_reg_array + ~context:(Printf.sprintf "In instruction's no %d arguments" id) + ~reg_arr:old_instr.arg ~loc_arr:instr.arg; + verify_reg_array + ~context:(Printf.sprintf "In instruction's no %d results" id) + ~reg_arr:old_instr.res ~loc_arr:instr.res + + let verify_basic ~seen_ids ~successor_id t instr = let id = instr.id in - if Hashtbl.mem seen_ids id - then - Cfg_regalloc_utils.fatal - "Duplicate instruction no. %d while checking post-allocation \ - description" - id; - Hashtbl.add seen_ids id (); - match Hashtbl.find_opt instructions id, is_regalloc_specific with + add_instr_id ~seen_ids + ~context:"checking a basic instruction in the new CFG" id; + match + Hashtbl.find_opt t.instructions id, is_regalloc_specific_basic instr.desc + with (* The instruction was present before. *) - | Some old_instr, false -> - (* CR-someday azewierzejew: Avoid using polymorphic compare. That is - tricky because here we can compare both [basic] and [terminator]. *) - if instr.desc <> old_instr.Instruction.desc + | Some { instr = old_instr; successor_id = old_successor_id }, false -> + if not (Int.equal old_successor_id successor_id) + then + Cfg_regalloc_utils.fatal + "The instruction's no. %d successor id has changed. Before \ + allocation: %d. After allocation (ignoring instructions added by \ + allocation): %d." + id old_successor_id successor_id; + (* CR-someday azewierzejew: Avoid using polymrphic compare. *) + if instr.desc <> old_instr.desc then Cfg_regalloc_utils.fatal "The desc of instruction with id %d changed" id; - verify_reg_array - ~context:(Printf.sprintf "In instruction's no %d arguments" id) - ~reg_arr:old_instr.Instruction.arg ~loc_arr:instr.arg; - verify_reg_array - ~context:(Printf.sprintf "In instruction's no %d results" id) - ~reg_arr:old_instr.Instruction.res ~loc_arr:instr.res; - () - (* Added spill/reload that wasn't before. *) - | None, true -> () + verify_reg_arrays ~id instr old_instr; + (* Return new successor id which is the id of the current instruction. *) + id + | None, true -> + (* Added regalloc specific instruction that wasn't before. The new + successor is the same as old one because this instruction is + ignored. *) + successor_id | Some _, true -> Cfg_regalloc_utils.fatal "Register allocation changed existing instruction no. %d into a \ @@ -463,6 +506,158 @@ end = struct Cfg_regalloc_utils.fatal "Register allocation added non-regalloc specific instruction no. %d" id + let compare_terminators ~successor_ids ~id (old_instr : terminator) + (instr : terminator) = + let compare_label l1 l2 = + let s1 = Label.Tbl.find successor_ids l1 in + let s2 = Label.Tbl.find successor_ids l2 in + if not (Int.equal s1 s2) + then + Cfg_regalloc_utils.fatal + "When checking equivalence of labels before and after allocation got \ + different successor id's. Successor (label, instr id) before: (%d, \ + %d). Successor (label, instr id) after: (%d, %d)." + l1 s1 l2 s2 + in + match old_instr, instr with + | Never, Never -> () + | Always l1, Always l2 -> compare_label l1 l2 + | ( Parity_test { ifso = ifso1; ifnot = ifnot1 }, + Parity_test { ifso = ifso2; ifnot = ifnot2 } ) -> + compare_label ifso1 ifso2; + compare_label ifnot1 ifnot2 + | ( Truth_test { ifso = ifso1; ifnot = ifnot1 }, + Truth_test { ifso = ifso2; ifnot = ifnot2 } ) -> + compare_label ifso1 ifso2; + compare_label ifnot1 ifnot2 + | ( Float_test { lt = lt1; eq = eq1; gt = gt1; uo = uo1 }, + Float_test { lt = lt2; eq = eq2; gt = gt2; uo = uo2 } ) -> + compare_label lt1 lt2; + compare_label eq1 eq2; + compare_label gt1 gt2; + compare_label uo1 uo2 + | ( Int_test { lt = lt1; eq = eq1; gt = gt1; is_signed = sign1; imm = imm1 }, + Int_test { lt = lt2; eq = eq2; gt = gt2; is_signed = sign2; imm = imm2 } + ) + when Bool.equal sign1 sign2 && Option.equal Int.equal imm1 imm2 -> + compare_label lt1 lt2; + compare_label eq1 eq2; + compare_label gt1 gt2 + | Switch labels1, Switch labels2 -> + Array.iter2 (fun l1 l2 -> compare_label l1 l2) labels1 labels2 + | Return, Return -> () + | Raise rk1, Raise rk2 + (* CR-someday azewierzejew: Avoid using polymorphic comparison. *) + when Stdlib.compare rk1 rk2 = 0 -> + () + | Tailcall_self { destination = l1 }, Tailcall_self { destination = l2 } -> + compare_label l1 l2 + | Tailcall_func call1, Tailcall_func call2 + (* CR-someday azewierzejew: Avoid using polymorphic comparison. *) + when Stdlib.compare call1 call2 = 0 -> + () + | Call_no_return call1, Call_no_return call2 + (* CR-someday azewierzejew: Avoid using polymorphic comparison. *) + when Stdlib.compare call1 call2 = 0 -> + () + | ( Call { op = call1; label_after = l1 }, + Call { op = call2; label_after = l2 } ) + (* CR-someday azewierzejew: Avoid using polymorphic comparison. *) + when Stdlib.compare call1 call2 = 0 -> + compare_label l1 l2 + | ( Prim { op = prim1; label_after = l1 }, + Prim { op = prim2; label_after = l2 } ) + (* CR-someday azewierzejew: Avoid using polymorphic comparison. *) + when Stdlib.compare prim1 prim2 = 0 -> + compare_label l1 l2 + | ( Specific_can_raise { op = op1; label_after = l1 }, + Specific_can_raise { op = op2; label_after = l2 } ) + (* CR-someday azewierzejew: Avoid using polymorphic comparison. *) + when Stdlib.compare op1 op2 = 0 -> + compare_label l1 l2 + | Poll_and_jump l1, Poll_and_jump l2 -> compare_label l1 l2 + | _ -> + Cfg_regalloc_utils.fatal + "The desc of terminator with id %d changed, before: %a, after: %a." id + (Cfg.dump_terminator ~sep:", ") + old_instr + (Cfg.dump_terminator ~sep:", ") + instr + + let verify_terminator ~seen_ids ~successor_ids t instr = + let id = instr.id in + add_instr_id ~seen_ids + ~context:"checking a terminator instruction in the new CFG" id; + match Hashtbl.find_opt t.terminators id with + (* The instruction was present before. *) + | Some old_instr -> + verify_reg_arrays ~id instr old_instr; + compare_terminators ~successor_ids ~id old_instr.desc instr.desc; + id + | None -> ( + match instr.desc with + | Always successor -> + (* A terminator added by the register allocator. The successor + instruction can be found in the next block. *) + Label.Tbl.find successor_ids successor + | _ -> + Cfg_regalloc_utils.fatal + "Register allocation added a terminator no. %d but that's not \ + allowed for this type of terminator: %a" + id Cfg.print_terminator instr) + + let compute_successor_ids t (cfg : Cfg.t) = + let visited_labels = Label.Tbl.create (Label.Tbl.length cfg.blocks) in + let successor_ids = Label.Tbl.create (Label.Tbl.length cfg.blocks) in + (* Finds and stores successor id for a given block. *) + let rec get_id (block : Cfg.basic_block) = + match Label.Tbl.find_opt successor_ids block.start with + | Some id -> id + | None -> + if Label.Tbl.mem visited_labels block.start + then + Misc.fatal_errorf + "Visiting the same block %d without knowing the successor \ + instruction's id. That means there's a loop consisting of only \ + instructions added by the register allocator." + block.start; + Label.Tbl.add visited_labels block.start (); + let first_id = get_first_non_regalloc_id t block in + Label.Tbl.add successor_ids block.start first_id; + first_id + (* Finds successor id in or after the given block. *) + and get_first_non_regalloc_id t (block : Cfg.basic_block) = + let res : Cfg.basic Cfg.instruction option = + Cfg.BasicInstructionList.fold_left + ~f:(fun acc instr -> + match acc with + | Some _ -> acc + | None -> + if Hashtbl.mem t.instructions instr.id then Some instr else None) + block.body ~init:None + in + match res with + | Some instr -> instr.id + | None -> ( + match + block.terminator.desc, Hashtbl.mem t.terminators block.terminator.id + with + | _, true -> block.terminator.id + | Always label, false -> get_id (Cfg.get_block_exn cfg label) + | _, false -> + Cfg_regalloc_utils.fatal + "Register allocation added a terminator no. %d but that's not \ + allowed for this type of terminator: %a" + block.terminator.id Cfg.print_terminator block.terminator) + in + Label.Tbl.iter + (fun _ block -> + (* Force compuatation of the given id. *) + let (_ : int) = get_id block in + ()) + cfg.blocks; + successor_ids + let verify t cfg = Cfg_regalloc_utils.postcondition cfg ~allow_stack_operands:true; verify_reg_array ~reg_arr:t.reg_fun_args ~context:"In function arguments" @@ -471,11 +666,22 @@ end = struct Hashtbl.create (Hashtbl.length t.instructions + Hashtbl.length t.terminators) in - Cfg_with_layout.iter_instructions cfg - ~instruction:(make_instruction_helper t (verify_instr ~seen_ids)) - ~terminator:(make_terminator_helper t (verify_instr ~seen_ids)); + let successor_ids = compute_successor_ids t (Cfg_with_layout.cfg cfg) in + Label.Tbl.iter + (fun _ (block : Cfg.basic_block) -> + let successor_id = + verify_terminator ~seen_ids ~successor_ids t block.terminator + in + let first_instruction_id = + Cfg.BasicInstructionList.fold_right + ~f:(fun instr successor_id -> + verify_basic ~seen_ids ~successor_id t instr) + block.body ~init:successor_id + in + ignore (first_instruction_id : int)) + (Cfg_with_layout.cfg cfg).Cfg.blocks; Hashtbl.iter - (fun id instr -> + (fun id { instr; _ } -> let can_be_removed = match instr.Instruction.desc with | Prologue -> @@ -852,6 +1058,8 @@ module Transfer (Desc_val : Description_value) : type error = Transfer_error.t + let description = Desc_val.description + (** This corresponds to case (10) in Fig. 1 of the paper [1]. *) let rename_location equations ~loc_instr = assert (Array.length loc_instr.arg = 1); @@ -944,41 +1152,54 @@ module Transfer (Desc_val : Description_value) : ~loc_arg:(Location.of_regs_exn loc_instr.arg) equations) - let[@inline] transfer_generic (type a) (instr_kind : a Instruction.Kind.t) - ~(find_description : Description.t -> a instruction -> a Instruction.t) - ~(can_raise : a -> bool) ~(destroyed_at : a -> Reg.t array) : - domain -> exn:domain -> a instruction -> (domain, error) result = - fun t ~exn instr -> - let exn = if can_raise instr.desc then Some exn else None in - let instr_before = find_description Desc_val.description instr in - append_equations t ~instr_kind ~exn ~reg_instr:instr_before ~loc_instr:instr - ~destroyed:(destroyed_at instr.desc |> Location.of_regs_exn) - - let basic t ~exn instr : (domain, error) result = - match instr.desc with - | Op (Spill | Reload) -> - assert (not (Cfg.can_raise_basic instr.desc)); + let basic t instr : (domain, error) result = + match Description.find_basic description instr with + | None -> + (match instr.desc with Op (Spill | Reload) -> () | _ -> assert false); Result.ok @@ rename_location t ~loc_instr:instr - | Op Move - when Array.length instr.arg = 1 - && Array.length instr.res = 1 - && Reg.same_loc instr.arg.(0) instr.res.(0) -> - (* This corresponds to a noop move where the source and target registers - have the same locations. *) - assert (not (Cfg.can_raise_basic instr.desc)); - let instr_before = Description.find_basic Desc_val.description instr in - Result.ok @@ rename_register t ~reg_instr:instr_before - | _ -> - transfer_generic Basic ~find_description:Description.find_basic - ~can_raise:Cfg.can_raise_basic ~destroyed_at:Proc.destroyed_at_basic t - ~exn instr + | Some instr_before -> ( + match instr.desc with + | Op Move + when Array.length instr.arg = 1 + && Array.length instr.res = 1 + && Reg.same_loc instr.arg.(0) instr.res.(0) -> + (* This corresponds to a noop move where the source and target registers + have the same locations. *) + Result.ok @@ rename_register t ~reg_instr:instr_before + | _ -> + append_equations t ~instr_kind:Instruction.Kind.Basic ~exn:None + ~reg_instr:instr_before ~loc_instr:instr + ~destroyed:(Proc.destroyed_at_basic instr.desc |> Location.of_regs_exn) + ) let terminator t ~exn instr = - (* CR-soon azewierzejew: This is kind of fragile for [Tailcall (Self _)] - because that instruction doesn't strictly adhere to generic semantics. *) - transfer_generic Terminator ~find_description:Description.find_terminator - ~can_raise:Cfg.can_raise_terminator - ~destroyed_at:Proc.destroyed_at_terminator t ~exn instr + match Description.find_terminator description instr with + | Some instr_before -> + (* CR-soon azewierzejew: This is kind of fragile for [Tailcall (Self _)] + because that instruction doesn't strictly adhere to generic + semantics. *) + let exn = + if Cfg.can_raise_terminator instr.desc then Some exn else None + in + append_equations t ~instr_kind:Instruction.Kind.Terminator ~exn + ~reg_instr:instr_before ~loc_instr:instr + ~destroyed: + (Proc.destroyed_at_terminator instr.desc |> Location.of_regs_exn) + | None -> ( + Result.ok + @@ + match instr.desc with + | Always _ -> + (* [Always] is always an identity. *) + assert (not (Cfg.can_raise_terminator instr.desc)); + assert (Array.length instr.arg = 0); + assert (Array.length instr.res = 0); + t + | _ -> + Cfg_regalloc_utils.fatal + "Register allocation added a terminator no. %d but that's not \ + allowed for this type of terminator: %a" + instr.id Cfg.print_terminator instr) (* This should remove the equations for the exception value, but we do that in [Domain.append_equations] because there we have more information to give if @@ -1004,17 +1225,17 @@ let save_as_dot_with_equations ~desc ~res_instr ~res_block ?filename cfg msg = Equation_set.print ppf); Cfg.print_instruction' ~print_reg:print_reg_as_loc; (fun ppf instr -> - match instr with - | `Basic instr -> ( - match Description.find_basic desc instr with - | prev_instr -> + let print printer find instr = + match find desc instr with + | Some prev_instr -> let instr = Instruction.to_prealloc ~alloced:instr prev_instr in - Cfg.print_basic ppf instr - | exception Not_found -> ()) + printer ppf instr + | None -> () + in + match instr with + | `Basic instr -> print Cfg.print_basic Description.find_basic instr | `Terminator ti -> - let prev_ti = Description.find_terminator desc ti in - let ti = Instruction.to_prealloc ~alloced:ti prev_ti in - Cfg.print_terminator ppf ti) ] + print Cfg.print_terminator Description.find_terminator ti) ] ~annotate_block_end:(fun ppf block -> Label.Tbl.find_opt res_block block.start |> Format.pp_print_option @@ -1180,7 +1401,7 @@ let test (desc : Description.t) (cfg : Cfg_with_layout.t) : let entrypoint_equations = let cfg = Cfg_with_layout.cfg cfg in let entry_block = Cfg.entry_label cfg |> Cfg.get_block_exn cfg in - let entry_id = Cfg_regalloc_utils.first_instruction_id entry_block in + let entry_id = Cfg.first_instruction_id entry_block in Cfg_dataflow.Instr.Tbl.find res_instr entry_id in verify_entrypoint entrypoint_equations desc cfg diff --git a/backend/cfg/cfg_to_linear.ml b/backend/cfg/cfg_to_linear.ml index 84f5f6cbb16..e228e391179 100644 --- a/backend/cfg/cfg_to_linear.ml +++ b/backend/cfg/cfg_to_linear.ml @@ -100,9 +100,10 @@ let linearize_terminator cfg (terminator : Cfg.terminator Cfg.instruction) we are making an arbitrary choice. *) (* If one of the successors is a fallthrough label, do not emit a jump for it. Otherwise, the last jump is unconditional. *) - let branch_or_fallthrough lbl = - if Label.equal next.label lbl then [] else [L.Lbranch lbl] + let branch_or_fallthrough d lbl = + if Label.equal next.label lbl then d else d @ [L.Lbranch lbl] in + let single d = [d], None in let emit_bool (c1, l1) (c2, l2) = (* c1 must be the inverse of c2 *) match Label.equal l1 next.label, Label.equal l2 next.label with @@ -116,22 +117,42 @@ let linearize_terminator cfg (terminator : Cfg.terminator Cfg.instruction) in let desc_list, tailrec_label = match terminator.desc with - | Return -> [L.Lreturn], None - | Raise kind -> [L.Lraise kind], None - | Tailcall (Func Indirect) -> [L.Lop Itailcall_ind], None - | Tailcall (Func (Direct { func_symbol })) -> - [L.Lop (Itailcall_imm { func = func_symbol })], None - | Tailcall (Self { destination }) -> + | Return -> single L.Lreturn + | Raise kind -> single (L.Lraise kind) + | Tailcall_func Indirect -> single (L.Lop Itailcall_ind) + | Tailcall_func (Direct { func_symbol }) -> + single (L.Lop (Itailcall_imm { func = func_symbol })) + | Tailcall_self { destination } -> [L.Lop (Itailcall_imm { func = Cfg.fun_name cfg })], Some destination | Call_no_return { func_symbol; alloc; ty_args; ty_res } -> - ( [ L.Lop - (Iextcall - { func = func_symbol; alloc; ty_args; ty_res; returns = false }) - ], - None ) - | Switch labels -> [L.Lswitch labels], None + single + (L.Lop + (Iextcall + { func = func_symbol; alloc; ty_args; ty_res; returns = false })) + | Call { op; label_after } -> + let op : Mach.operation = + match op with + | Indirect -> Icall_ind + | Direct { func_symbol } -> Icall_imm { func = func_symbol } + in + branch_or_fallthrough [L.Lop op] label_after, None + | Prim { op; label_after } -> + let op : Mach.operation = + match op with + | External { func_symbol; alloc; ty_args; ty_res } -> + Iextcall + { func = func_symbol; alloc; ty_args; ty_res; returns = true } + | Checkbound { immediate = None } -> Iintop Icheckbound + | Checkbound { immediate = Some i } -> Iintop_imm (Icheckbound, i) + | Alloc { bytes; dbginfo; mode } -> Ialloc { bytes; dbginfo; mode } + | Probe { name; handler_code_sym } -> Iprobe { name; handler_code_sym } + in + branch_or_fallthrough [L.Lop op] label_after, None + | Specific_can_raise { op; label_after } -> + branch_or_fallthrough [L.Lop (Ispecific op)] label_after, None + | Switch labels -> single (L.Lswitch labels) | Never -> Misc.fatal_error "Cannot linearize terminator: Never" - | Always label -> branch_or_fallthrough label, None + | Always label -> branch_or_fallthrough [] label, None | Parity_test { ifso; ifnot } -> emit_bool (Ieventest, ifso) (Ioddtest, ifnot), None | Truth_test { ifso; ifnot } -> @@ -143,7 +164,7 @@ let linearize_terminator cfg (terminator : Cfg.terminator Cfg.instruction) in match Label.Set.cardinal successor_labels with | 0 -> assert false - | 1 -> branch_or_fallthrough (Label.Set.min_elt successor_labels), None + | 1 -> branch_or_fallthrough [] (Label.Set.min_elt successor_labels), None | 2 | 3 | 4 -> let must_be_last, any = Label.Set.fold @@ -186,7 +207,7 @@ let linearize_terminator cfg (terminator : Cfg.terminator Cfg.instruction) else Some (L.Lcondbranch (Ifloattest c, lbl))) any in - branches @ branch_or_fallthrough last, None + branches @ branch_or_fallthrough [] last, None | _ -> assert false) | Int_test { lt; eq; gt; imm; is_signed } -> ( let successor_labels = @@ -194,7 +215,7 @@ let linearize_terminator cfg (terminator : Cfg.terminator Cfg.instruction) in match Label.Set.cardinal successor_labels with | 0 -> assert false - | 1 -> branch_or_fallthrough (Label.Set.min_elt successor_labels), None + | 1 -> branch_or_fallthrough [] (Label.Set.min_elt successor_labels), None | 2 | 3 -> (* If fallthrough label is a successor, do not emit a jump for it. Otherwise, the last jump could be unconditional. *) @@ -219,7 +240,7 @@ let linearize_terminator cfg (terminator : Cfg.terminator Cfg.instruction) let find l = if Label.equal next.label l then None else Some l in [L.Lcondbranch3 (find lt, find eq, find gt)], None else - let init = branch_or_fallthrough last in + let init = branch_or_fallthrough [] last in ( Label.Set.fold (fun lbl acc -> let cond = @@ -240,6 +261,8 @@ let linearize_terminator cfg (terminator : Cfg.terminator Cfg.instruction) cond_successor_labels init, None ) | _ -> assert false) + | Poll_and_jump return_label -> + [L.Lop (Ipoll { return_label = Some return_label })], None in ( List.fold_left (fun next desc -> to_linear_instr ~like:terminator desc ~next) @@ -258,19 +281,22 @@ let need_starting_label (cfg_with_layout : CL.t) (block : Cfg.basic_block) (* This block has a single predecessor which appears in the layout immediately prior to this block. *) (* No need for the label, unless the predecessor's terminator is [Switch] - when the label is needed for the jump table. *) - (* CR-someday gyorsh: is this correct with label_after for calls? *) + when the label is needed for the jump table; or [Poll_and_jump], in + which case there will always be a jump to such label. *) match prev_block.terminator.desc with - | Switch _ -> true + | Switch _ | Poll_and_jump _ -> true | Never -> Misc.fatal_error "Cannot linearize terminator: Never" - | Always _ | Parity_test _ | Truth_test _ | Float_test _ | Int_test _ -> + | Always _ | Parity_test _ | Truth_test _ | Float_test _ | Int_test _ + | Call _ | Prim _ | Specific_can_raise _ -> (* If the label came from the original [Linear] code, preserve it for checking that the conversion from [Linear] to [Cfg] and back is the identity; and for various assertions in reorder. *) let new_labels = CL.new_labels cfg_with_layout in CL.preserve_orig_labels cfg_with_layout && not (Label.Set.mem block.start new_labels) - | Return | Raise _ | Tailcall _ | Call_no_return _ -> assert false) + | Return | Raise _ | Tailcall_func _ | Tailcall_self _ | Call_no_return _ + -> + assert false) let adjust_stack_offset body (block : Cfg.basic_block) ~(prev_block : Cfg.basic_block) = @@ -304,9 +330,9 @@ let run cfg_with_layout = | (Some _ | None), None -> () | None, Some _ -> tailrec_label := terminator_tailrec_label | Some old_trl, Some new_trl -> assert (Label.equal old_trl new_trl)); - List.fold_left - (fun next i -> basic_to_linear i ~next) - terminator (List.rev block.body) + Cfg.BasicInstructionList.fold_right + ~f:(fun i next -> basic_to_linear i ~next) + ~init:terminator block.body in let insn = if i = 0 @@ -344,8 +370,7 @@ let run cfg_with_layout = fun_contains_calls; fun_num_stack_slots; fun_frame_required; - fun_prologue_required; - fun_end_label = Cmm.new_label () + fun_prologue_required } (** debug print block as assembly *) diff --git a/backend/cfg/cfg_to_linear_desc.ml b/backend/cfg/cfg_to_linear_desc.ml index ca939a6d84e..d034ccf4578 100644 --- a/backend/cfg/cfg_to_linear_desc.ml +++ b/backend/cfg/cfg_to_linear_desc.ml @@ -6,16 +6,6 @@ let from_basic (basic : basic) : Linear.instruction_desc = | Reloadretaddr -> Lreloadretaddr | Pushtrap { lbl_handler } -> Lpushtrap { lbl_handler } | Poptrap -> Lpoptrap - | Call (F Indirect) -> Lop Icall_ind - | Call (F (Direct { func_symbol })) -> Lop (Icall_imm { func = func_symbol }) - | Call (P (External { func_symbol; alloc; ty_args; ty_res })) -> - Lop - (Iextcall { func = func_symbol; alloc; ty_args; ty_res; returns = true }) - | Call (P (Checkbound { immediate = None })) -> Lop (Iintop Icheckbound) - | Call (P (Checkbound { immediate = Some i })) -> - Lop (Iintop_imm (Icheckbound, i)) - | Call (P (Alloc { bytes; dbginfo; mode })) -> - Lop (Ialloc { bytes; dbginfo; mode }) | Op op -> let op : Mach.operation = match op with @@ -30,6 +20,7 @@ let from_basic (basic : basic) : Linear.instruction_desc = | Store (c, m, b) -> Istore (c, m, b) | Intop op -> Iintop op | Intop_imm (op, i) -> Iintop_imm (op, i) + | Intop_atomic { op; size; addr } -> Iintop_atomic { op; size; addr } | Negf -> Inegf | Absf -> Iabsf | Addf -> Iaddf @@ -37,11 +28,11 @@ let from_basic (basic : basic) : Linear.instruction_desc = | Mulf -> Imulf | Divf -> Idivf | Compf c -> Icompf c + | Csel c -> Icsel c | Floatofint -> Ifloatofint | Intoffloat -> Iintoffloat | Valueofint -> Ivalueofint | Intofvalue -> Iintofvalue - | Probe { name; handler_code_sym } -> Iprobe { name; handler_code_sym } | Probe_is_enabled { name } -> Iprobe_is_enabled { name } | Opaque -> Iopaque | Specific op -> Ispecific op diff --git a/backend/cfg/cfg_with_layout.ml b/backend/cfg/cfg_with_layout.ml index e05bb9cdaeb..d6575c35a62 100644 --- a/backend/cfg/cfg_with_layout.ml +++ b/backend/cfg/cfg_with_layout.ml @@ -64,6 +64,27 @@ let remove_block t label = t.layout <- List.filter (fun l -> not (Label.equal l label)) t.layout; t.new_labels <- Label.Set.remove label t.new_labels +let remove_blocks t labels_to_remove = + if not (Label.Set.is_empty labels_to_remove) + then ( + Cfg.remove_blocks t.cfg labels_to_remove; + t.layout + <- List.filter (fun l -> not (Label.Set.mem l labels_to_remove)) t.layout; + t.new_labels <- Label.Set.diff t.new_labels labels_to_remove) + +let add_block t (block : Cfg.basic_block) ~after = + t.new_labels <- Label.Set.add block.start t.new_labels; + let initial_len = List.length t.layout in + t.layout + <- List.fold_right + (fun label layout -> + if Label.equal label after + then label :: block.start :: layout + else label :: layout) + t.layout []; + assert (List.length t.layout = initial_len + 1); + Cfg.add_block_exn t.cfg block + let is_trap_handler t label = let block = Cfg.get_block_exn t.cfg label in block.is_trap_handler @@ -79,7 +100,9 @@ let dump ppf t ~msg = let print_block label = let block = Label.Tbl.find t.cfg.blocks label in fprintf ppf "\n%d:\n" label; - List.iter (fprintf ppf "%a\n" Cfg.print_basic) block.body; + Cfg.BasicInstructionList.iter + ~f:(fprintf ppf "%a\n" Cfg.print_basic) + block.body; Cfg.print_terminator ppf block.terminator; fprintf ppf "\npredecessors:"; Label.Set.iter (fprintf ppf " %d") block.predecessors; @@ -187,7 +210,7 @@ let print_dot ?(show_instr = true) ?(show_exn = true) (print_row (print_cell ~col_span:col_count ~align:Center (Format.dprintf ".L%d:I%d:S%d%s%s%s" label show_index - (List.length block.body) + (Cfg.BasicInstructionList.length block.body) (if block.stack_offset > 0 then ":T" ^ string_of_int block.stack_offset else "") @@ -203,8 +226,8 @@ let print_dot ?(show_instr = true) ?(show_exn = true) Format.pp_print_int) (Label.Set.to_seq block.predecessors)))) ppf; - List.iter - (fun (i : _ Cfg.instruction) -> + Cfg.BasicInstructionList.iter + ~f:(fun (i : _ Cfg.instruction) -> (print_row (print_cell ~align:Right (Format.dprintf "%d" i.id) ++ annotate_instr (`Basic i))) @@ -338,7 +361,7 @@ let iter_instructions : unit = fun cfg_with_layout ~instruction ~terminator -> Cfg.iter_blocks cfg_with_layout.cfg ~f:(fun _label block -> - List.iter instruction block.body; + Cfg.BasicInstructionList.iter ~f:instruction block.body; terminator block.terminator) let fold_instructions : @@ -350,6 +373,8 @@ let fold_instructions : a = fun cfg_with_layout ~instruction ~terminator ~init -> Cfg.fold_blocks cfg_with_layout.cfg ~init ~f:(fun _label block acc -> - let acc = List.fold_left instruction acc block.body in + let acc = + Cfg.BasicInstructionList.fold_left ~f:instruction ~init:acc block.body + in let acc = terminator acc block.terminator in acc) diff --git a/backend/cfg/cfg_with_layout.mli b/backend/cfg/cfg_with_layout.mli index 2df599cd048..190e64e273d 100644 --- a/backend/cfg/cfg_with_layout.mli +++ b/backend/cfg/cfg_with_layout.mli @@ -44,9 +44,17 @@ val new_labels : t -> Label.Set.t val set_layout : t -> Label.t list -> unit +(** Add to cfg, layout, and other data-structures that track labels. *) +val add_block : t -> Cfg.basic_block -> after:Label.t -> unit + (** Remove from cfg, layout, and other data-structures that track labels. *) val remove_block : t -> Label.t -> unit +(* CR-soon gyorsh: [remove_block] is expensive because [layout] is implemented + as [list]. Bulk removal is a temporary workaround, until we optimize [layout] + implementation. *) +val remove_blocks : t -> Label.Set.t -> unit + val is_trap_handler : t -> Label.t -> bool val save_as_dot : diff --git a/backend/cfg/cfgize.ml b/backend/cfg/cfgize.ml index 22de815fc67..2874c311a6f 100644 --- a/backend/cfg/cfgize.ml +++ b/backend/cfg/cfgize.ml @@ -129,6 +129,7 @@ end type basic_or_terminator = | Basic of Cfg.basic | Terminator of Cfg.terminator + | With_next_label of (Label.t -> Cfg.terminator) let basic_or_terminator_of_operation : State.t -> Mach.operation -> basic_or_terminator = @@ -140,28 +141,45 @@ let basic_or_terminator_of_operation : | Iconst_int i -> Basic (Op (Const_int i)) | Iconst_float f -> Basic (Op (Const_float f)) | Iconst_symbol s -> Basic (Op (Const_symbol s)) - | Icall_ind -> Basic (Call (F Indirect)) - | Icall_imm { func } -> Basic (Call (F (Direct { func_symbol = func }))) - | Itailcall_ind -> Terminator (Tailcall (Func Indirect)) + | Icall_ind -> + With_next_label (fun label_after -> Call { op = Indirect; label_after }) + | Icall_imm { func } -> + With_next_label + (fun label_after -> + Call { op = Direct { func_symbol = func }; label_after }) + | Itailcall_ind -> Terminator (Tailcall_func Indirect) | Itailcall_imm { func } -> Terminator - (Tailcall - (if String.equal (State.get_fun_name state) func - then Self { destination = State.get_tailrec_label state } - else Func (Direct { func_symbol = func }))) + (if String.equal (State.get_fun_name state) func + then Tailcall_self { destination = State.get_tailrec_label state } + else Tailcall_func (Direct { func_symbol = func })) | Iextcall { func; ty_res; ty_args; alloc; returns } -> let external_call = { Cfg.func_symbol = func; alloc; ty_res; ty_args } in if returns - then Basic (Call (P (External external_call))) + then + With_next_label + (fun label_after -> Prim { op = External external_call; label_after }) else Terminator (Call_no_return external_call) | Istackoffset ofs -> Basic (Op (Stackoffset ofs)) | Iload (mem, mode, mut) -> Basic (Op (Load (mem, mode, mut))) | Istore (mem, mode, assignment) -> Basic (Op (Store (mem, mode, assignment))) | Ialloc { bytes; dbginfo; mode } -> - Basic (Call (P (Alloc { bytes; dbginfo; mode }))) - | Iintop Icheckbound -> Basic (Call (P (Checkbound { immediate = None }))) + With_next_label + (fun label_after -> + Prim { op = Alloc { bytes; dbginfo; mode }; label_after }) + | Iintop Icheckbound -> + With_next_label + (fun label_after -> + Prim { op = Checkbound { immediate = None }; label_after }) + | Ipoll { return_label = None } -> + With_next_label (fun label_after -> Poll_and_jump label_after) + | Ipoll { return_label = Some return_label } -> + Misc.fatal_errorf "Cfgize.basic_or_terminator: unexpected Ipoll %d" + return_label | Iintop_imm (Icheckbound, i) -> - Basic (Call (P (Checkbound { immediate = Some i }))) + With_next_label + (fun label_after -> + Prim { op = Checkbound { immediate = Some i }; label_after }) | Iintop (( Iadd | Isub | Imul | Imulh _ | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Iclz _ | Ictz _ | Ipopcnt | Icomp _ ) as op) -> @@ -171,6 +189,9 @@ let basic_or_terminator_of_operation : | Ilsr | Iasr | Iclz _ | Ictz _ | Ipopcnt | Icomp _ ) as op), imm ) -> Basic (Op (Intop_imm (op, imm))) + | Iintop_atomic { op; size; addr } -> + Basic (Op (Intop_atomic { op; size; addr })) + | Icsel tst -> Basic (Op (Csel tst)) | Icompf comp -> Basic (Op (Compf comp)) | Inegf -> Basic (Op Negf) | Iabsf -> Basic (Op Absf) @@ -182,14 +203,21 @@ let basic_or_terminator_of_operation : | Iintoffloat -> Basic (Op Intoffloat) | Ivalueofint -> Basic (Op Valueofint) | Iintofvalue -> Basic (Op Intofvalue) - | Ispecific op -> Basic (Op (Specific op)) + | Ispecific op -> + if Arch.operation_can_raise op + then + With_next_label + (fun label_after -> Specific_can_raise { op; label_after }) + else Basic (Op (Specific op)) | Iopaque -> Basic (Op Opaque) | Iname_for_debugger _ -> Misc.fatal_error "Cfgize.basic_or_terminator_of_operation: \"the Iname_for_debugger\" \ instruction is currently not supported " | Iprobe { name; handler_code_sym } -> - Basic (Op (Probe { name; handler_code_sym })) + With_next_label + (fun label_after -> + Prim { op = Probe { name; handler_code_sym }; label_after }) | Iprobe_is_enabled { name } -> Basic (Op (Probe_is_enabled { name })) | Ibeginregion -> Basic (Op Begin_region) | Iendregion -> Basic (Op End_region) @@ -346,10 +374,15 @@ let rec get_end : Mach.instruction -> Mach.instruction = | Itrywith _ | Iraise _ -> get_end instr.Mach.next +type terminator_info = + | Terminator of Cfg.terminator Cfg.instruction + | With_next_label of (Label.t -> Cfg.terminator Cfg.instruction) + | Complex_terminator + type block_info = - { instrs : Cfg.basic Cfg.instruction list; + { instrs : Cfg.BasicInstructionList.t; last : Mach.instruction; - terminator : Cfg.terminator Cfg.instruction option + terminator : terminator_info } (* [extract_block_info state first] returns a [block_info] containing all the @@ -360,10 +393,7 @@ type block_info = let extract_block_info : State.t -> Mach.instruction -> block_info = fun state first -> let rec loop (instr : Mach.instruction) acc = - let return terminator instrs = - let instrs = List.rev instrs in - { instrs; last = instr; terminator } - in + let return terminator instrs = { instrs; last = instr; terminator } in match instr.desc with | Iop op -> ( match basic_or_terminator_of_operation state op with @@ -373,18 +403,21 @@ let extract_block_info : State.t -> Mach.instruction -> block_info = because we want to compute liveness information on CFG values, and (i) such moves are necessary to compute the live sets and (ii) they can only be identified as useless after register allocation. *) - let acc = instr' :: acc in - if Cfg.can_raise_basic desc - then return None acc - else loop instr.next acc + Cfg.BasicInstructionList.add_end acc instr'; + loop instr.next acc | Terminator terminator -> - return (Some (copy_instruction state instr ~desc:terminator)) acc) + return (Terminator (copy_instruction state instr ~desc:terminator)) acc + | With_next_label terminator -> + return + (With_next_label + (fun label_after -> + copy_instruction state instr ~desc:(terminator label_after))) + acc) | Iend | Ireturn _ | Iifthenelse _ | Iswitch _ | Icatch _ | Iexit _ - | Itrywith _ -> - return None acc - | Iraise _ -> return None acc + | Itrywith _ | Iraise _ -> + return Complex_terminator acc in - loop first [] + loop first (Cfg.BasicInstructionList.make_empty ()) (* Represents the control flow exiting the function without encountering a return. *) @@ -406,56 +439,38 @@ let rec add_blocks : let { instrs; last; terminator } = extract_block_info state instr in let terminate_block ~trap_actions terminator = let body = instrs in - let body = - match starts_with_pushtrap with - | None -> body - | Some lbl_handler -> - make_instruction state ~desc:(Cfg.Pushtrap { lbl_handler }) :: body - in - let body = - body - @ List.map - (function - | Cmm.Push handler_id -> - let lbl_handler = State.get_catch_handler state ~handler_id in - make_instruction state ~desc:(Cfg.Pushtrap { lbl_handler }) - | Cmm.Pop -> make_instruction state ~desc:Cfg.Poptrap) - trap_actions - in - let body = - match terminator.Cfg.desc with - | Cfg.Return -> - if State.get_contains_calls state - then body @ [make_instruction state ~desc:Cfg.Reloadretaddr] - else body - | Cfg.Never | Cfg.Always _ | Cfg.Parity_test _ | Cfg.Truth_test _ - | Cfg.Float_test _ | Cfg.Int_test _ | Cfg.Switch _ | Cfg.Raise _ - | Cfg.Tailcall _ | Cfg.Call_no_return _ -> - body - in + (match starts_with_pushtrap with + | None -> () + | Some lbl_handler -> + Cfg.BasicInstructionList.add_begin body + (make_instruction state ~desc:(Cfg.Pushtrap { lbl_handler }))); + List.iter + (fun trap_action -> + let instr = + match trap_action with + | Cmm.Push handler_id -> + let lbl_handler = State.get_catch_handler state ~handler_id in + make_instruction state ~desc:(Cfg.Pushtrap { lbl_handler }) + | Cmm.Pop -> make_instruction state ~desc:Cfg.Poptrap + in + Cfg.BasicInstructionList.add_end body instr) + trap_actions; + (match terminator.Cfg.desc with + | Cfg.Return -> + if State.get_contains_calls state + then + Cfg.BasicInstructionList.add_end body + (make_instruction state ~desc:Cfg.Reloadretaddr) + else () + | Cfg.Never | Cfg.Always _ | Cfg.Parity_test _ | Cfg.Truth_test _ + | Cfg.Float_test _ | Cfg.Int_test _ | Cfg.Switch _ | Cfg.Raise _ + | Cfg.Call_no_return _ | Cfg.Poll_and_jump _ | Cfg.Tailcall_self _ + | Cfg.Tailcall_func _ | Cfg.Call _ | Cfg.Prim _ | Cfg.Specific_can_raise _ + -> + ()); let can_raise = - (* Recompute [can_raise] and check that instructions in the middle of the - block do not raise, i.e., only the terminator, or the last instruction - (when the terminator is just a goto) can raise. *) - let terminator_is_goto = - match (terminator.Cfg.desc : Cfg.terminator) with - | Always _ -> true - | Raise _ | Tailcall _ | Call_no_return _ | Never | Parity_test _ - | Truth_test _ | Float_test _ | Int_test _ | Switch _ | Return -> - false - in - let rec check = function - | [] -> false - | [last] -> - let res = Cfg.can_raise_basic last.Cfg.desc in - assert ((not res) || terminator_is_goto); - res - | hd :: tail -> - assert (not (Cfg.can_raise_basic hd.Cfg.desc)); - check tail - in - let body_can_raise = check body in - Cfg.can_raise_terminator terminator.Cfg.desc || body_can_raise + (* Recompute [can_raise]. Only terminator can actually raise. *) + Cfg.can_raise_terminator terminator.Cfg.desc in State.add_block state ~label:start ~block: @@ -486,18 +501,16 @@ let rec add_blocks : start, add_next_block in match terminator with - | Some terminator -> terminate_block ~trap_actions:[] terminator - | None -> ( + | Terminator terminator -> terminate_block ~trap_actions:[] terminator + | With_next_label f -> + let next, add_next_block = prepare_next_block () in + terminate_block ~trap_actions:[] (f next); + add_next_block () + | Complex_terminator -> ( match last.desc with - | Iop op -> - if not (Mach.operation_can_raise op) - then - Misc.fatal_error - "Cfgize.extract_block_info: unexpected Iop with no terminator"; - let next, add_next_block = prepare_next_block () in - terminate_block ~trap_actions:[] - (copy_instruction_no_reg state last ~desc:(Cfg.Always next)); - add_next_block () + | Iop _ -> + Misc.fatal_error + "Cfgize.extract_block_info: unexpected Iop as Complex_terminator" | Iend -> if Label.equal next fallthrough_label then @@ -604,10 +617,7 @@ module Stack_offset_and_exn = struct stack_offset + (Proc.trap_size_in_bytes * List.length traps) let check_and_set_stack_offset : - 'a Cfg.instruction -> - stack_offset:int -> - traps:handler_stack -> - 'a Cfg.instruction = + 'a Cfg.instruction -> stack_offset:int -> traps:handler_stack -> unit = fun instr ~stack_offset ~traps -> assert (instr.stack_offset = invalid_stack_offset); Cfg.set_stack_offset instr (compute_stack_offset ~stack_offset ~traps) @@ -616,50 +626,48 @@ module Stack_offset_and_exn = struct stack_offset:int -> traps:handler_stack -> Cfg.terminator Cfg.instruction -> - int * handler_stack * Cfg.terminator Cfg.instruction = + int * handler_stack = fun ~stack_offset ~traps term -> - assert (term.stack_offset = invalid_stack_offset); - let term = check_and_set_stack_offset term ~stack_offset ~traps in + check_and_set_stack_offset term ~stack_offset ~traps; match term.desc with - | Tailcall (Self _) when List.length traps <> 0 || stack_offset <> 0 -> + | Tailcall_self _ when List.length traps <> 0 || stack_offset <> 0 -> Misc.fatal_error "Cfgize.Stack_offset_and_exn.process_terminator: unexpected handler on \ self tailcall" - | Tailcall (Self _) - | Never | Return - | Tailcall (Func _) - | Call_no_return _ | Raise _ | Always _ | Parity_test _ | Truth_test _ - | Float_test _ | Int_test _ | Switch _ -> - stack_offset, traps, term + | Never | Always _ | Parity_test _ | Truth_test _ | Float_test _ + | Int_test _ | Switch _ | Return | Raise _ | Tailcall_self _ + | Tailcall_func _ | Call_no_return _ | Call _ | Prim _ | Poll_and_jump _ + | Specific_can_raise _ -> + stack_offset, traps let rec process_basic : Cfg.t -> stack_offset:int -> traps:handler_stack -> Cfg.basic Cfg.instruction -> - int * handler_stack * Cfg.basic Cfg.instruction = + int * handler_stack = fun cfg ~stack_offset ~traps instr -> - let instr = check_and_set_stack_offset instr ~stack_offset ~traps in + check_and_set_stack_offset instr ~stack_offset ~traps; match instr.desc with | Pushtrap { lbl_handler } -> update_block cfg lbl_handler ~stack_offset ~traps; - stack_offset, lbl_handler :: traps, instr + stack_offset, lbl_handler :: traps | Poptrap -> ( match traps with | [] -> Misc.fatal_error "Cfgize.Stack_offset_and_exn.process_basic: trying to pop from an \ empty stack" - | _ :: traps -> stack_offset, traps, instr) - | Op (Stackoffset n) -> stack_offset + n, traps, instr + | _ :: traps -> stack_offset, traps) + | Op (Stackoffset n) -> stack_offset + n, traps | Op ( Move | Spill | Reload | Const_int _ | Const_float _ | Const_symbol _ - | Load _ | Store _ | Intop _ | Intop_imm _ | Negf | Absf | Addf | Subf - | Mulf | Divf | Compf _ | Floatofint | Intoffloat | Valueofint - | Intofvalue | Probe _ | Probe_is_enabled _ | Opaque | Begin_region - | End_region | Specific _ | Name_for_debugger _ ) - | Call _ | Reloadretaddr | Prologue -> - stack_offset, traps, instr + | Load _ | Store _ | Intop _ | Intop_imm _ | Intop_atomic _ | Negf + | Absf | Addf | Subf | Mulf | Divf | Compf _ | Floatofint | Intoffloat + | Valueofint | Csel _ | Intofvalue | Probe_is_enabled _ | Opaque + | Begin_region | End_region | Specific _ | Name_for_debugger _ ) + | Reloadretaddr | Prologue -> + stack_offset, traps (* The argument [stack_offset] has a different meaning from the field [stack_offset] of Cfg's basic_blocks and instructions. The argument @@ -680,19 +688,14 @@ module Stack_offset_and_exn = struct if was_invalid then ( block.stack_offset <- compute_stack_offset ~stack_offset ~traps; - let stack_offset, traps, body = - ListLabels.fold_left block.body ~init:(stack_offset, traps, []) - ~f:(fun (stack_offset, traps, body) instr -> - let stack_offset, traps, instr = - process_basic cfg ~stack_offset ~traps instr - in - stack_offset, traps, instr :: body) + let stack_offset, traps = + Cfg.BasicInstructionList.fold_left block.body ~init:(stack_offset, traps) + ~f:(fun (stack_offset, traps) instr -> + process_basic cfg ~stack_offset ~traps instr) in - block.body <- List.rev body; - let stack_offset, traps, terminator = + let stack_offset, traps = process_terminator ~stack_offset ~traps block.terminator in - block.terminator <- terminator; (* non-exceptional successors *) Label.Set.iter (update_block cfg ~stack_offset ~traps) @@ -728,7 +731,12 @@ let fundecl : fun_codegen_options; fun_dbg; fun_num_stack_slots; - fun_contains_calls + fun_contains_calls; + (* CR-someday mshinwell: [fun_poll] will need to be propagated in the + future, e.g. when writing a [Polling] equivalent on [Cfg]. We don't + do this at present since there is no need, and because + [Linear_to_cfg] doesn't have [fun_poll] available. *) + fun_poll = _ } = fundecl in @@ -756,14 +764,15 @@ let fundecl : { start = Cfg.entry_label cfg; body = (match prologue_required with - | false -> [] + | false -> Cfg.BasicInstructionList.make_empty () | true -> - let dbg = fun_body.dbg in - let fdo = Fdo_info.none in (* Note: the prologue must come after all `Iname_for_debugger` instructions (this is currently not a concern because we do not support such instructions). *) - [{ (make_instruction state ~desc:Cfg.Prologue) with dbg; fdo }]); + let instr = make_instruction state ~desc:Cfg.Prologue in + instr.dbg <- fun_body.dbg; + instr.fdo <- Fdo_info.none; + Cfg.BasicInstructionList.make_single instr); terminator = copy_instruction_no_reg state fun_body ~desc:(Cfg.Always tailrec_label); @@ -778,7 +787,7 @@ let fundecl : State.add_block state ~label:tailrec_label ~block: { start = tailrec_label; - body = []; + body = Cfg.BasicInstructionList.make_empty (); terminator = copy_instruction_no_reg state fun_body ~desc:(Cfg.Always start_label); (* See [Cfg.register_predecessors_for_all_blocks] *) diff --git a/backend/cfg/eliminate_dead_code.ml b/backend/cfg/eliminate_dead_code.ml index 9f7c88e2a8f..20883225bd8 100644 --- a/backend/cfg/eliminate_dead_code.ml +++ b/backend/cfg/eliminate_dead_code.ml @@ -28,7 +28,7 @@ module Transfer = struct exceptional : domain } - let basic value _ = { normal = value; exceptional = value } + let basic value _ = value let terminator value _ = { normal = value; exceptional = value } end @@ -64,8 +64,6 @@ let run_dead_block : Cfg_with_layout.t -> unit = block.terminator <- { block.terminator with desc = Cfg_intf.S.Never }; block.exn <- None) unreachable_labels; - Label.Set.iter - (fun label -> Cfg_with_layout.remove_block cfg_with_layout label) - unreachable_labels; + Cfg_with_layout.remove_blocks cfg_with_layout unreachable_labels; (* CR xclerc for xclerc: temporary. *) Eliminate_dead_blocks.run cfg_with_layout diff --git a/backend/cfg/eliminate_fallthrough_blocks.ml b/backend/cfg/eliminate_fallthrough_blocks.ml index e3f4168fa28..cc74a54bd9b 100644 --- a/backend/cfg/eliminate_fallthrough_blocks.ml +++ b/backend/cfg/eliminate_fallthrough_blocks.ml @@ -32,7 +32,7 @@ let is_fallthrough_block cfg_with_layout (block : C.basic_block) = let cfg = CL.cfg cfg_with_layout in if Label.equal cfg.entry_label block.start || block.is_trap_handler - || List.length block.body > 0 + || (not (Cfg.BasicInstructionList.is_empty block.body)) || not (C.is_pure_terminator block.terminator.desc) then None else diff --git a/backend/cfg/extra_debug.ml b/backend/cfg/extra_debug.ml index 5256a321e1f..93313a5fe47 100644 --- a/backend/cfg/extra_debug.ml +++ b/backend/cfg/extra_debug.ml @@ -50,17 +50,17 @@ let add cl = then prev else i.dbg in - let fdo = Fdo_info.create ~discriminator:i.id ~dbg in - dbg, { i with fdo } + i.fdo <- Fdo_info.create ~discriminator:i.id ~dbg; + dbg in let cfg = CL.cfg cl in let layout = CL.layout cl in let update_block prev label = let block = Cfg.get_block_exn cfg label in - let prev, new_body = List.fold_left_map update_instr prev block.body in - block.body <- new_body; - let prev, new_terminator = update_instr prev block.terminator in - block.terminator <- new_terminator; + let prev = + Cfg.BasicInstructionList.fold_left ~f:update_instr ~init:prev block.body + in + let prev = update_instr prev block.terminator in prev in ignore (List.fold_left update_block cfg.fun_dbg layout : Debuginfo.t) diff --git a/backend/cfg/linear_to_cfg.ml b/backend/cfg/linear_to_cfg.ml index b9fd9409b41..d9d57861d5e 100644 --- a/backend/cfg/linear_to_cfg.ml +++ b/backend/cfg/linear_to_cfg.ml @@ -168,7 +168,7 @@ let create_empty_block t start ~stack_offset ~traps = in let block : C.basic_block = { start; - body = []; + body = Cfg.BasicInstructionList.make_empty (); terminator; exn = None; predecessors = Label.Set.empty; @@ -192,8 +192,6 @@ let register_block t (block : C.basic_block) traps = Misc.fatal_errorf "A block with starting label %d is already registered" block.start; if !C.verbose then Printf.printf "registering block %d\n" block.start; - (* Body is constructed in reverse, fix it now: *) - block.body <- List.rev block.body; (* Update trap stacks of normal successor blocks. *) Label.Set.iter (fun label -> record_traps t label traps) @@ -348,72 +346,6 @@ let mk_int_test ~lbl ~inv ~imm (cmp : Mach.integer_comparison) : C.int_test = let block_is_registered t (block : C.basic_block) = Label.Tbl.mem t.cfg.blocks block.start -let add_terminator t (block : C.basic_block) (i : L.instruction) - (desc : C.terminator) ~stack_offset ~traps = - (* All terminators are followed by a label, except branches we created for - fallthroughs in Linear. *) - (match desc with - | Never -> Misc.fatal_error "Cannot add terminator: Never" - | Always _ | Parity_test _ | Truth_test _ | Float_test _ | Int_test _ -> () - | Switch _ | Return | Raise _ | Tailcall _ | Call_no_return _ -> - if not (Linear_utils.defines_label i.next) - then - Misc.fatal_errorf "Linear instruction not followed by label:@ %a" - Printlinear.instr - { i with Linear.next = Linear.end_instr }); - block.terminator <- create_instruction t desc ~stack_offset i; - if Cfg.can_raise_terminator desc then record_exn t block traps; - register_block t block traps - -let to_basic (mop : Mach.operation) : C.basic = - match mop with - | Icall_ind -> Call (F Indirect) - | Icall_imm { func } -> Call (F (Direct { func_symbol = func })) - | Iextcall { func; alloc; ty_args; ty_res; returns = true } -> - Call (P (External { func_symbol = func; alloc; ty_args; ty_res })) - | Iintop Icheckbound -> Call (P (Checkbound { immediate = None })) - | Iintop - (( Iadd | Isub | Imul | Imulh _ | Idiv | Imod | Iand | Ior | Ixor | Ilsl - | Ipopcnt | Iclz _ | Ictz _ | Ilsr | Iasr | Icomp _ ) as op) -> - Op (Intop op) - | Iintop_imm (Icheckbound, i) -> Call (P (Checkbound { immediate = Some i })) - | Iintop_imm - ( (( Iadd | Isub | Imul | Imulh _ | Idiv | Imod | Iand | Ior | Ixor - | Ipopcnt | Iclz _ | Ictz _ | Ilsl | Ilsr | Iasr | Icomp _ ) as op), - i ) -> - Op (Intop_imm (op, i)) - | Ialloc { bytes; dbginfo; mode } -> Call (P (Alloc { bytes; dbginfo; mode })) - | Iprobe { name; handler_code_sym } -> Op (Probe { name; handler_code_sym }) - | Iprobe_is_enabled { name } -> Op (Probe_is_enabled { name }) - | Istackoffset i -> Op (Stackoffset i) - | Iload (c, a, m) -> Op (Load (c, a, m)) - | Istore (c, a, b) -> Op (Store (c, a, b)) - | Imove -> Op Move - | Ispill -> Op Spill - | Ireload -> Op Reload - | Iconst_int n -> Op (Const_int n) - | Iconst_float n -> Op (Const_float n) - | Iconst_symbol n -> Op (Const_symbol n) - | Inegf -> Op Negf - | Iabsf -> Op Absf - | Iaddf -> Op Addf - | Isubf -> Op Subf - | Imulf -> Op Mulf - | Idivf -> Op Divf - | Icompf c -> Op (Compf c) - | Ifloatofint -> Op Floatofint - | Iintoffloat -> Op Intoffloat - | Ivalueofint -> Op Valueofint - | Iintofvalue -> Op Intofvalue - | Iopaque -> Op Opaque - | Ibeginregion -> Op Begin_region - | Iendregion -> Op End_region - | Ispecific op -> Op (Specific op) - | Iname_for_debugger { ident; which_parameter; provenance; is_assignment } -> - Op (Name_for_debugger { ident; which_parameter; provenance; is_assignment }) - | Itailcall_ind | Itailcall_imm _ | Iextcall { returns = false; _ } -> - assert false - let rec adjust_traps (i : L.instruction) ~stack_offset ~traps = (* We do not emit any executable code for this insn; it only moves the virtual stack pointer in the emitter. We do not have a corresponding insn in [Cfg] @@ -450,6 +382,42 @@ let rec create_blocks (t : t) (i : L.instruction) (block : C.basic_block) enough information to compute it upfront, but stack_offset is directly computed. *) let stack_offset, traps, i = adjust_traps i ~stack_offset ~traps in + let add_terminator (desc : C.terminator) ~(next : Linear.instruction) = + (* All terminators are followed by a label, except branches we created for + fallthroughs in Linear. *) + (match desc with + | Never -> Misc.fatal_error "Cannot add terminator: Never" + | Always _ | Parity_test _ | Truth_test _ | Float_test _ | Int_test _ + | Poll_and_jump _ | Call _ | Prim _ | Specific_can_raise _ | Switch _ -> + () + | Return | Raise _ | Tailcall_self _ | Tailcall_func _ | Call_no_return _ -> + if not (Linear_utils.defines_label i.next) + then + Misc.fatal_errorf "Linear instruction not followed by label:@ %a" + Printlinear.instr + { i with Linear.next = L.end_instr }); + block.terminator <- create_instruction t desc ~stack_offset i; + if Cfg.can_raise_terminator desc then record_exn t block traps; + register_block t block traps; + create_blocks t next block ~stack_offset ~traps + in + let terminator desc = add_terminator desc ~next:i.next in + let terminator_fallthrough (mk_desc : Label.t -> C.terminator) = + let fallthrough = get_or_make_label t i.next in + let desc = mk_desc fallthrough.label in + add_terminator desc ~next:fallthrough.insn + in + let terminator_call call = + terminator_fallthrough (fun label_after -> Call { op = call; label_after }) + in + let terminator_prim prim = + terminator_fallthrough (fun label_after -> Prim { op = prim; label_after }) + in + let basic desc = + C.BasicInstructionList.add_end block.body + (create_instruction t desc i ~stack_offset); + create_blocks t i.next block ~stack_offset ~traps + in match i.desc with | Ladjust_stack_offset _ -> assert false | Lend -> @@ -484,61 +452,52 @@ let rec create_blocks (t : t) (i : L.instruction) (block : C.basic_block) then Misc.fatal_errorf "Stack offset is %d, but it must be 0 at Lreturn" stack_offset; - add_terminator t block i Return ~stack_offset ~traps; - create_blocks t i.next block ~stack_offset ~traps - | Lraise kind -> - add_terminator t block i (Raise kind) ~stack_offset ~traps; - create_blocks t i.next block ~stack_offset ~traps + terminator Return + | Lraise kind -> terminator (Raise kind) | Lbranch lbl -> if !C.verbose then Printf.printf "Lbranch %d\n" lbl; - add_terminator t block i (Always lbl) ~stack_offset ~traps; - create_blocks t i.next block ~stack_offset ~traps + terminator (Always lbl) | Lcondbranch (cond, lbl) -> (* This representation does not preserve the order of successors. *) - let fallthrough = get_or_make_label t i.next in - let inv = fallthrough.label in - let desc : C.terminator = - match (cond : Mach.test) with - | Ieventest -> Parity_test { ifso = lbl; ifnot = inv } - | Ioddtest -> Parity_test { ifso = inv; ifnot = lbl } - | Itruetest -> Truth_test { ifso = lbl; ifnot = inv } - | Ifalsetest -> Truth_test { ifso = inv; ifnot = lbl } - | Ifloattest cmp -> Float_test (of_cmm_float_test cmp ~lbl ~inv) - | Iinttest cmp -> Int_test (mk_int_test cmp ~lbl ~inv ~imm:None) - | Iinttest_imm (cmp, n) -> - Int_test (mk_int_test cmp ~lbl ~inv ~imm:(Some n)) - in - add_terminator t block i desc ~stack_offset ~traps; - create_blocks t fallthrough.insn block ~stack_offset ~traps + terminator_fallthrough (fun inv -> + match (cond : Mach.test) with + | Ieventest -> Parity_test { ifso = lbl; ifnot = inv } + | Ioddtest -> Parity_test { ifso = inv; ifnot = lbl } + | Itruetest -> Truth_test { ifso = lbl; ifnot = inv } + | Ifalsetest -> Truth_test { ifso = inv; ifnot = lbl } + | Ifloattest cmp -> Float_test (of_cmm_float_test cmp ~lbl ~inv) + | Iinttest cmp -> Int_test (mk_int_test cmp ~lbl ~inv ~imm:None) + | Iinttest_imm (cmp, n) -> + Int_test (mk_int_test cmp ~lbl ~inv ~imm:(Some n))) | Lcondbranch3 (lbl0, lbl1, lbl2) -> - let fallthrough = get_or_make_label t i.next in - let get_dest lbl = Option.value lbl ~default:fallthrough.label in - let it : C.int_test = - { imm = Some 1; - is_signed = false; - lt = get_dest lbl0; - eq = get_dest lbl1; - gt = get_dest lbl2 - } - in - add_terminator t block i (Int_test it) ~stack_offset ~traps; - create_blocks t fallthrough.insn block ~stack_offset ~traps + terminator_fallthrough (fun l -> + let get_dest lbl = Option.value lbl ~default:l in + let it : C.int_test = + { imm = Some 1; + is_signed = false; + lt = get_dest lbl0; + eq = get_dest lbl1; + gt = get_dest lbl2 + } + in + Int_test it) | Lswitch labels -> (* CR-someday gyorsh: get rid of switches entirely and re-generate them based on optimization and perf data? *) - add_terminator t block i (Switch labels) ~stack_offset ~traps; - create_blocks t i.next block ~stack_offset ~traps + terminator (Switch labels) | Lpushtrap { lbl_handler } -> t.trap_handlers <- Label.Set.add lbl_handler t.trap_handlers; record_traps t lbl_handler traps; let desc = C.Pushtrap { lbl_handler } in - block.body <- create_instruction t desc ~stack_offset i :: block.body; + C.BasicInstructionList.add_end block.body + (create_instruction t desc ~stack_offset i); let stack_offset = stack_offset + Proc.trap_size_in_bytes in let traps = T.push traps lbl_handler in create_blocks t i.next block ~stack_offset ~traps | Lpoptrap -> let desc = C.Poptrap in - block.body <- create_instruction t desc ~stack_offset i :: block.body; + C.BasicInstructionList.add_end block.body + (create_instruction t desc ~stack_offset i); let stack_offset = stack_offset - Proc.trap_size_in_bytes in if stack_offset < 0 then Misc.fatal_error "Lpoptrap moves the stack offset below zero"; @@ -554,67 +513,97 @@ let rec create_blocks (t : t) (i : L.instruction) (block : C.basic_block) create_blocks t i.next block ~stack_offset ~traps | Lentertrap -> (* Must be the first instruction in the block. *) - assert (List.compare_length_with block.body 0 = 0); + assert (C.BasicInstructionList.is_empty block.body); block.is_trap_handler <- true; create_blocks t i.next block ~stack_offset ~traps - | Lprologue -> - let desc = C.Prologue in - block.body <- create_instruction t desc i ~stack_offset :: block.body; - create_blocks t i.next block ~stack_offset ~traps - | Lreloadretaddr -> - let desc = C.Reloadretaddr in - block.body <- create_instruction t desc i ~stack_offset :: block.body; - create_blocks t i.next block ~stack_offset ~traps + | Lprologue -> basic C.Prologue + | Lreloadretaddr -> basic C.Reloadretaddr | Lop mop -> ( + let basic desc = + assert (not (Mach.operation_can_raise mop)); + basic (C.Op desc) + in match mop with - | Itailcall_ind -> - let desc = C.Tailcall (Func Indirect) in - add_terminator t block i desc ~stack_offset ~traps; - create_blocks t i.next block ~stack_offset ~traps + | Itailcall_ind -> terminator (C.Tailcall_func Indirect) | Itailcall_imm { func = func_symbol } -> let desc = if String.equal func_symbol (C.fun_name t.cfg) then match t.tailrec_label with | None -> Misc.fatal_error "tail call to missing tailrec entry point" - | Some destination -> C.Tailcall (Self { destination }) - else C.Tailcall (Func (Direct { func_symbol })) + | Some destination -> C.Tailcall_self { destination } + else C.Tailcall_func (Direct { func_symbol }) in - add_terminator t block i desc ~stack_offset ~traps; - create_blocks t i.next block ~stack_offset ~traps + terminator desc | Iextcall { func; alloc; ty_args; ty_res; returns = false } -> - let desc = - C.Call_no_return { func_symbol = func; alloc; ty_args; ty_res } - in - add_terminator t block i desc ~stack_offset ~traps; - create_blocks t i.next block ~stack_offset ~traps + terminator + (C.Call_no_return { func_symbol = func; alloc; ty_args; ty_res }) + | Icall_ind -> terminator_call Indirect + | Icall_imm { func } -> terminator_call (Direct { func_symbol = func }) + | Iextcall { func; alloc; ty_args; ty_res; returns = true } -> + terminator_prim (External { func_symbol = func; alloc; ty_args; ty_res }) + | Iintop Icheckbound -> terminator_prim (Checkbound { immediate = None }) + | Iintop_imm (Icheckbound, i) -> + terminator_prim (Checkbound { immediate = Some i }) + | Ialloc { bytes; dbginfo; mode } -> + terminator_prim (Alloc { bytes; dbginfo; mode }) + | Iprobe { name; handler_code_sym } -> + terminator_prim (Probe { name; handler_code_sym }) | Istackoffset bytes -> - let desc = to_basic mop in - block.body <- create_instruction t desc i ~stack_offset :: block.body; + let desc = C.Op (C.Stackoffset bytes) in + C.BasicInstructionList.add_end block.body + (create_instruction t desc i ~stack_offset); let stack_offset = stack_offset + bytes in create_blocks t i.next block ~stack_offset ~traps - | Imove | Ispill | Ireload | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf - | Ifloatofint | Iintoffloat | Ivalueofint | Iintofvalue | Iconst_int _ - | Iconst_float _ | Icompf _ | Iconst_symbol _ | Icall_ind | Icall_imm _ - | Iextcall _ - | Iload (_, _, _) - | Istore (_, _, _) - | Ialloc _ | Iintop _ - | Iintop_imm (_, _) - | Iopaque | Iprobe _ | Iprobe_is_enabled _ | Ispecific _ | Ibeginregion - | Iendregion | Iname_for_debugger _ -> - let desc = to_basic mop in - block.body <- create_instruction t desc i ~stack_offset :: block.body; - if Mach.operation_can_raise mop - then ( - (* Instruction that can raise is always at the end of a block. *) - record_exn t block traps; - let fallthrough = get_or_make_label t i.next in - let desc : Cfg.terminator = Always fallthrough.label in - let i_no_reg = { i with arg = [||]; res = [||]; fdo = Fdo_info.none } in - add_terminator t block i_no_reg desc ~stack_offset ~traps; - create_blocks t fallthrough.insn block ~stack_offset ~traps) - else create_blocks t i.next block ~stack_offset ~traps) + | Ipoll { return_label = None } -> + terminator_fallthrough (fun return_label -> Poll_and_jump return_label) + | Ipoll { return_label = Some return_label } -> + terminator (C.Poll_and_jump return_label) + | Iintop + (( Iadd | Isub | Imul | Imulh _ | Idiv | Imod | Iand | Ior | Ixor | Ilsl + | Ipopcnt | Iclz _ | Ictz _ | Ilsr | Iasr | Icomp _ ) as op) -> + basic (Intop op) + | Iintop_imm + ( (( Iadd | Isub | Imul | Imulh _ | Idiv | Imod | Iand | Ior | Ixor + | Ipopcnt | Iclz _ | Ictz _ | Ilsl | Ilsr | Iasr | Icomp _ ) as op), + i ) -> + basic (Intop_imm (op, i)) + | Iintop_atomic { op; size; addr } -> + basic (Intop_atomic { op; size; addr }) + | Icsel tst -> basic (Csel tst) + | Ivalueofint -> basic Valueofint + | Iintofvalue -> basic Intofvalue + | Iprobe_is_enabled { name } -> basic (Probe_is_enabled { name }) + | Iload (c, a, m) -> basic (Load (c, a, m)) + | Istore (c, a, b) -> basic (Store (c, a, b)) + | Imove -> basic Move + | Ispill -> basic Spill + | Ireload -> basic Reload + | Iconst_int n -> basic (Const_int n) + | Iconst_float n -> basic (Const_float n) + | Iconst_symbol n -> basic (Const_symbol n) + | Inegf -> basic Negf + | Iabsf -> basic Absf + | Iaddf -> basic Addf + | Isubf -> basic Subf + | Imulf -> basic Mulf + | Idivf -> basic Divf + | Icompf c -> basic (Compf c) + | Ifloatofint -> basic Floatofint + | Iintoffloat -> basic Intoffloat + | Iopaque -> basic Opaque + | Ibeginregion -> basic Begin_region + | Iendregion -> basic End_region + | Iname_for_debugger { ident; which_parameter; provenance; is_assignment } + -> + basic + (Name_for_debugger { ident; which_parameter; provenance; is_assignment }) + | Ispecific op -> + if Arch.operation_can_raise op + then + terminator_fallthrough (fun label_after -> + Specific_can_raise { op; label_after }) + else basic (Specific op)) let run (f : Linear.fundecl) ~preserve_orig_labels = let t = diff --git a/backend/cfg/merge_straightline_blocks.ml b/backend/cfg/merge_straightline_blocks.ml index e584307a3a1..f0464b7e974 100644 --- a/backend/cfg/merge_straightline_blocks.ml +++ b/backend/cfg/merge_straightline_blocks.ml @@ -42,17 +42,19 @@ * - its prececessors are set to empty; * - (its other fields are left unchanged). * - * As a consequence, `b2` becomes dead. *) + * As a consequence, `b2` becomes dead and is removed. + * This pass does remove any other dead blocks. + *) (* CR gyorsh: with the new requirement on b1 (that it cannot raise) this pass is even closer to eliminate_fallthrough_blocks. The only difference I think is that b1's body need not be empty here. *) -let rec merge_blocks (modified : bool) (cfg_with_layout : Cfg_with_layout.t) : - bool = +let rec merge_blocks (removed : Label.Set.t) + (cfg_with_layout : Cfg_with_layout.t) : Label.Set.t = let cfg = Cfg_with_layout.cfg cfg_with_layout in - let merged = + let new_removed = Label.Tbl.fold - (fun b1_label (b1_block : Cfg.basic_block) merged -> + (fun b1_label (b1_block : Cfg.basic_block) acc -> let b1_successors = Cfg.successor_labels ~normal:true ~exn:false b1_block in @@ -69,7 +71,8 @@ let rec merge_blocks (modified : bool) (cfg_with_layout : Cfg_with_layout.t) : then ( assert (Label.equal b1_label (List.hd b2_predecessors)); (* modify b1 *) - b1_block.body <- b1_block.body @ b2_block.body; + Cfg.BasicInstructionList.transfer ~to_:b1_block.body + ~from:b2_block.body (); b1_block.terminator <- b2_block.terminator; b1_block.exn <- b2_block.exn; b1_block.can_raise <- b2_block.can_raise; @@ -85,13 +88,15 @@ let rec merge_blocks (modified : bool) (cfg_with_layout : Cfg_with_layout.t) : b2_block.terminator <- { b2_block.terminator with desc = Cfg_intf.S.Never }; b2_block.exn <- None; - true) - else merged - | _ -> merged) - cfg.blocks false + Label.Set.add b2_label acc) + else acc + | _ -> acc) + cfg.blocks Label.Set.empty in - if merged then merge_blocks true cfg_with_layout else modified + if not (Label.Set.is_empty new_removed) + then merge_blocks (Label.Set.union new_removed removed) cfg_with_layout + else removed let run (cfg_with_layout : Cfg_with_layout.t) : unit = - let modified = merge_blocks false cfg_with_layout in - if modified then Eliminate_dead_code.run_dead_block cfg_with_layout + merge_blocks Label.Set.empty cfg_with_layout + |> Cfg_with_layout.remove_blocks cfg_with_layout diff --git a/backend/cfg/simplify_terminator.ml b/backend/cfg/simplify_terminator.ml index 6814b5445bb..cdc527cfdc1 100644 --- a/backend/cfg/simplify_terminator.ml +++ b/backend/cfg/simplify_terminator.ml @@ -98,6 +98,16 @@ let block (block : C.basic_block) = let l = Label.Set.min_elt labels in block.terminator <- { block.terminator with desc = Always l } | Switch labels -> simplify_switch block labels - | Call_no_return _ | Tailcall (Self _ | Func _) | Raise _ | Return -> () + | Raise _ | Return | Tailcall_self _ | Tailcall_func _ | Call_no_return _ + | Poll_and_jump _ + (* CR xclerc: I wonder whether Merge_straightline_block should be updated to + optimize a Poll_and_jump block where block is empty, and has a terminator + such as Always block'. + + (Note that the blocks are currently and correctly not merged because + Poll_and_jump block can raise. The optimization I suggest would be to + rewrite it to Poll_and_jump block'.) *) + | Call _ | Prim _ | Specific_can_raise _ -> + () let run cfg = C.iter_blocks cfg ~f:(fun _ b -> block b) diff --git a/backend/cfg/tests/check_regalloc_validation.ml b/backend/cfg/tests/check_regalloc_validation.ml index 8b8960360a2..be49b0dd87a 100644 --- a/backend/cfg/tests/check_regalloc_validation.ml +++ b/backend/cfg/tests/check_regalloc_validation.ml @@ -63,14 +63,9 @@ module Block = struct | _ -> true) in let terminator = Terminator.make ~remove_locs terminator in - let can_raise = - List.exists - (fun (i : basic instruction) -> Cfg.can_raise_basic i.desc) - body - || Cfg.can_raise_terminator terminator.desc - in + let can_raise = Cfg.can_raise_terminator terminator.desc in { start; - body; + body = Cfg.BasicInstructionList.of_list body; terminator; predecessors = Label.Set.empty; stack_offset = 0; @@ -173,7 +168,7 @@ let () = in Label.Tbl.add cfg.Cfg.blocks (Cfg.entry_label cfg) { start = Cfg.entry_label cfg; - body = []; + body = Cfg.BasicInstructionList.make_empty (); exn = None; can_raise = false; is_trap_handler = false; @@ -288,18 +283,13 @@ let base_templ () : Cfg_desc.t * (unit -> int) = } }; { start = call_label; - body = - [ { id = make_id (); - desc = Call (F Indirect); - arg = arg_locs; - res = tmp_result_locs - } ]; + body = []; exn = None; terminator = { id = make_id (); - desc = Always move_tmp_res_label; - arg = [||]; - res = [||] + desc = Call { op = Indirect; label_after = move_tmp_res_label }; + arg = arg_locs; + res = tmp_result_locs } }; { start = move_tmp_res_label; @@ -440,8 +430,8 @@ let () = cfg, cfg) ~exp_std:"fatal exception raised when creating description" ~exp_err: - ">> Fatal error: Duplicate instruction no. 8 while creating \ - pre-allocation description" + ">> Fatal error: Duplicate instruction no. 8 while adding a basic \ + instruction to the description" let () = check "Duplicate terminator found when creating description" @@ -453,8 +443,8 @@ let () = cfg, cfg) ~exp_std:"fatal exception raised when creating description" ~exp_err: - ">> Fatal error: Duplicate instruction no. 13 while creating \ - pre-allocation description" + ">> Fatal error: Duplicate instruction no. 13 while adding a terminator \ + instruction to the description" let () = check "Regalloc specific instructions are checked when creating description" @@ -463,36 +453,36 @@ let () = let cfg = Cfg_desc.make ~remove_regalloc:false ~remove_locs:true templ in cfg, cfg) ~exp_std:"fatal exception raised when creating description" - ~exp_err:">> Fatal error: instruction 20 is a spill" + ~exp_err:">> Fatal error: instruction 19 is a spill" let () = - check "Instruction argument count" + check "Terminator result count" (fun () -> let templ, make_id = base_templ () in let cfg1 = Cfg_desc.make_pre templ in - templ.&(call_label).!(0).arg <- Array.sub templ.&(call_label).!(0).arg 0 1; + templ.&(call_label).terminator.res <- [||]; let cfg2 = Cfg_desc.make_post templ in cfg1, cfg2) ~exp_std:"fatal exception raised when validating description" ~exp_err: - ">> Fatal error: In instruction's no 14 arguments: register array length \ - has changed. Before: 4. Now: 1." + ">> Fatal error: In instruction's no 13 results: register array length \ + has changed. Before: 1. Now: 0." let () = check "Instruction result count" (fun () -> let templ, make_id = base_templ () in let cfg1 = Cfg_desc.make_pre templ in - templ.&(call_label).!(0).res <- [||]; + templ.&(add_label).!(0).res <- [||]; let cfg2 = Cfg_desc.make_post templ in cfg1, cfg2) ~exp_std:"fatal exception raised when validating description" ~exp_err: - ">> Fatal error: In instruction's no 14 results: register array length \ + ">> Fatal error: In instruction's no 8 results: register array length \ has changed. Before: 1. Now: 0." let () = - check "Terminator arugment count" + check "Terminator argument count" (fun () -> let templ, make_id = base_templ () in let cfg1 = Cfg_desc.make_pre templ in @@ -551,7 +541,7 @@ let () = cfg, cfg) ~exp_std:"fatal exception raised when validating description" ~exp_err: - ">> Fatal error: instruction 21 has a register with an unknown location" + ">> Fatal error: instruction 20 has a register with an unknown location" let () = check "Precoloring can't change" @@ -563,7 +553,7 @@ let () = cfg1, cfg2) ~exp_std:"fatal exception raised when validating description" ~exp_err: - ">> Fatal error: In instruction's no 18 results: changed preassigned \ + ">> Fatal error: In instruction's no 17 results: changed preassigned \ register's location from %rdi to %rbx" let () = @@ -577,8 +567,8 @@ let () = cfg1, cfg2) ~exp_std:"fatal exception raised when validating description" ~exp_err: - ">> Fatal error: Duplicate instruction no. 10 while checking \ - post-allocation description" + ">> Fatal error: Duplicate instruction no. 10 while checking a basic \ + instruction in the new CFG" let () = check "Regalloc changed existing instruction into regalloc instruction" @@ -590,7 +580,7 @@ let () = cfg1, cfg2) ~exp_std:"fatal exception raised when validating description" ~exp_err: - ">> Fatal error: Register allocation changed existing instruction no. 24 \ + ">> Fatal error: Register allocation changed existing instruction no. 23 \ into a register allocation specific instruction" let () = @@ -607,18 +597,18 @@ let () = ~exp_std:"fatal exception raised when validating description" ~exp_err: ">> Fatal error: Register allocation added non-regalloc specific \ - instruction no. 27" + instruction no. 26" let () = - check "Regalloc added a terminator and a block" + check "Regalloc added a 'goto' and a block" (fun () -> let templ, make_id = base_templ () in - (* The spill has the same id as another instruction. *) let cfg1 = Cfg_desc.make_pre templ in + let tmp_label = new_label 1 in let templ = { templ with blocks = - { start = new_label 1; + { start = tmp_label; exn = None; body = []; terminator = @@ -631,12 +621,131 @@ let () = :: templ.blocks } in + templ.&(add_label).terminator.desc <- Always tmp_label; + let cfg2 = Cfg_desc.make_post templ in + cfg1, cfg2) + ~exp_std:"" ~exp_err:"" + +let () = + check "Regalloc added a fallthrough block that goes to the wrong label" + (fun () -> + let templ, make_id = base_templ () in + let cfg1 = Cfg_desc.make_pre templ in + let tmp_label = new_label 1 in + let templ = + { templ with + blocks = + { start = tmp_label; + exn = None; + body = []; + terminator = + { desc = Always call_label; + res = [||]; + arg = [||]; + id = make_id () + } + } + :: templ.blocks + } + in + templ.&(add_label).terminator.desc <- Always tmp_label; let cfg2 = Cfg_desc.make_post templ in cfg1, cfg2) ~exp_std:"fatal exception raised when validating description" ~exp_err: - ">> Fatal error: Register allocation added non-regalloc specific \ - instruction no. 27" + ">> Fatal error: When checking equivalence of labels before and after \ + allocation got different successor id's. Successor (label, instr id) \ + before: (6, 6). Successor (label, instr id) after: (8, 13)." + +let () = + check "Regalloc added a not allowed terminator and a block" + (fun () -> + let templ, make_id = base_templ () in + let cfg1 = Cfg_desc.make_pre templ in + let tmp_label = new_label 1 in + let templ = + { templ with + blocks = + { start = tmp_label; + exn = None; + body = []; + terminator = + { desc = Return; res = [||]; arg = [||]; id = make_id () } + } + :: templ.blocks + } + in + templ.&(add_label).terminator.desc <- Always tmp_label; + let cfg2 = Cfg_desc.make_post templ in + cfg1, cfg2) + ~exp_std:"fatal exception raised when validating description" + ~exp_err: + ">> Fatal error: Register allocation added a terminator no. 26 but \ + that's not allowed for this type of terminator: Return" + +let () = + check "Regalloc reordered instructions between blocks" + (fun () -> + let templ, make_id = base_templ () in + let cfg1 = Cfg_desc.make_pre templ in + let add_body = templ.&(add_label).body in + templ.&(add_label).body <- []; + templ.&(return_label).body <- add_body @ templ.&(return_label).body; + let cfg2 = Cfg_desc.make_post templ in + cfg1, cfg2) + ~exp_std:"fatal exception raised when validating description" + ~exp_err: + ">> Fatal error: The instruction's no. 8 successor id has changed. \ + Before allocation: 7. After allocation (ignoring instructions added by \ + allocation): 6." + +let () = + check "Regalloc reordered instructions within a block" + (fun () -> + let templ, make_id = base_templ () in + let cfg1 = Cfg_desc.make_pre templ in + let block = templ.&(move_tmp_res_label) in + block.body + <- (block.body |> List.rev |> function + | i1 :: i2 :: t -> i2 :: i1 :: t + | l -> l |> List.rev); + let cfg2 = Cfg_desc.make_post templ in + cfg1, cfg2) + ~exp_std:"fatal exception raised when validating description" + ~exp_err: + ">> Fatal error: The instruction's no. 12 successor id has changed. \ + Before allocation: 11. After allocation (ignoring instructions added by \ + allocation): 9." + +let () = + check "Regalloc added a loop" + (fun () -> + let templ, make_id = base_templ () in + let cfg1 = Cfg_desc.make_pre templ in + let tmp_label = new_label 1 in + let templ = + { templ with + blocks = + { start = tmp_label; + exn = None; + body = []; + terminator = + { desc = Always tmp_label; + res = [||]; + arg = [||]; + id = make_id () + } + } + :: templ.blocks + } + in + let cfg2 = Cfg_desc.make_post templ in + cfg1, cfg2) + ~exp_std:"fatal exception raised when validating description" + ~exp_err: + ">> Fatal error: Visiting the same block 8 without knowing the successor \ + instruction's id. That means there's a loop consisting of only \ + instructions added by the register allocator." let () = check "Regalloc changed instruction desc" @@ -658,7 +767,9 @@ let () = let cfg2 = Cfg_desc.make_post templ in cfg1, cfg2) ~exp_std:"fatal exception raised when validating description" - ~exp_err:">> Fatal error: The desc of instruction with id 3 changed" + ~exp_err: + ">> Fatal error: The desc of terminator with id 3 changed, before: \ + Return, after: Raise." let () = check "Deleted instruction" diff --git a/backend/checkmach.ml b/backend/checkmach.ml index 6f6c0b80b47..feb622da286 100644 --- a/backend/checkmach.ml +++ b/backend/checkmach.ml @@ -325,16 +325,21 @@ end = struct | Iintop ( Iadd | Isub | Imul | Imulh _ | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Ipopcnt | Iclz _ | Ictz _ | Icomp _ ) - | Iname_for_debugger _ -> + | Icsel _ | Iname_for_debugger _ -> assert (Mach.operation_is_pure op) | Istackoffset _ | Iprobe_is_enabled _ | Iopaque | Ibeginregion | Iendregion - -> + | Iintop_atomic _ -> () | Istore _ -> () | Iintop Icheckbound | Iintop_imm (Icheckbound, _) -> report_fail t "checkbound" dbg | Ialloc { mode = Alloc_local; _ } -> () | Ialloc { mode = Alloc_heap; _ } -> report_fail t "allocation" dbg + | Ipoll _ -> + (* Polling points may trigger finalisers, signal handlers or memprof + callbacks, but any allocations done therein don't count towards the + calling function being "allocating". *) + () | Iprobe { name; handler_code_sym } -> let desc = Printf.sprintf "probe %s handler %s" name handler_code_sym in check_call t handler_code_sym ~desc dbg diff --git a/backend/cmm.ml b/backend/cmm.ml index 81882152e03..1fa1bb97207 100644 --- a/backend/cmm.ml +++ b/backend/cmm.ml @@ -132,6 +132,10 @@ type rec_flag = Nonrecursive | Recursive type prefetch_temporal_locality_hint = Nonlocal | Low | Moderate | High +type atomic_op = Fetch_and_add | Compare_and_swap + +type atomic_bitwidth = Thirtytwo | Sixtyfour | Word + type effects = No_effects | Arbitrary_effects type coeffects = No_coeffects | Has_coeffects @@ -190,10 +194,12 @@ and operation = | Caddi | Csubi | Cmuli | Cmulhi of { signed: bool } | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr | Cbswap of { bitwidth: bswap_bitwidth; } + | Ccsel of machtype | Cclz of { arg_is_non_zero: bool; } | Cctz of { arg_is_non_zero: bool; } | Cpopcnt | Cprefetch of { is_write: bool; locality: prefetch_temporal_locality_hint; } + | Catomic of { op: atomic_op; size : atomic_bitwidth } | Ccmpi of integer_comparison | Caddv | Cadda | Ccmpa of integer_comparison @@ -260,6 +266,7 @@ type fundecl = fun_args: (Backend_var.With_provenance.t * machtype) list; fun_body: expression; fun_codegen_options : codegen_option list; + fun_poll: Lambda.poll_attribute; fun_dbg : Debuginfo.t; } diff --git a/backend/cmm.mli b/backend/cmm.mli index 1ca31d9e7de..028c0df8f22 100644 --- a/backend/cmm.mli +++ b/backend/cmm.mli @@ -104,6 +104,10 @@ type rec_flag = Nonrecursive | Recursive type prefetch_temporal_locality_hint = Nonlocal | Low | Moderate | High +type atomic_op = Fetch_and_add | Compare_and_swap + +type atomic_bitwidth = Thirtytwo | Sixtyfour | Word + type effects = No_effects | Arbitrary_effects type coeffects = No_coeffects | Has_coeffects @@ -191,10 +195,12 @@ and operation = | Caddi | Csubi | Cmuli | Cmulhi of { signed: bool } | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr | Cbswap of { bitwidth: bswap_bitwidth; } + | Ccsel of machtype | Cclz of { arg_is_non_zero: bool; } | Cctz of { arg_is_non_zero: bool; } | Cpopcnt | Cprefetch of { is_write: bool; locality: prefetch_temporal_locality_hint; } + | Catomic of { op: atomic_op; size : atomic_bitwidth } | Ccmpi of integer_comparison | Caddv (* pointer addition that produces a [Val] (well-formed Caml value) *) | Cadda (* pointer addition that produces a [Addr] (derived heap pointer) *) @@ -251,6 +257,8 @@ type expression = | Cexit of exit_label * expression list * trap_action list | Ctrywith of expression * trywith_kind * Backend_var.With_provenance.t * expression * Debuginfo.t * value_kind + (** Only if the [trywith_kind] is [Regular] will a region be inserted for + the "try" block. *) | Cregion of expression | Ctail of expression @@ -269,6 +277,7 @@ type fundecl = fun_args: (Backend_var.With_provenance.t * machtype) list; fun_body: expression; fun_codegen_options : codegen_option list; + fun_poll: Lambda.poll_attribute; fun_dbg : Debuginfo.t; } diff --git a/backend/cmm_builtins.ml b/backend/cmm_builtins.ml new file mode 100644 index 00000000000..925476eee9f --- /dev/null +++ b/backend/cmm_builtins.ml @@ -0,0 +1,581 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Cmm +open Cmm_helpers +open Arch + +let four_args name args = + match args with + | [arg1; arg2; arg3; arg4] -> arg1, arg2, arg3, arg4 + | _ -> + Misc.fatal_errorf "Cmm_builtins: expected exactly 4 arguments for %s" name + +let three_args name args = + match args with + | [arg1; arg2; arg3] -> arg1, arg2, arg3 + | _ -> + Misc.fatal_errorf "Cmm_builtins: expected exactly 3 arguments for %s" name + +let two_args name args = + match args with + | [arg1; arg2] -> arg1, arg2 + | _ -> + Misc.fatal_errorf "Cmm_builtins: expected exactly 2 arguments for %s" name + +let one_arg name args = + match args with + | [arg] -> arg + | _ -> + Misc.fatal_errorf "Cmm_builtins: expected exactly 1 argument for %s" name + +let if_operation_supported op ~f = + match Proc.operation_supported op with true -> Some (f ()) | false -> None + +let if_operation_supported_bi bi op ~f = + if bi = Primitive.Pint64 && size_int = 4 + then None + else if_operation_supported op ~f + +let int_of_value arg dbg = Cop (Cintofvalue, [arg], dbg) + +let value_of_int arg dbg = Cop (Cvalueofint, [arg], dbg) + +(* Untagging of a negative value shifts in an extra bit. The following code + clears the shifted sign bit of an untagged int. This straightline code is + faster on most targets than conditional code for checking whether the + argument is negative. *) +let clear_sign_bit arg dbg = + let mask = Nativeint.lognot (Nativeint.shift_left 1n ((size_int * 8) - 1)) in + Cop (Cand, [arg; Cconst_natint (mask, dbg)], dbg) + +let clz ~arg_is_non_zero bi arg dbg = + let op = Cclz { arg_is_non_zero } in + if_operation_supported_bi bi op ~f:(fun () -> + let res = Cop (op, [make_unsigned_int bi arg dbg], dbg) in + if bi = Primitive.Pint32 && size_int = 8 + then Cop (Caddi, [res; Cconst_int (-32, dbg)], dbg) + else res) + +let ctz ~arg_is_non_zero bi arg dbg = + let arg = make_unsigned_int bi arg dbg in + if bi = Primitive.Pint32 && size_int = 8 + then + (* regardless of the value of the argument [arg_is_non_zero], always set the + corresponding field to [true], because we make it non-zero below by + setting bit 32. *) + let op = Cctz { arg_is_non_zero = true } in + if_operation_supported_bi bi op ~f:(fun () -> + (* Set bit 32 *) + let mask = Nativeint.shift_left 1n 32 in + Cop (op, [Cop (Cor, [arg; Cconst_natint (mask, dbg)], dbg)], dbg)) + else + let op = Cctz { arg_is_non_zero } in + if_operation_supported_bi bi op ~f:(fun () -> Cop (op, [arg], dbg)) + +let popcnt bi arg dbg = + if_operation_supported_bi bi Cpopcnt ~f:(fun () -> + Cop (Cpopcnt, [make_unsigned_int bi arg dbg], dbg)) + +let mulhi bi ~signed args dbg = + let op = Cmulhi { signed } in + if_operation_supported_bi bi op ~f:(fun () -> Cop (op, args, dbg)) + +let ext_pointer_load chunk name args dbg = + let p = int_as_pointer (one_arg name args) dbg in + Some (Cop (Cload (chunk, Mutable), [p], dbg)) + +let ext_pointer_store chunk name args dbg = + let arg1, arg2 = two_args name args in + let p = int_as_pointer arg1 dbg in + Some (return_unit dbg (Cop (Cstore (chunk, Assignment), [p; arg2], dbg))) + +let bigstring_prefetch ~is_write locality args dbg = + let op = Cprefetch { is_write; locality } in + if_operation_supported op ~f:(fun () -> + let arg1, arg2 = two_args "bigstring_prefetch" args in + (* [arg2], the index, is already untagged. *) + bind "index" arg2 (fun idx -> + bind "ba" arg1 (fun ba -> + bind "ba_data" + (Cop (Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg)) + (fun ba_data -> + (* pointer to element "idx" of "ba" of type (char, + int8_unsigned_elt, c_layout) Bigarray.Array1.t is simply + offset "idx" from "ba_data" *) + return_unit dbg (Cop (op, [add_int ba_data idx dbg], dbg)))))) + +let prefetch ~is_write locality arg dbg = + let op = Cprefetch { is_write; locality } in + if_operation_supported op ~f:(fun () -> + return_unit dbg (Cop (op, [arg], dbg))) + +let prefetch_offset ~is_write locality (arg1, arg2) dbg = + (* [arg2], the index, is already untagged. *) + let op = Cprefetch { is_write; locality } in + if_operation_supported op ~f:(fun () -> + return_unit dbg (Cop (op, [add_int arg1 arg2 dbg], dbg))) + +let ext_pointer_prefetch ~is_write locality arg dbg = + prefetch ~is_write locality (int_as_pointer arg dbg) dbg + +let native_pointer_cas size (arg1, arg2, arg3) dbg = + let op = Catomic { op = Compare_and_swap; size } in + if_operation_supported op ~f:(fun () -> + bind "set_to" arg3 (fun set_to -> + bind "compare_with" arg2 (fun compare_with -> + bind "dst" arg1 (fun dst -> + tag_int (Cop (op, [compare_with; set_to; dst], dbg)) dbg)))) + +let ext_pointer_cas size (arg1, arg2, arg3) dbg = + native_pointer_cas size (int_as_pointer arg1 dbg, arg2, arg3) dbg + +let bigstring_cas size (arg1, arg2, arg3, arg4) dbg = + let op = Catomic { op = Compare_and_swap; size } in + if_operation_supported op ~f:(fun () -> + bind "set_to" arg4 (fun set_to -> + bind "compare_with" arg3 (fun compare_with -> + bind "idx" arg2 (fun idx -> + bind "bs" arg1 (fun bs -> + bind "bs_data" + (Cop + ( Cload (Word_int, Mutable), + [field_address bs 1 dbg], + dbg )) + (fun bs_data -> + bind "dst" (add_int bs_data idx dbg) (fun dst -> + tag_int + (Cop (op, [compare_with; set_to; dst], dbg)) + dbg))))))) + +let native_pointer_atomic_add size (arg1, arg2) dbg = + let op = Catomic { op = Fetch_and_add; size } in + if_operation_supported op ~f:(fun () -> + bind "src" arg2 (fun src -> + bind "dst" arg1 (fun dst -> Cop (op, [src; dst], dbg)))) + +let native_pointer_atomic_sub size (arg1, arg2) dbg = + native_pointer_atomic_add size (arg1, neg_int arg2 dbg) dbg + +let ext_pointer_atomic_add size (arg1, arg2) dbg = + native_pointer_atomic_add size (int_as_pointer arg1 dbg, arg2) dbg + +let ext_pointer_atomic_sub size (arg1, arg2) dbg = + native_pointer_atomic_add size (int_as_pointer arg1 dbg, neg_int arg2 dbg) dbg + +let bigstring_atomic_add size (arg1, arg2, arg3) dbg = + let op = Catomic { op = Fetch_and_add; size } in + if_operation_supported op ~f:(fun () -> + bind "src" arg3 (fun src -> + bind "idx" arg2 (fun idx -> + bind "bs" arg1 (fun bs -> + bind "bs_data" + (Cop + (Cload (Word_int, Mutable), [field_address bs 1 dbg], dbg)) + (fun bs_data -> + bind "dst" (add_int bs_data idx dbg) (fun dst -> + Cop (op, [src; dst], dbg))))))) + +let bigstring_atomic_sub size (arg1, arg2, arg3) dbg = + bigstring_atomic_add size (arg1, arg2, neg_int arg3 dbg) dbg + +(** [transl_builtin prim args dbg] returns None if the built-in [prim] is not + supported, otherwise it constructs and returns the corresponding Cmm + expression. + + The names of builtins below correspond to the native code names associated + with "external" declarations in the stand-alone library [ocaml_intrinsics]. + + For situations such as where the Cmm code below returns e.g. an untagged + integer, we exploit the generic mechanism on "external" to deal with the + tagging before the result is returned to the user. *) +let transl_builtin name args dbg typ_res = + match name with + | "caml_int_clz_tagged_to_untagged" -> + (* The tag does not change the number of leading zeros. The advantage of + keeping the tag is it guarantees that, on x86-64, the input to the BSR + instruction is nonzero. *) + let op = Cclz { arg_is_non_zero = true } in + if_operation_supported op ~f:(fun () -> Cop (op, args, dbg)) + | "caml_int_clz_untagged_to_untagged" -> + let op = Cclz { arg_is_non_zero = false } in + if_operation_supported op ~f:(fun () -> + let arg = clear_sign_bit (one_arg name args) dbg in + Cop (Caddi, [Cop (op, [arg], dbg); Cconst_int (-1, dbg)], dbg)) + | "caml_int64_clz_unboxed_to_untagged" -> + clz ~arg_is_non_zero:false Pint64 (one_arg name args) dbg + | "caml_int32_clz_unboxed_to_untagged" -> + clz ~arg_is_non_zero:false Pint32 (one_arg name args) dbg + | "caml_nativeint_clz_unboxed_to_untagged" -> + clz ~arg_is_non_zero:false Pnativeint (one_arg name args) dbg + | "caml_int64_clz_nonzero_unboxed_to_untagged" -> + clz ~arg_is_non_zero:true Pint64 (one_arg name args) dbg + | "caml_int32_clz_nonzero_unboxed_to_untagged" -> + clz ~arg_is_non_zero:true Pint32 (one_arg name args) dbg + | "caml_nativeint_clz_nonzero_unboxed_to_untagged" -> + clz ~arg_is_non_zero:true Pnativeint (one_arg name args) dbg + | "caml_int_popcnt_tagged_to_untagged" -> + if_operation_supported Cpopcnt ~f:(fun () -> + (* Having the argument tagged saves a shift, but there is one extra + "set" bit, which is accounted for by the (-1) below. *) + Cop (Caddi, [Cop (Cpopcnt, args, dbg); Cconst_int (-1, dbg)], dbg)) + | "caml_int_popcnt_untagged_to_untagged" -> + (* This code is expected to be faster than [popcnt(tagged_x) - 1] when the + untagged argument is already available from a previous computation. *) + if_operation_supported Cpopcnt ~f:(fun () -> + let arg = clear_sign_bit (one_arg name args) dbg in + Cop (Cpopcnt, [arg], dbg)) + | "caml_int64_popcnt_unboxed_to_untagged" -> + popcnt Pint64 (one_arg name args) dbg + | "caml_int32_popcnt_unboxed_to_untagged" -> + popcnt Pint32 (one_arg name args) dbg + | "caml_nativeint_popcnt_unboxed_to_untagged" -> + popcnt Pnativeint (one_arg name args) dbg + | "caml_int_ctz_untagged_to_untagged" -> + (* Assuming a 64-bit x86-64 target: + + Setting the top bit of the input for the BSF instruction ensures the + input is nonzero without affecting the result. + + The expression [x lor (1 lsl 63)] sets the top bit of x. The constant: + + [1 lsl 63] + + can be precomputed statically: + + Cconst_natint ((Nativeint.shift_left 1n 63), dbg) + + However, the encoding of this OR instruction with the large static + constant is 10 bytes long, on x86-64. Instead, we emit a shift operation, + whose corresponding instruction is 1 byte shorter. This will not require + an extra register, unless both the argument and result of the BSF + instruction are in the same register. *) + let op = Cctz { arg_is_non_zero = true } in + if_operation_supported op ~f:(fun () -> + let c = + Cop + ( Clsl, + [Cconst_int (1, dbg); Cconst_int ((size_int * 8) - 1, dbg)], + dbg ) + in + Cop (op, [Cop (Cor, [one_arg name args; c], dbg)], dbg)) + | "caml_int32_ctz_unboxed_to_untagged" -> + ctz ~arg_is_non_zero:false Pint32 (one_arg name args) dbg + | "caml_int64_ctz_unboxed_to_untagged" -> + ctz ~arg_is_non_zero:false Pint64 (one_arg name args) dbg + | "caml_nativeint_ctz_unboxed_to_untagged" -> + ctz ~arg_is_non_zero:false Pnativeint (one_arg name args) dbg + | "caml_int32_ctz_nonzero_unboxed_to_untagged" -> + ctz ~arg_is_non_zero:true Pint32 (one_arg name args) dbg + | "caml_int64_ctz_nonzero_unboxed_to_untagged" -> + ctz ~arg_is_non_zero:true Pint64 (one_arg name args) dbg + | "caml_nativeint_ctz_nonzero_unboxed_to_untagged" -> + ctz ~arg_is_non_zero:true Pnativeint (one_arg name args) dbg + | "caml_signed_int64_mulh_unboxed" -> mulhi ~signed:true Pint64 args dbg + | "caml_unsigned_int64_mulh_unboxed" -> mulhi ~signed:false Pint64 args dbg + | "caml_int32_unsigned_to_int_trunc_unboxed_to_untagged" -> + Some (zero_extend_32 dbg (one_arg name args)) + | "caml_csel_value" | "caml_csel_int_untagged" | "caml_csel_int64_unboxed" + | "caml_csel_int32_unboxed" | "caml_csel_nativeint_unboxed" -> + (* Unboxed float variant of csel intrinsic is not currently supported. It + can be emitted on arm64 using FCSEL, but there appears to be no + corresponding instruction on amd64 for xmm registers. *) + let op = Ccsel typ_res in + let cond, ifso, ifnot = three_args name args in + if_operation_supported op ~f:(fun () -> + Cop (op, [test_bool dbg cond; ifso; ifnot], dbg)) + (* Native_pointer: handled as unboxed nativeint *) + | "caml_ext_pointer_as_native_pointer" -> + Some (int_as_pointer (one_arg name args) dbg) + | "caml_native_pointer_of_value" -> + Some (int_of_value (one_arg name args) dbg) + | "caml_native_pointer_to_value" -> + Some (value_of_int (one_arg name args) dbg) + | "caml_native_pointer_load_immediate" + | "caml_native_pointer_load_unboxed_nativeint" -> + Some (Cop (Cload (Word_int, Mutable), args, dbg)) + | "caml_native_pointer_store_immediate" + | "caml_native_pointer_store_unboxed_nativeint" -> + Some (return_unit dbg (Cop (Cstore (Word_int, Assignment), args, dbg))) + | "caml_native_pointer_load_unboxed_int64" when size_int = 8 -> + Some (Cop (Cload (Word_int, Mutable), args, dbg)) + | "caml_native_pointer_store_unboxed_int64" when size_int = 8 -> + Some (return_unit dbg (Cop (Cstore (Word_int, Assignment), args, dbg))) + | "caml_native_pointer_load_signed_int32" + | "caml_native_pointer_load_unboxed_int32" -> + Some (Cop (Cload (Thirtytwo_signed, Mutable), args, dbg)) + | "caml_native_pointer_store_signed_int32" + | "caml_native_pointer_store_unboxed_int32" -> + Some + (return_unit dbg (Cop (Cstore (Thirtytwo_signed, Assignment), args, dbg))) + | "caml_native_pointer_load_unsigned_int32" -> + Some (Cop (Cload (Thirtytwo_unsigned, Mutable), args, dbg)) + | "caml_native_pointer_store_unsigned_int32" -> + Some + (return_unit dbg + (Cop (Cstore (Thirtytwo_unsigned, Assignment), args, dbg))) + | "caml_native_pointer_load_unboxed_float" -> + Some (Cop (Cload (Double, Mutable), args, dbg)) + | "caml_native_pointer_store_unboxed_float" -> + Some (return_unit dbg (Cop (Cstore (Double, Assignment), args, dbg))) + | "caml_native_pointer_load_unsigned_int8" -> + Some (Cop (Cload (Byte_unsigned, Mutable), args, dbg)) + | "caml_native_pointer_load_signed_int8" -> + Some (Cop (Cload (Byte_signed, Mutable), args, dbg)) + | "caml_native_pointer_load_unsigned_int16" -> + Some (Cop (Cload (Sixteen_unsigned, Mutable), args, dbg)) + | "caml_native_pointer_load_signed_int16" -> + Some (Cop (Cload (Sixteen_signed, Mutable), args, dbg)) + | "caml_native_pointer_store_unsigned_int8" -> + Some (return_unit dbg (Cop (Cstore (Byte_unsigned, Assignment), args, dbg))) + | "caml_native_pointer_store_signed_int8" -> + Some (return_unit dbg (Cop (Cstore (Byte_signed, Assignment), args, dbg))) + | "caml_native_pointer_store_unsigned_int16" -> + Some + (return_unit dbg (Cop (Cstore (Sixteen_unsigned, Assignment), args, dbg))) + | "caml_native_pointer_store_signed_int16" -> + Some + (return_unit dbg (Cop (Cstore (Sixteen_signed, Assignment), args, dbg))) + (* Ext_pointer: handled as tagged int *) + | "caml_ext_pointer_load_immediate" + | "caml_ext_pointer_load_unboxed_nativeint" -> + ext_pointer_load Word_int name args dbg + | "caml_ext_pointer_store_immediate" + | "caml_ext_pointer_store_unboxed_nativeint" -> + ext_pointer_store Word_int name args dbg + | "caml_ext_pointer_load_unboxed_int64" when size_int = 8 -> + ext_pointer_load Word_int name args dbg + | "caml_ext_pointer_store_unboxed_int64" when size_int = 8 -> + ext_pointer_store Word_int name args dbg + | "caml_ext_pointer_load_signed_int32" | "caml_ext_pointer_load_unboxed_int32" + -> + ext_pointer_load Thirtytwo_signed name args dbg + | "caml_ext_pointer_store_signed_int32" + | "caml_ext_pointer_store_unboxed_int32" -> + ext_pointer_store Thirtytwo_signed name args dbg + | "caml_ext_pointer_load_unsigned_int32" -> + ext_pointer_load Thirtytwo_unsigned name args dbg + | "caml_ext_pointer_store_unsigned_int32" -> + ext_pointer_store Thirtytwo_unsigned name args dbg + | "caml_ext_pointer_load_unboxed_float" -> + ext_pointer_load Double name args dbg + | "caml_ext_pointer_store_unboxed_float" -> + ext_pointer_store Double name args dbg + | "caml_ext_pointer_load_unsigned_int8" -> + ext_pointer_load Byte_unsigned name args dbg + | "caml_ext_pointer_load_signed_int8" -> + ext_pointer_load Byte_signed name args dbg + | "caml_ext_pointer_load_unsigned_int16" -> + ext_pointer_load Sixteen_unsigned name args dbg + | "caml_ext_pointer_load_signed_int16" -> + ext_pointer_load Sixteen_signed name args dbg + | "caml_ext_pointer_store_unsigned_int8" -> + ext_pointer_store Byte_unsigned name args dbg + | "caml_ext_pointer_store_signed_int8" -> + ext_pointer_store Byte_signed name args dbg + | "caml_ext_pointer_store_unsigned_int16" -> + ext_pointer_store Sixteen_unsigned name args dbg + | "caml_ext_pointer_store_signed_int16" -> + ext_pointer_store Sixteen_signed name args dbg + (* Bigstring prefetch *) + | "caml_prefetch_write_high_bigstring_untagged" -> + bigstring_prefetch ~is_write:true High args dbg + | "caml_prefetch_write_moderate_bigstring_untagged" -> + bigstring_prefetch ~is_write:true Moderate args dbg + | "caml_prefetch_write_low_bigstring_untagged" -> + bigstring_prefetch ~is_write:true Low args dbg + | "caml_prefetch_write_none_bigstring_untagged" -> + bigstring_prefetch ~is_write:true Nonlocal args dbg + | "caml_prefetch_read_none_bigstring_untagged" -> + bigstring_prefetch ~is_write:false Nonlocal args dbg + | "caml_prefetch_read_high_bigstring_untagged" -> + bigstring_prefetch ~is_write:false High args dbg + | "caml_prefetch_read_moderate_bigstring_untagged" -> + bigstring_prefetch ~is_write:false Moderate args dbg + | "caml_prefetch_read_low_bigstring_untagged" -> + bigstring_prefetch ~is_write:false Low args dbg + (* Ext_pointer prefetch *) + | "caml_prefetch_write_high_ext_pointer" -> + ext_pointer_prefetch ~is_write:true High (one_arg name args) dbg + | "caml_prefetch_write_moderate_ext_pointer" -> + ext_pointer_prefetch ~is_write:true Moderate (one_arg name args) dbg + | "caml_prefetch_write_low_ext_pointer" -> + ext_pointer_prefetch ~is_write:true Low (one_arg name args) dbg + | "caml_prefetch_write_none_ext_pointer" -> + ext_pointer_prefetch ~is_write:true Nonlocal (one_arg name args) dbg + | "caml_prefetch_read_none_ext_pointer" -> + ext_pointer_prefetch ~is_write:false Nonlocal (one_arg name args) dbg + | "caml_prefetch_read_high_ext_pointer" -> + ext_pointer_prefetch ~is_write:false High (one_arg name args) dbg + | "caml_prefetch_read_moderate_ext_pointer" -> + ext_pointer_prefetch ~is_write:false Moderate (one_arg name args) dbg + | "caml_prefetch_read_low_ext_pointer" -> + ext_pointer_prefetch ~is_write:false Low (one_arg name args) dbg + (* Value and unboxed Native_pointer prefetch *) + | "caml_prefetch_write_high" -> + prefetch ~is_write:true High (one_arg name args) dbg + | "caml_prefetch_write_moderate" -> + prefetch ~is_write:true Moderate (one_arg name args) dbg + | "caml_prefetch_write_low" -> + prefetch ~is_write:true Low (one_arg name args) dbg + | "caml_prefetch_write_none" -> + prefetch ~is_write:true Nonlocal (one_arg name args) dbg + | "caml_prefetch_read_none" -> + prefetch ~is_write:false Nonlocal (one_arg name args) dbg + | "caml_prefetch_read_high" -> + prefetch ~is_write:false High (one_arg name args) dbg + | "caml_prefetch_read_moderate" -> + prefetch ~is_write:false Moderate (one_arg name args) dbg + | "caml_prefetch_read_low" -> + prefetch ~is_write:false Low (one_arg name args) dbg + (* Prefetch value with offset *) + | "caml_prefetch_write_high_val_offset_untagged" -> + prefetch_offset ~is_write:true High (two_args name args) dbg + | "caml_prefetch_write_moderate_val_offset_untagged" -> + prefetch_offset ~is_write:true Moderate (two_args name args) dbg + | "caml_prefetch_write_low_val_offset_untagged" -> + prefetch_offset ~is_write:true Low (two_args name args) dbg + | "caml_prefetch_write_none_val_offset_untagged" -> + prefetch_offset ~is_write:true Nonlocal (two_args name args) dbg + | "caml_prefetch_read_none_val_offset_untagged" -> + prefetch_offset ~is_write:false Nonlocal (two_args name args) dbg + | "caml_prefetch_read_high_val_offset_untagged" -> + prefetch_offset ~is_write:false High (two_args name args) dbg + | "caml_prefetch_read_moderate_val_offset_untagged" -> + prefetch_offset ~is_write:false Moderate (two_args name args) dbg + | "caml_prefetch_read_low_val_offset_untagged" -> + prefetch_offset ~is_write:false Low (two_args name args) dbg + (* Atomics *) + | "caml_native_pointer_fetch_and_add_nativeint_unboxed" + | "caml_native_pointer_fetch_and_add_int_untagged" -> + native_pointer_atomic_add Word (two_args name args) dbg + | "caml_native_pointer_fetch_and_add_int64_unboxed" when size_int = 8 -> + native_pointer_atomic_add Sixtyfour (two_args name args) dbg + | "caml_native_pointer_fetch_and_add_int32_unboxed" -> + native_pointer_atomic_add Thirtytwo (two_args name args) dbg + | "caml_ext_pointer_fetch_and_add_nativeint_unboxed" + | "caml_ext_pointer_fetch_and_add_int_untagged" -> + ext_pointer_atomic_add Word (two_args name args) dbg + | "caml_ext_pointer_fetch_and_add_int64_unboxed" when size_int = 8 -> + ext_pointer_atomic_add Sixtyfour (two_args name args) dbg + | "caml_ext_pointer_fetch_and_add_int32_unboxed" -> + ext_pointer_atomic_add Thirtytwo (two_args name args) dbg + | "caml_bigstring_fetch_and_add_nativeint_unboxed" + | "caml_bigstring_fetch_and_add_int_untagged" -> + bigstring_atomic_add Word (three_args name args) dbg + | "caml_bigstring_fetch_and_add_int64_unboxed" when size_int = 8 -> + bigstring_atomic_add Sixtyfour (three_args name args) dbg + | "caml_bigstring_fetch_and_add_int32_unboxed" -> + bigstring_atomic_add Thirtytwo (three_args name args) dbg + | "caml_native_pointer_fetch_and_sub_nativeint_unboxed" + | "caml_native_pointer_fetch_and_sub_int_untagged" -> + native_pointer_atomic_sub Word (two_args name args) dbg + | "caml_native_pointer_fetch_and_sub_int64_unboxed" when size_int = 8 -> + native_pointer_atomic_sub Sixtyfour (two_args name args) dbg + | "caml_native_pointer_fetch_and_sub_int32_unboxed" -> + native_pointer_atomic_sub Thirtytwo (two_args name args) dbg + | "caml_ext_pointer_fetch_and_sub_nativeint_unboxed" + | "caml_ext_pointer_fetch_and_sub_int_untagged" -> + ext_pointer_atomic_sub Word (two_args name args) dbg + | "caml_ext_pointer_fetch_and_sub_int64_unboxed" when size_int = 8 -> + ext_pointer_atomic_sub Sixtyfour (two_args name args) dbg + | "caml_ext_pointer_fetch_and_sub_int32_unboxed" -> + ext_pointer_atomic_sub Thirtytwo (two_args name args) dbg + | "caml_bigstring_fetch_and_sub_nativeint_unboxed" + | "caml_bigstring_fetch_and_sub_int_untagged" -> + bigstring_atomic_sub Word (three_args name args) dbg + | "caml_bigstring_fetch_and_sub_int64_unboxed" when size_int = 8 -> + bigstring_atomic_sub Sixtyfour (three_args name args) dbg + | "caml_bigstring_fetch_and_sub_int32_unboxed" -> + bigstring_atomic_sub Thirtytwo (three_args name args) dbg + | "caml_native_pointer_compare_and_swap_int_untagged" + | "caml_native_pointer_compare_and_swap_nativeint_unboxed" -> + native_pointer_cas Word (three_args name args) dbg + | "caml_native_pointer_compare_and_swap_int64_unboxed" when size_int = 8 -> + native_pointer_cas Sixtyfour (three_args name args) dbg + | "caml_native_pointer_compare_and_swap_int32_unboxed" -> + native_pointer_cas Thirtytwo (three_args name args) dbg + | "caml_ext_pointer_compare_and_swap_int_untagged" + | "caml_ext_pointer_compare_and_swap_nativeint_unboxed" -> + ext_pointer_cas Word (three_args name args) dbg + | "caml_ext_pointer_compare_and_swap_int64_unboxed" when size_int = 8 -> + ext_pointer_cas Sixtyfour (three_args name args) dbg + | "caml_ext_pointer_compare_and_swap_int32_unboxed" -> + ext_pointer_cas Thirtytwo (three_args name args) dbg + | "caml_bigstring_compare_and_swap_int_untagged" + | "caml_bigstring_compare_and_swap_nativeint_unboxed" -> + bigstring_cas Word (four_args name args) dbg + | "caml_bigstring_compare_and_swap_int64_unboxed" when size_int = 8 -> + bigstring_cas Sixtyfour (four_args name args) dbg + | "caml_bigstring_compare_and_swap_int32_unboxed" -> + bigstring_cas Thirtytwo (four_args name args) dbg + | _ -> None + +let transl_effects (e : Primitive.effects) : Cmm.effects = + match e with + | No_effects -> No_effects + | Only_generative_effects | Arbitrary_effects -> Arbitrary_effects + +let transl_coeffects (ce : Primitive.coeffects) : Cmm.coeffects = + match ce with No_coeffects -> No_coeffects | Has_coeffects -> Has_coeffects + +(* [cextcall] is called from [Cmmgen.transl_ccall] *) +let cextcall (prim : Primitive.description) args dbg ret ty_args returns = + let name = Primitive.native_name prim in + let default = + Cop + ( Cextcall + { func = name; + ty = ret; + builtin = prim.prim_c_builtin; + effects = transl_effects prim.prim_effects; + coeffects = transl_coeffects prim.prim_coeffects; + alloc = prim.prim_alloc; + returns; + ty_args + }, + args, + dbg ) + in + if prim.prim_c_builtin + then + match transl_builtin name args dbg ret with + | Some op -> op + | None -> default + else default + +let extcall ~dbg ~returns ~alloc ~is_c_builtin ~ty_args name typ_res args = + if not returns then assert (typ_res = typ_void); + let default = + Cop + ( Cextcall + { func = name; + ty = typ_res; + alloc; + ty_args; + returns; + builtin = is_c_builtin; + effects = Arbitrary_effects; + coeffects = Has_coeffects + }, + args, + dbg ) + in + if is_c_builtin + then + match transl_builtin name args dbg typ_res with + | Some op -> op + | None -> default + else default diff --git a/ocaml/toplevel/opttopdirs.mli b/backend/cmm_builtins.mli similarity index 63% rename from ocaml/toplevel/opttopdirs.mli rename to backend/cmm_builtins.mli index e70433528b5..33e53f467d8 100644 --- a/ocaml/toplevel/opttopdirs.mli +++ b/backend/cmm_builtins.mli @@ -13,22 +13,28 @@ (* *) (**************************************************************************) -(* The toplevel directives. *) +open Cmm -open Format +(** Create a C function call. *) +val extcall : + dbg:Debuginfo.t -> + returns:bool -> + alloc:bool -> + is_c_builtin:bool -> + ty_args:exttype list -> + string -> + machtype -> + expression list -> + expression -val dir_quit : unit -> unit -val dir_directory : string -> unit -val dir_remove_directory : string -> unit -val dir_cd : string -> unit -val dir_load : formatter -> string -> unit -val dir_use : formatter -> string -> unit -val dir_use_output : formatter -> string -> unit -val dir_install_printer : formatter -> Longident.t -> unit -val dir_remove_printer : formatter -> Longident.t -> unit - -type 'a printer_type_new = Format.formatter -> 'a -> unit -type 'a printer_type_old = 'a -> unit - -(* For topmain.ml. Maybe shouldn't be there *) -val load_file : formatter -> string -> bool +(** [cextcall prim args dbg type_of_result] returns Cextcall operation that + corresponds to [prim]. If [prim] is a C builtin supported on the target, + returns [Cmm.operation] variant for [prim]'s intrinsics. *) +val cextcall : + Primitive.description -> + expression list -> + Debuginfo.t -> + machtype -> + exttype list -> + bool -> + expression diff --git a/backend/cmm_helpers.ml b/backend/cmm_helpers.ml index 26dee274944..f2affb49fca 100644 --- a/backend/cmm_helpers.ml +++ b/backend/cmm_helpers.ml @@ -106,16 +106,20 @@ let caml_int64_ops = "caml_int64_ops" let pos_arity_in_closinfo = (8 * size_addr) - 8 (* arity = the top 8 bits of the closinfo word *) -let closure_info ~arity ~startenv = +let closure_info ~arity ~startenv ~is_last = let arity = match arity with Lambda.Tupled, n -> -n | Lambda.Curried _, n -> n in assert (-128 <= arity && arity <= 127); - assert (0 <= startenv && startenv < 1 lsl (pos_arity_in_closinfo - 1)); + assert (0 <= startenv && startenv < 1 lsl (pos_arity_in_closinfo - 2)); Nativeint.( add (shift_left (of_int arity) pos_arity_in_closinfo) - (add (shift_left (of_int startenv) 1) 1n)) + (add + (shift_left + (Bool.to_int is_last |> Nativeint.of_int) + (pos_arity_in_closinfo - 1)) + (add (shift_left (of_int startenv) 1) 1n))) let alloc_float_header mode dbg = match mode with @@ -131,8 +135,8 @@ let alloc_closure_header ~mode sz dbg = let alloc_infix_header ofs dbg = Cconst_natint (infix_header ofs, dbg) -let alloc_closure_info ~arity ~startenv dbg = - Cconst_natint (closure_info ~arity ~startenv, dbg) +let alloc_closure_info ~arity ~startenv ~is_last dbg = + Cconst_natint (closure_info ~arity ~startenv ~is_last, dbg) let alloc_boxedint32_header mode dbg = match mode with @@ -215,6 +219,8 @@ let rec sub_int c1 c2 dbg = add_const (sub_int c1 c2 dbg) n1 dbg | c1, c2 -> Cop (Csubi, [c1; c2], dbg) +let neg_int c dbg = sub_int (Cconst_int (0, dbg)) c dbg + let rec lsl_int c1 c2 dbg = match c1, c2 with | Cop (Clsl, [c; Cconst_int (n1, _)], _), Cconst_int (n2, _) @@ -1879,6 +1885,10 @@ module SArgBlocks = struct let gtint = Ccmpi Cgt + type arg = expression + + type test = expression + type act = expression type loc = Debuginfo.t @@ -1897,6 +1907,10 @@ module SArgBlocks = struct let make_isin h arg = Cop (Ccmpa Cge, [h; arg], Debuginfo.none) + let make_is_nonzero arg = arg + + let arg_as_test arg = arg + let make_if value_kind cond ifso ifnot = Cifthenelse ( cond, @@ -2385,7 +2399,8 @@ let send_function (arity, mode) = fun_args = List.map (fun (arg, ty) -> VP.create arg, ty) fun_args; fun_body = body; fun_codegen_options = []; - fun_dbg + fun_dbg; + fun_poll = Default_poll } let apply_function arity = @@ -2398,7 +2413,8 @@ let apply_function arity = fun_args = List.map (fun arg -> VP.create arg, typ_val) all_args; fun_body = body; fun_codegen_options = []; - fun_dbg + fun_dbg; + fun_poll = Default_poll } (* Generate tuplifying functions: @@ -2430,7 +2446,8 @@ let tuplify_function arity = @ [Cvar clos], dbg () ); fun_codegen_options = []; - fun_dbg + fun_dbg; + fun_poll = Default_poll } (* Generate currying functions: @@ -2505,7 +2522,8 @@ let final_curry_function ~nlocal ~arity = fun_args = [VP.create last_arg, typ_val; VP.create last_clos, typ_val]; fun_body = curry_fun [] last_clos (arity - 1); fun_codegen_options = []; - fun_dbg + fun_dbg; + fun_poll = Default_poll } let rec intermediate_curry_functions ~nlocal ~arity num = @@ -2536,7 +2554,7 @@ let rec intermediate_curry_functions ~nlocal ~arity num = Cconst_symbol (name1 ^ "_" ^ Int.to_string (num + 1), dbg ()); alloc_closure_info ~arity:(curried (arity - num - 1)) - ~startenv:3 (dbg ()); + ~startenv:3 (dbg ()) ~is_last:true; Cconst_symbol (name1 ^ "_" ^ Int.to_string (num + 1) ^ "_app", dbg ()); Cvar arg; @@ -2547,12 +2565,14 @@ let rec intermediate_curry_functions ~nlocal ~arity num = ( Calloc mode, [ alloc_closure_header ~mode 4 (dbg ()); Cconst_symbol (name1 ^ "_" ^ Int.to_string (num + 1), dbg ()); - alloc_closure_info ~arity:(curried 1) ~startenv:2 (dbg ()); + alloc_closure_info ~arity:(curried 1) ~startenv:2 + ~is_last:true (dbg ()); Cvar arg; Cvar clos ], dbg () )); fun_codegen_options = []; - fun_dbg + fun_dbg; + fun_poll = Default_poll } :: (if arity <= max_arity_optimized && arity - num > 2 @@ -2598,7 +2618,8 @@ let rec intermediate_curry_functions ~nlocal ~arity num = (List.map (fun (arg, _) -> Cvar arg) direct_args) clos; fun_codegen_options = []; - fun_dbg + fun_dbg; + fun_poll = Default_poll } in cf :: intermediate_curry_functions ~nlocal ~arity (num + 1) @@ -2676,11 +2697,6 @@ let floatfield n ptr dbg = dbg ) let int_as_pointer arg dbg = Cop (Caddi, [arg; Cconst_int (-1, dbg)], dbg) - -let int_of_value arg dbg = Cop (Cintofvalue, [arg], dbg) - -let value_of_int arg dbg = Cop (Cvalueofint, [arg], dbg) - (* always a pointer outside the heap *) let raise_prim raise_kind arg dbg = @@ -2782,46 +2798,6 @@ let bswap16 arg dbg = [arg], dbg ) -let if_operation_supported op ~f = - match Proc.operation_supported op with true -> Some (f ()) | false -> None - -let if_operation_supported_bi bi op ~f = - if bi = Primitive.Pint64 && size_int = 4 - then None - else if_operation_supported op ~f - -let clz ~arg_is_non_zero bi arg dbg = - let op = Cclz { arg_is_non_zero } in - if_operation_supported_bi bi op ~f:(fun () -> - let res = Cop (op, [make_unsigned_int bi arg dbg], dbg) in - if bi = Primitive.Pint32 && size_int = 8 - then Cop (Caddi, [res; Cconst_int (-32, dbg)], dbg) - else res) - -let ctz ~arg_is_non_zero bi arg dbg = - let arg = make_unsigned_int bi arg dbg in - if bi = Primitive.Pint32 && size_int = 8 - then - (* regardless of the value of the argument [arg_is_non_zero], always set the - corresponding field to [true], because we make it non-zero below by - setting bit 32. *) - let op = Cctz { arg_is_non_zero = true } in - if_operation_supported_bi bi op ~f:(fun () -> - (* Set bit 32 *) - let mask = Nativeint.shift_left 1n 32 in - Cop (op, [Cop (Cor, [arg; Cconst_natint (mask, dbg)], dbg)], dbg)) - else - let op = Cctz { arg_is_non_zero } in - if_operation_supported_bi bi op ~f:(fun () -> Cop (op, [arg], dbg)) - -let popcnt bi arg dbg = - if_operation_supported_bi bi Cpopcnt ~f:(fun () -> - Cop (Cpopcnt, [make_unsigned_int bi arg dbg], dbg)) - -let mulhi bi ~signed args dbg = - let op = Cmulhi { signed } in - if_operation_supported_bi bi op ~f:(fun () -> Cop (op, args, dbg)) - type binary_primitive = expression -> expression -> Debuginfo.t -> expression (* let pfield_computed = addr_array_ref *) @@ -2831,15 +2807,17 @@ type binary_primitive = expression -> expression -> Debuginfo.t -> expression type assignment_kind = | Caml_modify | Caml_modify_local + | Caml_initialize (* never local *) | Simple of initialization_or_assignment let assignment_kind (ptr : Lambda.immediate_or_pointer) (init : Lambda.initialization_or_assignment) = match init, ptr with | Assignment Alloc_heap, Pointer -> Caml_modify - | Assignment Alloc_local, Pointer -> Caml_modify_local - | Heap_initialization, _ -> - Misc.fatal_error "Cmm_helpers: Lambda.Heap_initialization unsupported" + | Assignment Alloc_local, Pointer -> + assert Config.stack_allocation; + Caml_modify_local + | Heap_initialization, _ -> Caml_initialize | Assignment _, Immediate -> Simple Assignment | Root_initialization, (Immediate | Pointer) -> Simple Initialization @@ -2875,6 +2853,21 @@ let setfield n ptr init arg1 arg2 dbg = }, [arg1; Cconst_int (n, dbg); arg2], dbg )) + | Caml_initialize -> + return_unit dbg + (Cop + ( Cextcall + { func = "caml_initialize"; + ty = typ_void; + alloc = false; + builtin = false; + returns = true; + effects = Arbitrary_effects; + coeffects = Has_coeffects; + ty_args = [] + }, + [field_address arg1 n dbg; arg2], + dbg )) | Simple init -> return_unit dbg (set_field arg1 n arg2 init dbg) let setfloatfield n init arg1 arg2 dbg = @@ -3077,6 +3070,8 @@ let setfield_computed ptr init arg1 arg2 arg3 dbg = | Caml_modify -> return_unit dbg (addr_array_set arg1 arg2 arg3 dbg) | Caml_modify_local -> return_unit dbg (addr_array_set_local arg1 arg2 arg3 dbg) + | Caml_initialize -> + return_unit dbg (addr_array_initialize arg1 arg2 arg3 dbg) | Simple _ -> return_unit dbg (int_array_set arg1 arg2 arg3 dbg) let bytesset_unsafe arg1 arg2 arg3 dbg = @@ -3211,330 +3206,6 @@ let bigstring_set size unsafe arg1 arg2 arg3 dbg = check_bound unsafe size dbg (bigstring_length ba dbg) idx (unaligned_set size ba_data idx newval dbg)))))) -let two_args name args = - match args with - | [arg1; arg2] -> arg1, arg2 - | _ -> - Misc.fatal_errorf "Cmm_helpers: expected exactly 2 arguments for %s" name - -let one_arg name args = - match args with - | [arg] -> arg - | _ -> - Misc.fatal_errorf "Cmm_helpers: expected exactly 1 argument for %s" name - -(* Untagging of a negative value shifts in an extra bit. The following code - clears the shifted sign bit of an untagged int. This straightline code is - faster on most targets than conditional code for checking whether the - argument is negative. *) -let clear_sign_bit arg dbg = - let mask = Nativeint.lognot (Nativeint.shift_left 1n ((size_int * 8) - 1)) in - Cop (Cand, [arg; Cconst_natint (mask, dbg)], dbg) - -let ext_pointer_load chunk name args dbg = - let p = int_as_pointer (one_arg name args) dbg in - Some (Cop (Cload (chunk, Mutable), [p], dbg)) - -let ext_pointer_store chunk name args dbg = - let arg1, arg2 = two_args name args in - let p = int_as_pointer arg1 dbg in - Some (return_unit dbg (Cop (Cstore (chunk, Assignment), [p; arg2], dbg))) - -let bigstring_prefetch ~is_write locality args dbg = - let op = Cprefetch { is_write; locality } in - if_operation_supported op ~f:(fun () -> - let arg1, arg2 = two_args "bigstring_prefetch" args in - (* [arg2], the index, is already untagged. *) - bind "index" arg2 (fun idx -> - bind "ba" arg1 (fun ba -> - bind "ba_data" - (Cop (Cload (Word_int, Mutable), [field_address ba 1 dbg], dbg)) - (fun ba_data -> - (* pointer to element "idx" of "ba" of type (char, - int8_unsigned_elt, c_layout) Bigarray.Array1.t is simply - offset "idx" from "ba_data" *) - return_unit dbg (Cop (op, [add_int ba_data idx dbg], dbg)))))) - -let prefetch ~is_write locality arg dbg = - let op = Cprefetch { is_write; locality } in - if_operation_supported op ~f:(fun () -> - return_unit dbg (Cop (op, [arg], dbg))) - -let ext_pointer_prefetch ~is_write locality arg dbg = - prefetch ~is_write locality (int_as_pointer arg dbg) dbg - -(** [transl_builtin prim args dbg] returns None if the built-in [prim] is not - supported, otherwise it constructs and returns the corresponding Cmm - expression. - - The names of builtins below correspond to the native code names associated - with "external" declarations in the stand-alone library [ocaml_intrinsics]. - - For situations such as where the Cmm code below returns e.g. an untagged - integer, we exploit the generic mechanism on "external" to deal with the - tagging before the result is returned to the user. *) -let transl_builtin name args dbg = - match name with - | "caml_int_clz_tagged_to_untagged" -> - (* The tag does not change the number of leading zeros. The advantage of - keeping the tag is it guarantees that, on x86-64, the input to the BSR - instruction is nonzero. *) - let op = Cclz { arg_is_non_zero = true } in - if_operation_supported op ~f:(fun () -> Cop (op, args, dbg)) - | "caml_int_clz_untagged_to_untagged" -> - let op = Cclz { arg_is_non_zero = false } in - if_operation_supported op ~f:(fun () -> - let arg = clear_sign_bit (one_arg name args) dbg in - Cop (Caddi, [Cop (op, [arg], dbg); Cconst_int (-1, dbg)], dbg)) - | "caml_int64_clz_unboxed_to_untagged" -> - clz ~arg_is_non_zero:false Pint64 (one_arg name args) dbg - | "caml_int32_clz_unboxed_to_untagged" -> - clz ~arg_is_non_zero:false Pint32 (one_arg name args) dbg - | "caml_nativeint_clz_unboxed_to_untagged" -> - clz ~arg_is_non_zero:false Pnativeint (one_arg name args) dbg - | "caml_int64_clz_nonzero_unboxed_to_untagged" -> - clz ~arg_is_non_zero:true Pint64 (one_arg name args) dbg - | "caml_int32_clz_nonzero_unboxed_to_untagged" -> - clz ~arg_is_non_zero:true Pint32 (one_arg name args) dbg - | "caml_nativeint_clz_nonzero_unboxed_to_untagged" -> - clz ~arg_is_non_zero:true Pnativeint (one_arg name args) dbg - | "caml_int_popcnt_tagged_to_untagged" -> - if_operation_supported Cpopcnt ~f:(fun () -> - (* Having the argument tagged saves a shift, but there is one extra - "set" bit, which is accounted for by the (-1) below. *) - Cop (Caddi, [Cop (Cpopcnt, args, dbg); Cconst_int (-1, dbg)], dbg)) - | "caml_int_popcnt_untagged_to_untagged" -> - (* This code is expected to be faster than [popcnt(tagged_x) - 1] when the - untagged argument is already available from a previous computation. *) - if_operation_supported Cpopcnt ~f:(fun () -> - let arg = clear_sign_bit (one_arg name args) dbg in - Cop (Cpopcnt, [arg], dbg)) - | "caml_int64_popcnt_unboxed_to_untagged" -> - popcnt Pint64 (one_arg name args) dbg - | "caml_int32_popcnt_unboxed_to_untagged" -> - popcnt Pint32 (one_arg name args) dbg - | "caml_nativeint_popcnt_unboxed_to_untagged" -> - popcnt Pnativeint (one_arg name args) dbg - | "caml_int_ctz_untagged_to_untagged" -> - (* Assuming a 64-bit x86-64 target: - - Setting the top bit of the input for the BSF instruction ensures the - input is nonzero without affecting the result. - - The expression [x lor (1 lsl 63)] sets the top bit of x. The constant: - - [1 lsl 63] - - can be precomputed statically: - - Cconst_natint ((Nativeint.shift_left 1n 63), dbg) - - However, the encoding of this OR instruction with the large static - constant is 10 bytes long, on x86-64. Instead, we emit a shift operation, - whose corresponding instruction is 1 byte shorter. This will not require - an extra register, unless both the argument and result of the BSF - instruction are in the same register. *) - let op = Cctz { arg_is_non_zero = true } in - if_operation_supported op ~f:(fun () -> - let c = - Cop - ( Clsl, - [Cconst_int (1, dbg); Cconst_int ((size_int * 8) - 1, dbg)], - dbg ) - in - Cop (op, [Cop (Cor, [one_arg name args; c], dbg)], dbg)) - | "caml_int32_ctz_unboxed_to_untagged" -> - ctz ~arg_is_non_zero:false Pint32 (one_arg name args) dbg - | "caml_int64_ctz_unboxed_to_untagged" -> - ctz ~arg_is_non_zero:false Pint64 (one_arg name args) dbg - | "caml_nativeint_ctz_unboxed_to_untagged" -> - ctz ~arg_is_non_zero:false Pnativeint (one_arg name args) dbg - | "caml_int32_ctz_nonzero_unboxed_to_untagged" -> - ctz ~arg_is_non_zero:true Pint32 (one_arg name args) dbg - | "caml_int64_ctz_nonzero_unboxed_to_untagged" -> - ctz ~arg_is_non_zero:true Pint64 (one_arg name args) dbg - | "caml_nativeint_ctz_nonzero_unboxed_to_untagged" -> - ctz ~arg_is_non_zero:true Pnativeint (one_arg name args) dbg - | "caml_signed_int64_mulh_unboxed" -> mulhi ~signed:true Pint64 args dbg - | "caml_unsigned_int64_mulh_unboxed" -> mulhi ~signed:false Pint64 args dbg - | "caml_int32_unsigned_to_int_trunc_unboxed_to_untagged" -> - Some (zero_extend_32 dbg (one_arg name args)) - (* Native_pointer: handled as unboxed nativeint *) - | "caml_ext_pointer_as_native_pointer" -> - Some (int_as_pointer (one_arg name args) dbg) - | "caml_native_pointer_of_value" -> - Some (int_of_value (one_arg name args) dbg) - | "caml_native_pointer_to_value" -> - Some (value_of_int (one_arg name args) dbg) - | "caml_native_pointer_load_immediate" - | "caml_native_pointer_load_unboxed_nativeint" -> - Some (Cop (Cload (Word_int, Mutable), args, dbg)) - | "caml_native_pointer_store_immediate" - | "caml_native_pointer_store_unboxed_nativeint" -> - Some (return_unit dbg (Cop (Cstore (Word_int, Assignment), args, dbg))) - | "caml_native_pointer_load_unboxed_int64" when size_int = 8 -> - Some (Cop (Cload (Word_int, Mutable), args, dbg)) - | "caml_native_pointer_store_unboxed_int64" when size_int = 8 -> - Some (return_unit dbg (Cop (Cstore (Word_int, Assignment), args, dbg))) - | "caml_native_pointer_load_signed_int32" - | "caml_native_pointer_load_unboxed_int32" -> - Some (Cop (Cload (Thirtytwo_signed, Mutable), args, dbg)) - | "caml_native_pointer_store_signed_int32" - | "caml_native_pointer_store_unboxed_int32" -> - Some - (return_unit dbg (Cop (Cstore (Thirtytwo_signed, Assignment), args, dbg))) - | "caml_native_pointer_load_unsigned_int32" -> - Some (Cop (Cload (Thirtytwo_unsigned, Mutable), args, dbg)) - | "caml_native_pointer_store_unsigned_int32" -> - Some - (return_unit dbg - (Cop (Cstore (Thirtytwo_unsigned, Assignment), args, dbg))) - | "caml_native_pointer_load_unboxed_float" -> - Some (Cop (Cload (Double, Mutable), args, dbg)) - | "caml_native_pointer_store_unboxed_float" -> - Some (return_unit dbg (Cop (Cstore (Double, Assignment), args, dbg))) - | "caml_native_pointer_load_unsigned_int8" -> - Some (Cop (Cload (Byte_unsigned, Mutable), args, dbg)) - | "caml_native_pointer_load_signed_int8" -> - Some (Cop (Cload (Byte_signed, Mutable), args, dbg)) - | "caml_native_pointer_load_unsigned_int16" -> - Some (Cop (Cload (Sixteen_unsigned, Mutable), args, dbg)) - | "caml_native_pointer_load_signed_int16" -> - Some (Cop (Cload (Sixteen_signed, Mutable), args, dbg)) - | "caml_native_pointer_store_unsigned_int8" -> - Some (return_unit dbg (Cop (Cstore (Byte_unsigned, Assignment), args, dbg))) - | "caml_native_pointer_store_signed_int8" -> - Some (return_unit dbg (Cop (Cstore (Byte_signed, Assignment), args, dbg))) - | "caml_native_pointer_store_unsigned_int16" -> - Some - (return_unit dbg (Cop (Cstore (Sixteen_unsigned, Assignment), args, dbg))) - | "caml_native_pointer_store_signed_int16" -> - Some - (return_unit dbg (Cop (Cstore (Sixteen_signed, Assignment), args, dbg))) - (* Ext_pointer: handled as tagged int *) - | "caml_ext_pointer_load_immediate" - | "caml_ext_pointer_load_unboxed_nativeint" -> - ext_pointer_load Word_int name args dbg - | "caml_ext_pointer_store_immediate" - | "caml_ext_pointer_store_unboxed_nativeint" -> - ext_pointer_store Word_int name args dbg - | "caml_ext_pointer_load_unboxed_int64" when size_int = 8 -> - ext_pointer_load Word_int name args dbg - | "caml_ext_pointer_store_unboxed_int64" when size_int = 8 -> - ext_pointer_store Word_int name args dbg - | "caml_ext_pointer_load_signed_int32" | "caml_ext_pointer_load_unboxed_int32" - -> - ext_pointer_load Thirtytwo_signed name args dbg - | "caml_ext_pointer_store_signed_int32" - | "caml_ext_pointer_store_unboxed_int32" -> - ext_pointer_store Thirtytwo_signed name args dbg - | "caml_ext_pointer_load_unsigned_int32" -> - ext_pointer_load Thirtytwo_unsigned name args dbg - | "caml_ext_pointer_store_unsigned_int32" -> - ext_pointer_store Thirtytwo_unsigned name args dbg - | "caml_ext_pointer_load_unboxed_float" -> - ext_pointer_load Double name args dbg - | "caml_ext_pointer_store_unboxed_float" -> - ext_pointer_store Double name args dbg - | "caml_ext_pointer_load_unsigned_int8" -> - ext_pointer_load Byte_unsigned name args dbg - | "caml_ext_pointer_load_signed_int8" -> - ext_pointer_load Byte_signed name args dbg - | "caml_ext_pointer_load_unsigned_int16" -> - ext_pointer_load Sixteen_unsigned name args dbg - | "caml_ext_pointer_load_signed_int16" -> - ext_pointer_load Sixteen_signed name args dbg - | "caml_ext_pointer_store_unsigned_int8" -> - ext_pointer_store Byte_unsigned name args dbg - | "caml_ext_pointer_store_signed_int8" -> - ext_pointer_store Byte_signed name args dbg - | "caml_ext_pointer_store_unsigned_int16" -> - ext_pointer_store Sixteen_unsigned name args dbg - | "caml_ext_pointer_store_signed_int16" -> - ext_pointer_store Sixteen_signed name args dbg - (* Bigstring prefetch *) - | "caml_prefetch_write_high_bigstring_untagged" -> - bigstring_prefetch ~is_write:true High args dbg - | "caml_prefetch_write_moderate_bigstring_untagged" -> - bigstring_prefetch ~is_write:true Moderate args dbg - | "caml_prefetch_write_low_bigstring_untagged" -> - bigstring_prefetch ~is_write:true Low args dbg - | "caml_prefetch_write_none_bigstring_untagged" -> - bigstring_prefetch ~is_write:true Nonlocal args dbg - | "caml_prefetch_read_none_bigstring_untagged" -> - bigstring_prefetch ~is_write:false Nonlocal args dbg - | "caml_prefetch_read_high_bigstring_untagged" -> - bigstring_prefetch ~is_write:false High args dbg - | "caml_prefetch_read_moderate_bigstring_untagged" -> - bigstring_prefetch ~is_write:false Moderate args dbg - | "caml_prefetch_read_low_bigstring_untagged" -> - bigstring_prefetch ~is_write:false Low args dbg - (* Ext_pointer prefetch *) - | "caml_prefetch_write_high_ext_pointer" -> - ext_pointer_prefetch ~is_write:true High (one_arg name args) dbg - | "caml_prefetch_write_moderate_ext_pointer" -> - ext_pointer_prefetch ~is_write:true Moderate (one_arg name args) dbg - | "caml_prefetch_write_low_ext_pointer" -> - ext_pointer_prefetch ~is_write:true Low (one_arg name args) dbg - | "caml_prefetch_write_none_ext_pointer" -> - ext_pointer_prefetch ~is_write:true Nonlocal (one_arg name args) dbg - | "caml_prefetch_read_none_ext_pointer" -> - ext_pointer_prefetch ~is_write:false Nonlocal (one_arg name args) dbg - | "caml_prefetch_read_high_ext_pointer" -> - ext_pointer_prefetch ~is_write:false High (one_arg name args) dbg - | "caml_prefetch_read_moderate_ext_pointer" -> - ext_pointer_prefetch ~is_write:false Moderate (one_arg name args) dbg - | "caml_prefetch_read_low_ext_pointer" -> - ext_pointer_prefetch ~is_write:false Low (one_arg name args) dbg - (* Native_pointer prefetch *) - | "caml_prefetch_write_high_native_pointer_unboxed" -> - prefetch ~is_write:true High (one_arg name args) dbg - | "caml_prefetch_write_moderate_native_pointer_unboxed" -> - prefetch ~is_write:true Moderate (one_arg name args) dbg - | "caml_prefetch_write_low_native_pointer_unboxed" -> - prefetch ~is_write:true Low (one_arg name args) dbg - | "caml_prefetch_write_none_native_pointer_unboxed" -> - prefetch ~is_write:true Nonlocal (one_arg name args) dbg - | "caml_prefetch_read_none_native_pointer_unboxed" -> - prefetch ~is_write:false Nonlocal (one_arg name args) dbg - | "caml_prefetch_read_high_native_pointer_unboxed" -> - prefetch ~is_write:false High (one_arg name args) dbg - | "caml_prefetch_read_moderate_native_pointer_unboxed" -> - prefetch ~is_write:false Moderate (one_arg name args) dbg - | "caml_prefetch_read_low_native_pointer_unboxed" -> - prefetch ~is_write:false Low (one_arg name args) dbg - | _ -> None - -let transl_effects (e : Primitive.effects) : Cmm.effects = - match e with - | No_effects -> No_effects - | Only_generative_effects | Arbitrary_effects -> Arbitrary_effects - -let transl_coeffects (ce : Primitive.coeffects) : Cmm.coeffects = - match ce with No_coeffects -> No_coeffects | Has_coeffects -> Has_coeffects - -(* [cextcall] is called from [Cmmgen.transl_ccall] *) -let cextcall (prim : Primitive.description) args dbg ret ty_args returns = - let name = Primitive.native_name prim in - let default = - Cop - ( Cextcall - { func = name; - ty = ret; - builtin = prim.prim_c_builtin; - effects = transl_effects prim.prim_effects; - coeffects = transl_coeffects prim.prim_coeffects; - alloc = prim.prim_alloc; - returns; - ty_args - }, - args, - dbg ) - in - if prim.prim_c_builtin - then match transl_builtin name args dbg with Some op -> op | None -> default - else default - (* Symbols *) let cdefine_symbol (symb, (global : Cmmgen_state.is_global)) = @@ -3639,7 +3310,8 @@ let entry_point namelist = fun_args = []; fun_body = body; fun_codegen_options = [Reduce_code_size]; - fun_dbg + fun_dbg; + fun_poll = Default_poll } (* Generate the table of globals *) @@ -3757,19 +3429,21 @@ let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont = let rec emit_others pos = function | [] -> clos_vars @ cont | (f2 : Clambda.ufunction) :: rem -> ( + let is_last = match rem with [] -> true | _ :: _ -> false in match f2.arity with | (Curried _, (0 | 1)) as arity -> (Cint (infix_header pos) :: closure_symbol f2) @ Csymbol_address f2.label - :: Cint (closure_info ~arity ~startenv:(startenv - pos)) + :: Cint (closure_info ~arity ~startenv:(startenv - pos) ~is_last) :: emit_others (pos + 3) rem | arity -> (Cint (infix_header pos) :: closure_symbol f2) @ Csymbol_address (curry_function_sym arity) - :: Cint (closure_info ~arity ~startenv:(startenv - pos)) + :: Cint (closure_info ~arity ~startenv:(startenv - pos) ~is_last) :: Csymbol_address f2.label :: emit_others (pos + 4) rem) in + let is_last = match remainder with [] -> true | _ :: _ -> false in Cint (black_closure_header (fundecls_size fundecls + List.length clos_vars)) :: cdefine_symbol symb @ closure_symbol f1 @@ -3777,11 +3451,11 @@ let emit_constant_closure ((_, global_symb) as symb) fundecls clos_vars cont = match f1.arity with | (Curried _, (0 | 1)) as arity -> Csymbol_address f1.label - :: Cint (closure_info ~arity ~startenv) + :: Cint (closure_info ~arity ~startenv ~is_last) :: emit_others 3 remainder | arity -> Csymbol_address (curry_function_sym arity) - :: Cint (closure_info ~arity ~startenv) + :: Cint (closure_info ~arity ~startenv ~is_last) :: Csymbol_address f1.label :: emit_others 4 remainder) (* Build the NULL terminated array of gc roots *) @@ -4071,27 +3745,6 @@ let indirect_full_call ~dbg ty pos alloc_mode f = function letin v' ~defining_expr:f ~body:(Cop (Capply (ty, pos), (fun_ptr :: args) @ [Cvar v], dbg)) -let extcall ~dbg ~returns ~alloc ~is_c_builtin ~ty_args name typ_res args = - if not returns then assert (typ_res = typ_void); - let default = - Cop - ( Cextcall - { func = name; - ty = typ_res; - alloc; - ty_args; - returns; - builtin = is_c_builtin; - effects = Arbitrary_effects; - coeffects = Has_coeffects - }, - args, - dbg ) - in - if is_c_builtin - then match transl_builtin name args dbg with Some op -> op | None -> default - else default - let bigarray_load ~dbg ~elt_kind ~elt_size ~elt_chunk ~bigarray ~index = let ba_data_f = field_address bigarray 1 dbg in let ba_data_p = load ~dbg Word_int Mutable ~addr:ba_data_f in @@ -4155,8 +3808,8 @@ let cfunction decl = Cmm.Cfunction decl let cdata d = Cmm.Cdata d -let fundecl fun_name fun_args fun_body fun_codegen_options fun_dbg = - { Cmm.fun_name; fun_args; fun_body; fun_codegen_options; fun_dbg } +let fundecl fun_name fun_args fun_body fun_codegen_options fun_dbg fun_poll = + { Cmm.fun_name; fun_args; fun_body; fun_codegen_options; fun_dbg; fun_poll } (* Gc root table *) diff --git a/backend/cmm_helpers.mli b/backend/cmm_helpers.mli index b1e17ff6169..7848372eeaf 100644 --- a/backend/cmm_helpers.mli +++ b/backend/cmm_helpers.mli @@ -60,13 +60,18 @@ val boxedint64_header : nativeint val boxedintnat_header : nativeint (** Closure info for a closure of given arity and distance to environment *) -val closure_info : arity:Clambda.arity -> startenv:int -> nativeint +val closure_info : + arity:Clambda.arity -> startenv:int -> is_last:bool -> nativeint (** Wrappers *) val alloc_infix_header : int -> Debuginfo.t -> expression val alloc_closure_info : - arity:Lambda.function_kind * int -> startenv:int -> Debuginfo.t -> expression + arity:Lambda.function_kind * int -> + startenv:int -> + is_last:bool -> + Debuginfo.t -> + expression (** Integers *) @@ -109,6 +114,8 @@ val add_int : expression -> expression -> Debuginfo.t -> expression val sub_int : expression -> expression -> Debuginfo.t -> expression +val neg_int : expression -> Debuginfo.t -> expression + val lsl_int : expression -> expression -> Debuginfo.t -> expression val mul_int : expression -> expression -> Debuginfo.t -> expression @@ -774,18 +781,6 @@ val send : (** Construct [Cregion e], eliding some useless regions *) val region : expression -> expression -(** [cextcall prim args dbg type_of_result] returns Cextcall operation that - corresponds to [prim]. If [prim] is a C builtin supported on the target, - returns [Cmm.operation] variant for [prim]'s intrinsics. *) -val cextcall : - Primitive.description -> - expression list -> - Debuginfo.t -> - machtype -> - exttype list -> - bool -> - expression - (** Generic Cmm fragments *) (** Generate generic functions *) @@ -820,8 +815,7 @@ val reference_symbols : string list -> phrase The runtime representation of the type here must match that of [type global_map] in the natdynlink code. *) val globals_map : - (Compilation_unit.Name.t * Digest.t option * Digest.t option * Symbol.t list) - list -> + (Compilation_unit.t * Digest.t option * Digest.t option * Symbol.t list) list -> phrase (** Generate the caml_frametable table, referencing the frametables from the @@ -1127,18 +1121,6 @@ val indirect_full_call : expression list -> expression -(** Create a C function call. *) -val extcall : - dbg:Debuginfo.t -> - returns:bool -> - alloc:bool -> - is_c_builtin:bool -> - ty_args:exttype list -> - string -> - machtype -> - expression list -> - expression - val bigarray_load : dbg:Debuginfo.t -> elt_kind:Lambda.bigarray_kind -> @@ -1188,6 +1170,7 @@ val fundecl : expression -> codegen_option list -> Debuginfo.t -> + Lambda.poll_attribute -> fundecl (** Create a cmm phrase for a function declaration. *) diff --git a/backend/cmmgen.ml b/backend/cmmgen.ml index 46b6c542a18..9de6e6e35a7 100644 --- a/backend/cmmgen.ml +++ b/backend/cmmgen.ml @@ -32,6 +32,7 @@ module IntMap = Map.Make(Int) module V = Backend_var module VP = Backend_var.With_provenance open Cmm_helpers +open Cmm_builtins (* Environments used for translation to Cmm. *) @@ -156,8 +157,9 @@ type rhs_kind = let rec expr_size env = function | Uvar id -> begin try V.find_same id env with Not_found -> RHS_nonrec end - | Uclosure(fundecls, clos_vars) -> - RHS_block (fundecls_size fundecls + List.length clos_vars) + | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> + RHS_block (fundecls_size functions + List.length not_scanned_slots + + List.length scanned_slots) | Ulet(_str, _kind, id, exp, body) -> expr_size (V.add (VP.var id) (expr_size env exp) env) body | Uletrec(bindings, body) -> @@ -426,18 +428,18 @@ let rec transl env e = end | Uconst sc -> transl_constant Debuginfo.none sc - | Uclosure(fundecls, []) -> + | Uclosure { functions ; not_scanned_slots = [] ; scanned_slots = [] } -> let sym = Compilenv.new_const_symbol() in - Cmmgen_state.add_constant sym (Const_closure (Local, fundecls, [])); - List.iter (fun f -> Cmmgen_state.add_function f) fundecls; + Cmmgen_state.add_constant sym (Const_closure (Local, functions, [])); + List.iter (fun f -> Cmmgen_state.add_function f) functions; let dbg = - match fundecls with + match functions with | [] -> Debuginfo.none | fundecl::_ -> fundecl.dbg in Cconst_symbol (sym, dbg) - | Uclosure(fundecls, clos_vars) -> - let startenv = fundecls_size fundecls in + | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> + let startenv = fundecls_size functions + List.length not_scanned_slots in let mode = Option.get @@ List.fold_left (fun s { mode; dbg; _ } -> @@ -447,11 +449,12 @@ let rec transl env e = if not (Lambda.eq_mode mode m') then Misc.fatal_errorf "Inconsistent modes in let rec at %s" (Debuginfo.to_string dbg); - s) None fundecls in + s) None functions in let rec transl_fundecls pos = function [] -> - List.map (transl env) clos_vars + List.map (transl env) (not_scanned_slots @ scanned_slots) | f :: rem -> + let is_last = match rem with [] -> true | _::_ -> false in Cmmgen_state.add_function f; let dbg = f.dbg in let without_header = @@ -459,12 +462,12 @@ let rec transl env e = | Curried _, (1|0) as arity -> Cconst_symbol (f.label, dbg) :: alloc_closure_info ~arity - ~startenv:(startenv - pos) dbg :: + ~startenv:(startenv - pos) ~is_last dbg :: transl_fundecls (pos + 3) rem | arity -> Cconst_symbol (curry_function_sym arity, dbg) :: alloc_closure_info ~arity - ~startenv:(startenv - pos) dbg :: + ~startenv:(startenv - pos) ~is_last dbg :: Cconst_symbol (f.label, dbg) :: transl_fundecls (pos + 4) rem in @@ -473,11 +476,11 @@ let rec transl env e = else alloc_infix_header pos f.dbg :: without_header in let dbg = - match fundecls with + match functions with | [] -> Debuginfo.none | fundecl::_ -> fundecl.dbg in - make_alloc ~mode dbg Obj.closure_tag (transl_fundecls 0 fundecls) + make_alloc ~mode dbg Obj.closure_tag (transl_fundecls 0 functions) | Uoffset(arg, offset) -> (* produces a valid Caml value, pointing just after an infix header *) let ptr = transl env arg in @@ -1481,6 +1484,7 @@ let transl_function f = fun_args = List.map (fun (id, _) -> (id, typ_val)) f.params; fun_body = cmm_body; fun_codegen_options; + fun_poll = f.poll; fun_dbg = f.dbg} (* Translate all function definitions *) @@ -1583,7 +1587,8 @@ let compunit (ulam, preallocated_blocks, constants) = Use_linscan_regalloc; ] else [ Reduce_code_size; Use_linscan_regalloc ]; - fun_dbg = Debuginfo.none }] in + fun_dbg = Debuginfo.none; + fun_poll = Default_poll }] in let c2 = transl_clambda_constants constants c1 in let c3 = transl_all_functions c2 in Cmmgen_state.set_structured_constants []; diff --git a/backend/comballoc.ml b/backend/comballoc.ml index 30b205d1135..5275f0a9490 100644 --- a/backend/comballoc.ml +++ b/backend/comballoc.ml @@ -71,7 +71,7 @@ let rec combine i allocstate = i.arg i.res i.dbg next, allocstate) end | Iop(Icall_ind | Icall_imm _ | Iextcall _ | - Itailcall_ind | Itailcall_imm _ | Iprobe _ | + Itailcall_ind | Itailcall_imm _ | Ipoll _ | Iprobe _ | Iintop Icheckbound | Iintop_imm (Icheckbound, _)) -> let newnext = combine_restart i.next in (instr_cons_debug i.desc i.arg i.res i.dbg newnext, @@ -88,13 +88,15 @@ let rec combine i allocstate = | Iop((Imove|Ispill|Ireload|Inegf|Iabsf|Iaddf|Isubf|Imulf|Idivf|Ifloatofint| Iintoffloat|Ivalueofint|Iintofvalue|Iopaque|Iconst_int _|Iconst_float _| Iconst_symbol _|Istackoffset _|Iload (_, _, _)|Istore (_, _, _)|Icompf _| + Icsel _ | Ispecific _|Iname_for_debugger _|Iprobe_is_enabled _)) | Iop(Iintop(Iadd | Isub | Imul | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Ipopcnt | Imulh _ | Iclz _ | Ictz _ | Icomp _)) | Iop(Iintop_imm((Iadd | Isub | Imul | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Ipopcnt | Imulh _ - | Iclz _ | Ictz _ | Icomp _),_)) -> + | Iclz _ | Ictz _ | Icomp _),_)) + | Iop(Iintop_atomic _) -> let (newnext, s') = combine i.next allocstate in (instr_cons_debug i.desc i.arg i.res i.dbg newnext, s') | Iifthenelse(test, ifso, ifnot) -> diff --git a/backend/dataflow.ml b/backend/dataflow.ml index 66afad8311e..9b490483dff 100644 --- a/backend/dataflow.ml +++ b/backend/dataflow.ml @@ -24,7 +24,7 @@ end module Backward(D: DOMAIN) = struct -let analyze ?(exnhandler = fun x -> x) ~transfer instr = +let analyze ?(exnhandler = fun x -> x) ?(exnescape = D.bot) ~transfer instr = let lbls = (Hashtbl.create 20 : (int, D.t) Hashtbl.t) in @@ -80,7 +80,7 @@ let analyze ?(exnhandler = fun x -> x) ~transfer instr = | Iraise _ -> transfer i ~next:D.bot ~exn in - let b = before D.bot D.bot instr in + let b = before D.bot exnescape instr in (b, get_lbl) end diff --git a/backend/dataflow.mli b/backend/dataflow.mli index df845b028be..e722066d6d1 100644 --- a/backend/dataflow.mli +++ b/backend/dataflow.mli @@ -28,6 +28,7 @@ end module Backward(D: DOMAIN) : sig val analyze: ?exnhandler: (D.t -> D.t) -> + ?exnescape: D.t -> transfer: (Mach.instruction -> next: D.t -> exn: D.t -> D.t) -> Mach.instruction -> D.t * (int -> D.t) @@ -80,6 +81,10 @@ module Backward(D: DOMAIN) : sig the beginning of the handler and removes the register [Proc.loc_exn_bucket] that carries the exception value. If not specified, [exnhandler] defaults to the identity function. + + The optional [exnescape] argument deals with unhandled exceptions. + It is the abstract state corresponding to exiting the function on an + unhandled exception. It defaults to [D.bot]. *) end diff --git a/backend/debug/available_regs.ml b/backend/debug/available_regs.ml index 75d8f0d9fef..b792fa48c7a 100644 --- a/backend/debug/available_regs.ml +++ b/backend/debug/available_regs.ml @@ -368,7 +368,7 @@ and join branches ~avail_before = None, avail_after let fundecl (f : M.fundecl) = - if !Clflags.debug && !Clflags.debug_runavail + if false (* !Clflags.debug && !Clflags.debug_runavail *) then ( assert (Hashtbl.length avail_at_exit = 0); avail_at_raise := RAS.Unreachable; diff --git a/backend/debug/dwarf/dwarf_high/proto_die.ml b/backend/debug/dwarf/dwarf_high/proto_die.ml index 63438e15aff..af13d7eb249 100644 --- a/backend/debug/dwarf/dwarf_high/proto_die.ml +++ b/backend/debug/dwarf/dwarf_high/proto_die.ml @@ -15,7 +15,7 @@ open Asm_targets open Dwarf_low -[@@@ocaml.warning "+a-4-30-40-41-42"] +[@@@ocaml.warning "+a-4-30-40-41-42-69"] module ASS = Dwarf_attributes.Attribute_specification.Sealed module AV = Dwarf_attribute_values.Attribute_value diff --git a/backend/emit.mli b/backend/emit.mli index d5ca01ad5db..f908d1fc231 100644 --- a/backend/emit.mli +++ b/backend/emit.mli @@ -17,5 +17,6 @@ val fundecl: Linear.fundecl -> unit val data: Cmm.data_item list -> unit -val begin_assembly: init_dwarf:(unit -> unit) -> unit -val end_assembly: Dwarf_ocaml.Dwarf.t option -> unit +val begin_assembly: (module Compiler_owee.Unix_intf.S) -> unit +val end_assembly: unit -> unit + diff --git a/backend/emitaux.ml b/backend/emitaux.ml index edea8415a80..864ff545fd0 100644 --- a/backend/emitaux.ml +++ b/backend/emitaux.ml @@ -17,6 +17,7 @@ type error = | Stack_frame_too_large of int + | Stack_frame_way_too_large of int exception Error of error @@ -119,16 +120,48 @@ type frame_descr = { fd_lbl: int; (* Return address *) fd_frame_size: int; (* Size of stack frame *) fd_live_offset: int list; (* Offsets/regs of live addresses *) - fd_debuginfo: frame_debuginfo } (* Location, if any *) + fd_debuginfo: frame_debuginfo; (* Location, if any *) + fd_long: bool; (* Use 32 instead of 16 bit format. *) + } let frame_descriptors = ref([] : frame_descr list) +let get_flags debuginfo = + match debuginfo with + | Dbg_other d | Dbg_raise d -> + if Debuginfo.is_none d then 0 else 1 + | Dbg_alloc dbgs -> + if !Clflags.debug && + List.exists (fun d -> + not (Debuginfo.is_none d.Debuginfo.alloc_dbg)) dbgs + then 3 else 2 + +let is_long n = + assert (n >= 0); + (* Long frames must fit in 32-bit integer and + not truncated upon conversion from int on any target. *) + if n > 0x3FFF_FFFF then + raise (Error(Stack_frame_way_too_large n)); + n >= !Flambda_backend_flags.long_frames_threshold + let record_frame_descr ~label ~frame_size ~live_offset debuginfo = - frame_descriptors := - { fd_lbl = label; + assert (frame_size land 3 = 0); + let fd_long = + is_long (frame_size + get_flags debuginfo) || + (* The checks below are redundant + (if they fail, then frame size check above should have failed), + but they make the safety of [emit_frame] clear. *) + is_long (List.length live_offset) || + (List.exists is_long live_offset) + in + if fd_long && not !Flambda_backend_flags.allow_long_frames then + raise (Error(Stack_frame_too_large frame_size)); + frame_descriptors := { fd_lbl = label; fd_frame_size = frame_size; fd_live_offset = List.sort_uniq (-) live_offset; - fd_debuginfo = debuginfo } :: !frame_descriptors + fd_debuginfo = debuginfo; + fd_long; + } :: !frame_descriptors type emit_frame_actions = { efa_code_label: int -> unit; @@ -183,28 +216,22 @@ let emit_frames a = Label_table.add debuginfos key lbl; lbl in - let efa_16_checked n = - assert (n >= 0); - if n < 0x1_0000 - then a.efa_16 n - else raise (Error(Stack_frame_too_large n)) - in + let emit_32 n = n |> Int32.of_int |> a.efa_32 in let emit_frame fd = - assert (fd.fd_frame_size land 3 = 0); - let flags = - match fd.fd_debuginfo with - | Dbg_other d | Dbg_raise d -> - if Debuginfo.is_none d then 0 else 1 - | Dbg_alloc dbgs -> - if !Clflags.debug && - List.exists (fun d -> - not (Debuginfo.is_none d.Debuginfo.alloc_dbg)) dbgs - then 3 else 2 - in + let flags = get_flags fd.fd_debuginfo in a.efa_code_label fd.fd_lbl; - efa_16_checked (fd.fd_frame_size + flags); - efa_16_checked (List.length fd.fd_live_offset); - List.iter efa_16_checked fd.fd_live_offset; + (* For short format, the size is guaranteed + to be less than the constant below. *) + if fd.fd_long then begin + a.efa_16 Flambda_backend_flags.max_long_frames_threshold; + a.efa_align 4; + end; + let emit_16_or_32 = + if fd.fd_long then emit_32 else a.efa_16 + in + emit_16_or_32 (fd.fd_frame_size + flags); + emit_16_or_32 (List.length fd.fd_live_offset); + List.iter emit_16_or_32 fd.fd_live_offset; begin match fd.fd_debuginfo with | _ when flags = 0 -> () @@ -405,7 +432,77 @@ let reduce_heap_size ~reset = Gc.compact ()) end +module Dwarf_helpers = struct + open Dwarf_ocaml + + let dwarf = ref None + let sourcefile_for_dwarf = ref None + + let begin_dwarf ~build_asm_directives ~code_begin ~code_end ~file_emitter = + match !sourcefile_for_dwarf with + | None -> () + | Some sourcefile -> + let asm_directives = build_asm_directives () in + let (module Asm_directives : Asm_targets.Asm_directives_intf.S) = asm_directives in + Asm_targets.Asm_label.initialize ~new_label:Cmm.new_label; + Asm_directives.initialize (); + let unit_name = + (* CR lmaurer: This doesn't actually need to be an [Ident.t] *) + Symbol.for_current_unit () + |> Symbol.linkage_name + |> Linkage_name.to_string + |> Ident.create_persistent + in + let code_begin = Asm_targets.Asm_symbol.create code_begin in + let code_end = Asm_targets.Asm_symbol.create code_end in + dwarf := Some (Dwarf.create + ~sourcefile + ~unit_name + ~asm_directives + ~get_file_id:(get_file_num ~file_emitter) + ~code_begin ~code_end) + + let reset_dwarf () = + dwarf := None; + sourcefile_for_dwarf := None + + let init ~disable_dwarf sourcefile = + reset_dwarf (); + let can_emit_dwarf = + !Clflags.debug + && not !Dwarf_flags.restrict_to_upstream_dwarf + && not disable_dwarf + in + match can_emit_dwarf, + Target_system.architecture (), + Target_system.derived_system () with + | true, X86_64, _ -> sourcefile_for_dwarf := Some sourcefile + | true, _, _ + | false, _, _ -> () + + let emit_dwarf () = Option.iter Dwarf_ocaml.Dwarf.emit !dwarf + + let record_dwarf_for_fundecl ~fun_name fun_dbg = + match !dwarf with + | None -> None + | Some dwarf -> + let label = Cmm.new_label () in + let fun_end_label = + Asm_targets.Asm_label.create_int Text label + in + let fundecl : Dwarf_concrete_instances.fundecl = + { fun_name; + fun_dbg; + fun_end_label; + } + in + Dwarf.dwarf_for_fundecl dwarf fundecl; + Some label +end + let report_error ppf = function | Stack_frame_too_large n -> - Format.fprintf ppf "stack frame too large (%d bytes)" n - + Format.fprintf ppf "stack frame too large (%d bytes). \n\ + Use -long-frames compiler flag." n + | Stack_frame_way_too_large n -> + Format.fprintf ppf "stack frame too large (%d bytes)." n diff --git a/backend/emitaux.mli b/backend/emitaux.mli index 0706fe87b21..0221ef348d7 100644 --- a/backend/emitaux.mli +++ b/backend/emitaux.mli @@ -105,6 +105,22 @@ val reduce_heap_size : reset:(unit -> unit) -> unit type error = | Stack_frame_too_large of int + | Stack_frame_way_too_large of int + +module Dwarf_helpers : sig + val init: disable_dwarf:bool -> string -> unit + + val begin_dwarf + : build_asm_directives:(unit -> (module Asm_targets.Asm_directives_intf.S)) + -> code_begin:string + -> code_end:string + -> file_emitter:(file_num:int -> file_name:string -> unit) + -> unit + + val emit_dwarf : unit -> unit + + val record_dwarf_for_fundecl : fun_name:string -> Debuginfo.t -> Cmm.label option +end exception Error of error val report_error: Format.formatter -> error -> unit diff --git a/backend/linear.ml b/backend/linear.ml index 8b20ac07420..68cda4ae031 100644 --- a/backend/linear.ml +++ b/backend/linear.ml @@ -45,7 +45,8 @@ and instruction_desc = let has_fallthrough = function | Lreturn | Lbranch _ | Lswitch _ | Lraise _ - | Lop Itailcall_ind | Lop (Itailcall_imm _) -> false + | Lop Itailcall_ind | Lop (Itailcall_imm _) + | Lop (Ipoll { return_label = Some _ }) -> false | _ -> true type fundecl = @@ -58,7 +59,6 @@ type fundecl = fun_num_stack_slots: int array; fun_frame_required: bool; fun_prologue_required: bool; - fun_end_label: label; } (* Invert a test *) diff --git a/backend/linear.mli b/backend/linear.mli index 8c79dd03395..56cb40136ac 100644 --- a/backend/linear.mli +++ b/backend/linear.mli @@ -59,7 +59,6 @@ type fundecl = fun_num_stack_slots: int array; fun_frame_required: bool; fun_prologue_required: bool; - fun_end_label: label; } val traps_to_bytes : int -> int diff --git a/backend/linearize.ml b/backend/linearize.ml index 7b70cd516dc..9e56e582ca3 100644 --- a/backend/linearize.ml +++ b/backend/linearize.ml @@ -168,6 +168,30 @@ let linear i n contains_calls = | Iop(Imove | Ireload | Ispill) when i.Mach.arg.(0).loc = i.Mach.res.(0).loc -> linear env i.Mach.next n + | Iop((Icsel _) as op) -> + (* CR gyorsh: this optimization can leave behind dead code + from computing the condition and the arguments, because there + is not dead code elimination after linearize. *) + let len = Array.length i.Mach.arg in + let ifso = i.Mach.arg.(len-2) in + let ifnot = i.Mach.arg.(len-1) in + if Reg.same_loc i.Mach.res.(0) ifso && + Reg.same_loc i.Mach.res.(0) ifnot + then linear env i.Mach.next n + else copy_instr (Lop op) i (linear env i.Mach.next n) + | Iop((Ipoll { return_label = None; _ }) as op) -> + (* If the poll call does not already specify where to jump to after + the poll (the expected situation in the current implementation), + absorb any branch after the poll call into the poll call itself. + This, in particular, optimises polls at the back edges of loops. *) + let n = linear env i.Mach.next n in + let op, n = + match n.desc with + | Lbranch lbl -> + Mach.Ipoll { return_label = Some lbl }, n.next + | _ -> op, n + in + copy_instr (Lop op) i n | Iop op -> copy_instr (Lop op) i (linear env i.Mach.next n) | Ireturn traps -> @@ -389,5 +413,4 @@ let fundecl f = fun_num_stack_slots; fun_frame_required; fun_prologue_required; - fun_end_label = Cmm.new_label () } diff --git a/backend/mach.ml b/backend/mach.ml index 4c9121b7b16..a9170ee9677 100644 --- a/backend/mach.ml +++ b/backend/mach.ml @@ -67,12 +67,16 @@ type operation = mode : Lambda.alloc_mode } | Iintop of integer_operation | Iintop_imm of integer_operation * int + | Iintop_atomic of { op : Cmm.atomic_op; size : Cmm.atomic_bitwidth; + addr : Arch.addressing_mode } | Icompf of float_comparison | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf + | Icsel of test | Ifloatofint | Iintoffloat | Ivalueofint | Iintofvalue | Iopaque | Ispecific of Arch.specific_operation + | Ipoll of { return_label: Cmm.label option } | Iname_for_debugger of { ident : Backend_var.t; which_parameter : int option; provenance : unit option; is_assignment : bool; } | Iprobe of { name: string; handler_code_sym: string; } @@ -107,6 +111,7 @@ type fundecl = fun_body: instruction; fun_codegen_options : Cmm.codegen_option list; fun_dbg : Debuginfo.t; + fun_poll: Lambda.poll_attribute; fun_num_stack_slots: int array; fun_contains_calls: bool; } @@ -173,21 +178,22 @@ let rec instr_iter f i = | Iconst_int _ | Iconst_float _ | Iconst_symbol _ | Icall_ind | Icall_imm _ | Iextcall _ | Istackoffset _ | Iload _ | Istore _ | Ialloc _ - | Iintop _ | Iintop_imm _ + | Iintop _ | Iintop_imm _ | Iintop_atomic _ | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf | Icompf _ + | Icsel _ | Ifloatofint | Iintoffloat | Ivalueofint | Iintofvalue | Ispecific _ | Iname_for_debugger _ | Iprobe _ | Iprobe_is_enabled _ | Iopaque - | Ibeginregion | Iendregion) -> + | Ibeginregion | Iendregion | Ipoll _) -> instr_iter f i.next let operation_is_pure = function | Icall_ind | Icall_imm _ | Itailcall_ind | Itailcall_imm _ - | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ + | Iextcall _ | Istackoffset _ | Istore _ | Ialloc _ | Ipoll _ | Iintop(Icheckbound) | Iintop_imm(Icheckbound, _) | Iopaque (* Conservative to ensure valueofint/intofvalue are not eliminated before emit. *) - | Ivalueofint | Iintofvalue -> false + | Ivalueofint | Iintofvalue | Iintop_atomic _ -> false | Ibeginregion | Iendregion -> false | Iprobe _ -> false | Iprobe_is_enabled _-> true @@ -198,6 +204,7 @@ let operation_is_pure = function | Ilsl | Ilsr | Iasr | Ipopcnt | Iclz _|Ictz _|Icomp _) | Imove | Ispill | Ireload | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf | Icompf _ + | Icsel _ | Ifloatofint | Iintoffloat | Iconst_int _ | Iconst_float _ | Iconst_symbol _ | Iload (_, _, _) | Iname_for_debugger _ @@ -214,14 +221,16 @@ let operation_can_raise op = | Ilsl | Ilsr | Iasr | Ipopcnt | Iclz _|Ictz _|Icomp _), _) | Iintop(Iadd | Isub | Imul | Imulh _ | Idiv | Imod | Iand | Ior | Ixor | Ilsl | Ilsr | Iasr | Ipopcnt | Iclz _|Ictz _|Icomp _) + | Iintop_atomic _ | Imove | Ispill | Ireload | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf | Icompf _ + | Icsel _ | Ifloatofint | Iintoffloat | Ivalueofint | Iintofvalue | Iconst_int _ | Iconst_float _ | Iconst_symbol _ | Istackoffset _ | Istore _ | Iload (_, _, _) | Iname_for_debugger _ | Itailcall_imm _ | Itailcall_ind | Iopaque | Ibeginregion | Iendregion - | Iprobe_is_enabled _ | Ialloc _ + | Iprobe_is_enabled _ | Ialloc _ | Ipoll _ -> false let free_conts_for_handlers fundecl = diff --git a/backend/mach.mli b/backend/mach.mli index 8b04f01c8b6..11c9c7644b7 100644 --- a/backend/mach.mli +++ b/backend/mach.mli @@ -71,12 +71,16 @@ type operation = mode: Lambda.alloc_mode } | Iintop of integer_operation | Iintop_imm of integer_operation * int + | Iintop_atomic of { op : Cmm.atomic_op; size : Cmm.atomic_bitwidth; + addr : Arch.addressing_mode } | Icompf of float_comparison | Inegf | Iabsf | Iaddf | Isubf | Imulf | Idivf + | Icsel of test | Ifloatofint | Iintoffloat | Ivalueofint | Iintofvalue | Iopaque | Ispecific of Arch.specific_operation + | Ipoll of { return_label: Cmm.label option } | Iname_for_debugger of { ident : Backend_var.t; which_parameter : int option; provenance : unit option; is_assignment : bool; } (** [Iname_for_debugger] has the following semantics: @@ -117,6 +121,7 @@ type fundecl = fun_body: instruction; fun_codegen_options : Cmm.codegen_option list; fun_dbg : Debuginfo.t; + fun_poll: Lambda.poll_attribute; fun_num_stack_slots: int array; fun_contains_calls: bool; } diff --git a/backend/polling.ml b/backend/polling.ml new file mode 100644 index 00000000000..c0991c27070 --- /dev/null +++ b/backend/polling.ml @@ -0,0 +1,336 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy and Damien Doligez, projet Cambium, INRIA Paris *) +(* Sadiq Jaffer, OCaml Labs Consultancy Ltd *) +(* Stephen Dolan and Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2021 OCaml Labs Consultancy Ltd *) +(* Copyright 2021 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Mach +open Format + +module Int = Numbers.Int +module String = Misc.Stdlib.String + +let function_is_assumed_to_never_poll func = + String.begins_with ~prefix:"caml_apply" func + || String.begins_with ~prefix:"caml_send" func + +(* These are used for the poll error annotation later on*) +type polling_point = Alloc | Poll | Function_call | External_call +type error = Poll_error of (polling_point * Debuginfo.t) list + +exception Error of error + +(* Detection of recursive handlers that are not guaranteed to poll + at every loop iteration. *) + +(* We use a backwards dataflow analysis to compute a mapping from handlers H + (= loop heads) to either "safe" or "unsafe". + + H is "safe" if every path starting from H goes through an Ialloc, + Ipoll, Ireturn, Itailcall_ind or Itailcall_imm instruction. + + H is "unsafe", therefore, if starting from H we can loop infinitely + without crossing an Ialloc or Ipoll instruction. +*) + +type unsafe_or_safe = Unsafe | Safe + +module Unsafe_or_safe = struct + type t = unsafe_or_safe + + let bot = Unsafe + + let join t1 t2 = + match t1, t2 with + | Unsafe, Unsafe + | Unsafe, Safe + | Safe, Unsafe -> Unsafe + | Safe, Safe -> Safe + + let lessequal t1 t2 = + match t1, t2 with + | Unsafe, Unsafe + | Unsafe, Safe + | Safe, Safe -> true + | Safe, Unsafe -> false +end + +module PolledLoopsAnalysis = Dataflow.Backward(Unsafe_or_safe) + +let polled_loops_analysis funbody = + let transfer i ~next ~exn = + match i.desc with + | Iend -> next + | Iop (Ialloc _ | Ipoll _) + | Iop (Itailcall_ind | Itailcall_imm _) -> Safe + | Iop op -> + if operation_can_raise op + then Unsafe_or_safe.join next exn + else next + | Ireturn _ -> Safe + | Iifthenelse _ | Iswitch _ | Icatch _ | Iexit _ | Itrywith _ -> next + | Iraise _ -> exn + in + (* [exnescape] is [Safe] because we can't loop infinitely having + returned from the function via an unhandled exception. *) + snd (PolledLoopsAnalysis.analyze ~exnescape:Safe ~transfer funbody) + +(* Detection of functions that can loop via a tail-call without going + through a poll point. *) + +(* We use a backwards dataflow analysis to compute a single value: either + "Might_not_poll" or "Always_polls". + + "Might_not_poll" means there exists a path from the function entry to a + Potentially Recursive Tail Call (an Itailcall_ind or + Itailcall_imm to a forward function) + that does not go through an Ialloc or Ipoll instruction. + + "Always_polls", therefore, means the function always polls (via Ialloc or + Ipoll) before doing a PRTC. +*) + +type polls_before_prtc = Might_not_poll | Always_polls + +module Polls_before_prtc = struct + type t = polls_before_prtc + + let bot = Always_polls + + let join t1 t2 = + match t1, t2 with + | Might_not_poll, Might_not_poll + | Might_not_poll, Always_polls + | Always_polls, Might_not_poll -> Might_not_poll + | Always_polls, Always_polls -> Always_polls + + let lessequal t1 t2 = + match t1, t2 with + | Always_polls, Always_polls + | Always_polls, Might_not_poll + | Might_not_poll, Might_not_poll -> true + | Might_not_poll, Always_polls -> false +end + +module PTRCAnalysis = Dataflow.Backward(Polls_before_prtc) + +let potentially_recursive_tailcall ~future_funcnames funbody = + let transfer i ~next ~exn = + match i.desc with + | Iend -> next + | Iop (Ialloc _ | Ipoll _) -> Always_polls + | Iop (Itailcall_ind) -> Might_not_poll + | Iop (Itailcall_imm { func }) -> + (* We optimise by making a partial ordering over Mach functions: in + definition order within a compilation unit, and dependency order + between compilation units. This order is acyclic, as OCaml does not + allow circular dependencies between modules. It's also finite, so if + there's an infinite sequence of function calls then something has to + make a forward reference. + + Also, in such an infinite sequence of function calls, at most finitely + many of them can be non-tail calls. (If there are infinitely many + non-tail calls, then the program soon terminates with a stack + overflow). + + So, every such infinite sequence must contain many forward-referencing + tail calls, so polling only on those suffices. This is checked using + the set [future_funcnames]. *) + if String.Set.mem func future_funcnames + || function_is_assumed_to_never_poll func + then Might_not_poll + else Always_polls + | Iop op -> + if operation_can_raise op + then Polls_before_prtc.join next exn + else next + | Ireturn _ -> Always_polls + | Iifthenelse _ | Iswitch _ | Icatch _ | Iexit _ | Itrywith _ -> next + | Iraise _ -> exn + in + fst (PTRCAnalysis.analyze ~transfer funbody) + +(* We refer to the set of recursive handler labels that need extra polling + as the "unguarded back edges" ("ube"). + + Given the result of the analysis of recursive handlers, add [Ipoll] + instructions at the [Iexit] instructions before unguarded back edges, + thus ensuring that every loop contains a poll point. Also compute whether + the resulting function contains any [Ipoll] instructions. +*) + +let contains_polls = ref false + +let add_poll i = + contains_polls := true; + Mach.instr_cons_debug (Iop (Ipoll { return_label = None })) [||] [||] i.dbg i + +let instr_body handler_safe i = + let add_unsafe_handler ube (k, _trap_stack, _) = + match handler_safe k with + | Safe -> ube + | Unsafe -> Int.Set.add k ube + in + let rec instr ube i = + match i.desc with + | Iifthenelse (test, i0, i1) -> + { i with + desc = Iifthenelse (test, instr ube i0, instr ube i1); + next = instr ube i.next; + } + | Iswitch (index, cases) -> + { i with + desc = Iswitch (index, Array.map (instr ube) cases); + next = instr ube i.next; + } + | Icatch (rc, trap_stack, hdl, body) -> + let ube' = + match rc with + | Cmm.Recursive -> List.fold_left add_unsafe_handler ube hdl + | Cmm.Nonrecursive -> ube in + let instr_handler (k, trap_stack, i0) = + let i1 = instr ube' i0 in + (k, trap_stack, i1) in + (* Since we are only interested in unguarded _back_ edges, we don't + use [ube'] for instrumenting [body], but just [ube] instead. *) + let body = instr ube body in + { i with + desc = Icatch (rc, + trap_stack, + List.map instr_handler hdl, + body); + next = instr ube i.next; + } + | Iexit (k, _trap_actions) -> + if Int.Set.mem k ube + then add_poll i + else i + | Itrywith (body, kind, (trap_stack, hdl)) -> + { i with + desc = Itrywith (instr ube body, kind, (trap_stack, instr ube hdl)); + next = instr ube i.next; + } + | Iend | Ireturn _ | Iraise _ -> i + | Iop op -> + begin match op with + | Ipoll _ -> contains_polls := true + | _ -> () + end; + { i with next = instr ube i.next } + in + instr Int.Set.empty i + +let find_poll_alloc_or_calls instr = + let f_match i = + match i.desc with + | Iop(Ipoll _) -> Some (Poll, i.dbg) + | Iop(Ialloc _) -> Some (Alloc, i.dbg) + | Iop(Icall_ind | Icall_imm _ | + Itailcall_ind | Itailcall_imm _ ) -> Some (Function_call, i.dbg) + | Iop(Iextcall { alloc = true }) -> Some (External_call, i.dbg) + | Iop(Imove | Ispill | Ireload | Iconst_int _ | Iconst_float _ | + Iconst_symbol _ | Iextcall { alloc = false } | Istackoffset _ | + Iload _ | Istore _ | Iintop _ | Iintop_imm _ | Iintop_atomic _ | + Ifloatofint | Iintoffloat | Inegf | Iabsf | Iaddf | Isubf | + Imulf | Idivf | Iopaque | Ispecific _ | Ibeginregion | Iendregion | + Icsel _ | Icompf _ | Iname_for_debugger _ | Iprobe _ | + Iprobe_is_enabled _ | Ivalueofint | Iintofvalue)-> None + | Iend | Ireturn _ | Iifthenelse _ | Iswitch _ | Icatch _ | Iexit _ | + Itrywith _ | Iraise _ -> None + in + let matches = ref [] in + Mach.instr_iter + (fun i -> + match f_match i with + | Some(x) -> matches := x :: !matches + | None -> ()) + instr; + List.rev !matches + +let is_disabled fun_name = + (not Config.poll_insertion) || + !Flambda_backend_flags.disable_poll_insertion || + function_is_assumed_to_never_poll fun_name + +let instrument_fundecl ~future_funcnames:_ (f : Mach.fundecl) : Mach.fundecl = + if is_disabled f.fun_name then f + else begin + let handler_needs_poll = polled_loops_analysis f.fun_body in + contains_polls := false; + let new_body = instr_body handler_needs_poll f.fun_body in + begin match f.fun_poll with + | Error_poll -> begin + match find_poll_alloc_or_calls new_body with + | [] -> () + | poll_error_instrs -> raise (Error(Poll_error poll_error_instrs)) + end + | Default_poll -> () end; + let new_contains_calls = f.fun_contains_calls || !contains_polls in + { f with fun_body = new_body; fun_contains_calls = new_contains_calls } + end + +let requires_prologue_poll ~future_funcnames ~fun_name i = + if is_disabled fun_name then false + else + match potentially_recursive_tailcall ~future_funcnames i with + | Might_not_poll -> true + | Always_polls -> false + +(* Error report *) + +let instr_type p = + match p with + | Poll -> "inserted poll" + | Alloc -> "allocation" + | Function_call -> "function call" + | External_call -> "external call that allocates" + +let report_error ppf = function +| Poll_error instrs -> + begin + let num_inserted_polls = + List.fold_left + (fun s (p,_) -> s + match p with Poll -> 1 + | Alloc | Function_call | External_call -> 0 + ) 0 instrs in + let num_user_polls = (List.length instrs) - num_inserted_polls in + if num_user_polls = 0 then + fprintf ppf "Function with poll-error attribute contains polling \ + points (inserted by the compiler)\n" + else begin + fprintf ppf + "Function with poll-error attribute contains polling points:\n"; + List.iter (fun (p,dbg) -> + begin match p with + | Poll -> () + | Alloc | Function_call | External_call -> + fprintf ppf "\t%s at " (instr_type p); + Location.print_loc ppf (Debuginfo.to_location dbg); + fprintf ppf "\n" + end + ) instrs; + if num_inserted_polls > 0 then + fprintf ppf "\t(plus compiler-inserted polling point(s) in prologue \ + and/or loop back edges)\n" + end + end + +let () = + Location.register_error_of_exn + (function + | Error err -> Some (Location.error_of_printer_file report_error err) + | _ -> None + ) diff --git a/backend/polling.mli b/backend/polling.mli new file mode 100644 index 00000000000..c4629a78a5a --- /dev/null +++ b/backend/polling.mli @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy and Damien Doligez, projet Cambium, INRIA Paris *) +(* Sadiq Jaffer, OCaml Labs Consultancy Ltd *) +(* Stephen Dolan and Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2021 OCaml Labs Consultancy Ltd *) +(* Copyright 2021 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Analyses related to the insertion of [Ipoll] operations. *) + +val instrument_fundecl : future_funcnames:Misc.Stdlib.String.Set.t + -> Mach.fundecl -> Mach.fundecl + +val requires_prologue_poll : future_funcnames:Misc.Stdlib.String.Set.t + -> fun_name:string -> Mach.instruction -> bool diff --git a/backend/printcmm.ml b/backend/printcmm.ml index 2aaa14f9ad1..9f6f97e8c9a 100644 --- a/backend/printcmm.ml +++ b/backend/printcmm.ml @@ -95,12 +95,21 @@ let chunk = function | Single -> "float32" | Double -> "float64" +let atomic_bitwidth : Cmm.atomic_bitwidth -> string = function + | Word -> "int" + | Thirtytwo -> "int32" + | Sixtyfour -> "int64" + let temporal_locality = function | Nonlocal -> "nonlocal" | Low -> "low" | Moderate -> "moderate" | High -> "high" +let atomic_op = function + | Fetch_and_add -> "fetch_and_add" + | Compare_and_swap -> "compare_and_swap" + let phantom_defining_expr ppf defining_expr = match defining_expr with | Cphantom_const_int i -> Targetint.print ppf i @@ -150,6 +159,14 @@ let trywith_kind ppf kind = | Regular -> () | Delayed i -> fprintf ppf "" i +let to_string msg = + let b = Buffer.create 17 in + let ppf = Format.formatter_of_buffer b in + Format.kfprintf (fun ppf -> + Format.pp_print_flush ppf (); + Buffer.contents b + ) ppf msg + let operation d = function | Capply(_ty, _) -> "app" ^ location d | Cextcall { func = lbl; _ } -> @@ -193,6 +210,8 @@ let operation d = function | Csubf -> "-f" | Cmulf -> "*f" | Cdivf -> "/f" + | Ccsel ret_typ -> + to_string "csel %a" machtype ret_typ | Cfloatofint -> "floatofint" | Cintoffloat -> "intoffloat" | Cvalueofint -> "valueofint" @@ -206,6 +225,7 @@ let operation d = function | Cprefetch { is_write; locality; } -> Printf.sprintf "prefetch is_write=%b prefetch_temporal_locality_hint=%s" is_write (temporal_locality locality) + | Catomic { op; size = _ } -> Printf.sprintf "atomic %s" (atomic_op op) | Copaque -> "opaque" | Cbeginregion -> "beginregion" | Cendregion -> "endregion" diff --git a/backend/printcmm.mli b/backend/printcmm.mli index 4f8f14b3c86..d596782ad23 100644 --- a/backend/printcmm.mli +++ b/backend/printcmm.mli @@ -27,6 +27,7 @@ val float_comparison : Cmm.float_comparison -> string val trap_action_list : formatter -> Cmm.trap_action list -> unit val trywith_kind : formatter -> Cmm.trywith_kind -> unit val chunk : Cmm.memory_chunk -> string +val atomic_bitwidth : Cmm.atomic_bitwidth -> string val operation : Debuginfo.t -> Cmm.operation -> string val expression : formatter -> Cmm.expression -> unit val fundecl : formatter -> Cmm.fundecl -> unit diff --git a/backend/printlinear.ml b/backend/printlinear.ml index 83b936a76d1..3373651d175 100644 --- a/backend/printlinear.ml +++ b/backend/printlinear.ml @@ -34,7 +34,7 @@ let instr' ?(print_reg = Printmach.reg) ppf i = fprintf ppf "prologue" | Lop op -> begin match op with - | Ialloc _ | Icall_ind | Icall_imm _ | Iextcall _ | Iprobe _ -> + | Ialloc _ | Ipoll _ | Icall_ind | Icall_imm _ | Iextcall _ | Iprobe _ -> fprintf ppf "@[<1>{%a}@]@," regsetaddr i.live | _ -> () end; diff --git a/backend/printmach.ml b/backend/printmach.ml index 63b5b09b191..b40cb099ba2 100644 --- a/backend/printmach.ml +++ b/backend/printmach.ml @@ -179,6 +179,16 @@ let operation' ?(print_reg = reg) op arg ppf res = fprintf ppf "%a%s%a" reg arg.(0) (intop op) reg arg.(1) end | Iintop_imm(op, n) -> fprintf ppf "%a%s%i" reg arg.(0) (intop op) n + | Iintop_atomic {op = Compare_and_swap; size; addr} -> + fprintf ppf "lock cas %s[%a] ?%a %a" + (Printcmm.atomic_bitwidth size) + (Arch.print_addressing reg addr) (Array.sub arg 2 (Array.length arg - 2)) + reg arg.(0) reg arg.(1) + | Iintop_atomic {op = Fetch_and_add; size; addr} -> + fprintf ppf "lock %s[%a] += %a" + (Printcmm.atomic_bitwidth size) + (Arch.print_addressing reg addr) (Array.sub arg 1 (Array.length arg - 1)) + reg arg.(0) | Icompf cmp -> fprintf ppf "%a%s%a" reg arg.(0) (floatcomp cmp) reg arg.(1) | Inegf -> fprintf ppf "-f %a" reg arg.(0) | Iabsf -> fprintf ppf "absf %a" reg arg.(0) @@ -186,6 +196,10 @@ let operation' ?(print_reg = reg) op arg ppf res = | Isubf -> fprintf ppf "%a -f %a" reg arg.(0) reg arg.(1) | Imulf -> fprintf ppf "%a *f %a" reg arg.(0) reg arg.(1) | Idivf -> fprintf ppf "%a /f %a" reg arg.(0) reg arg.(1) + | Icsel tst -> + let len = Array.length arg in + fprintf ppf "csel %a ? %a : %a" + (test tst) arg reg arg.(len-2) reg arg.(len-1) | Ifloatofint -> fprintf ppf "floatofint %a" reg arg.(0) | Iintoffloat -> fprintf ppf "intoffloat %a" reg arg.(0) | Ivalueofint -> fprintf ppf "valueofint %a" reg arg.(0) @@ -202,6 +216,12 @@ let operation' ?(print_reg = reg) op arg ppf res = | Iendregion -> fprintf ppf "endregion %a" reg arg.(0) | Ispecific op -> Arch.print_specific_operation reg op ppf arg + | Ipoll { return_label } -> + fprintf ppf "poll call"; + (match return_label with + | None -> () + | Some return_label -> + fprintf ppf " returning to L%d" return_label) | Iprobe {name;handler_code_sym} -> fprintf ppf "probe \"%s\" %s %a" name handler_code_sym regs arg | Iprobe_is_enabled {name} -> fprintf ppf "probe_is_enabled \"%s\"" name @@ -213,6 +233,7 @@ let rec instr ppf i = fprintf ppf "@[<1>{%a" regsetaddr i.live; if Array.length i.arg > 0 then fprintf ppf "@ +@ %a" regs i.arg; fprintf ppf "}@]@,"; + (* CR-someday mshinwell: to use for gdb work if !Clflags.dump_avail then begin let module RAS = Reg_availability_set in fprintf ppf "@[<1>AB={%a}" (RAS.print ~print_reg:reg) i.available_before; @@ -222,7 +243,7 @@ let rec instr ppf i = fprintf ppf ",AA={%a}" (RAS.print ~print_reg:reg) available_across end; fprintf ppf "@]@," - end + end *) end; begin match i.desc with | Iend -> () diff --git a/backend/reloadgen.ml b/backend/reloadgen.ml index f971bb11b79..d5ca5521b3d 100644 --- a/backend/reloadgen.ml +++ b/backend/reloadgen.ml @@ -152,6 +152,7 @@ method fundecl f num_stack_slots = ({fun_name = f.fun_name; fun_args = f.fun_args; fun_body = new_body; fun_codegen_options = f.fun_codegen_options; fun_dbg = f.fun_dbg; + fun_poll = f.fun_poll; fun_contains_calls = f.fun_contains_calls; fun_num_stack_slots = Array.copy num_stack_slots; }, diff --git a/backend/schedgen.ml b/backend/schedgen.ml index 6abf748174f..7603cf09d9d 100644 --- a/backend/schedgen.ml +++ b/backend/schedgen.ml @@ -154,7 +154,7 @@ method oper_in_basic_block = function | Itailcall_imm _ -> false | Iextcall _ -> false | Istackoffset _ -> false - | Ialloc _ -> false + | Ialloc _ | Ipoll _ -> false | Iprobe _ -> false | _ -> true @@ -397,7 +397,6 @@ method schedule_fundecl f = fun_num_stack_slots = f.fun_num_stack_slots; fun_frame_required = f.fun_frame_required; fun_prologue_required = f.fun_prologue_required; - fun_end_label = Cmm.new_label () } end else f diff --git a/backend/selectgen.ml b/backend/selectgen.ml index 3321f467370..63bfc87cdfc 100644 --- a/backend/selectgen.ml +++ b/backend/selectgen.ml @@ -174,6 +174,7 @@ let oper_result_type = function | Calloc _ -> typ_val | Cstore (_c, _) -> typ_void | Cprefetch _ -> typ_void + | Catomic _ -> typ_int | Caddi | Csubi | Cmuli | Cmulhi _ | Cdivi | Cmodi | Cand | Cor | Cxor | Clsl | Clsr | Casr | Cclz _ | Cctz _ | Cpopcnt | @@ -182,6 +183,7 @@ let oper_result_type = function | Caddv -> typ_val | Cadda -> typ_addr | Cnegf | Cabsf | Caddf | Csubf | Cmulf | Cdivf -> typ_float + | Ccsel ty -> ty | Cfloatofint -> typ_float | Cintoffloat -> typ_int | Cvalueofint -> typ_val @@ -450,7 +452,7 @@ method is_simple_expr = function List.for_all self#is_simple_expr args (* The following may have side effects *) | Capply _ | Cextcall _ | Calloc _ | Cstore _ - | Craise _ | Ccheckbound + | Craise _ | Ccheckbound | Catomic _ | Cprobe _ | Cprobe_is_enabled _ | Copaque -> false | Cprefetch _ | Cbeginregion | Cendregion -> false (* avoid reordering *) (* The remaining operations are simple if their args are *) @@ -458,6 +460,7 @@ method is_simple_expr = function | Cxor | Clsl | Clsr | Casr | Ccmpi _ | Caddv | Cadda | Ccmpa _ | Cnegf | Cclz _ | Cctz _ | Cpopcnt | Cbswap _ + | Ccsel _ | Cabsf | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat | Cvalueofint | Cintofvalue | Ccmpf _ -> List.for_all self#is_simple_expr args @@ -502,12 +505,14 @@ method effects_of exp = | Cstore _ -> EC.effect_only Effect.Arbitrary | Cbeginregion | Cendregion -> EC.arbitrary | Cprefetch _ -> EC.arbitrary + | Catomic _ -> EC.arbitrary | Craise _ | Ccheckbound -> EC.effect_only Effect.Raise | Cload (_, Asttypes.Immutable) -> EC.none | Cload (_, Asttypes.Mutable) -> EC.coeffect_only Coeffect.Read_mutable | Cprobe_is_enabled _ -> EC.coeffect_only Coeffect.Arbitrary | Caddi | Csubi | Cmuli | Cmulhi _ | Cdivi | Cmodi | Cand | Cor | Cxor | Cbswap _ + | Ccsel _ | Cclz _ | Cctz _ | Cpopcnt | Clsl | Clsr | Casr | Ccmpi _ | Caddv | Cadda | Ccmpa _ | Cnegf | Cabsf | Caddf | Csubf | Cmulf | Cdivf | Cfloatofint | Cintoffloat @@ -557,9 +562,9 @@ method mark_instr = function self#mark_call | Iop (Itailcall_ind | Itailcall_imm _) -> self#mark_tailcall - | Iop (Ialloc _) -> - self#mark_call (* caml_alloc*, caml_garbage_collection *) - | Iop (Iintop(Icheckbound) | Iintop_imm(Icheckbound, _)) -> + | Iop (Ialloc _) | Iop (Ipoll _) -> + self#mark_call (* caml_alloc*, caml_garbage_collection (incl. polls) *) + | Iop (Iintop (Icheckbound) | Iintop_imm(Icheckbound, _)) -> self#mark_c_tailcall (* caml_ml_array_bound_error *) | Iraise raise_kind -> begin match raise_kind with @@ -626,6 +631,9 @@ method select_operation op args _dbg = | (Cadda, _) -> self#select_arith_comm Iadd args | (Ccmpa comp, _) -> self#select_arith_comp (Iunsigned comp) args | (Ccmpf comp, _) -> (Icompf comp, args) + | (Ccsel _, [cond; ifso; ifnot]) -> + let (cond, earg) = self#select_condition cond in + (Icsel cond, [ earg; ifso; ifnot ]) | (Cnegf, _) -> (Inegf, args) | (Cabsf, _) -> (Iabsf, args) | (Caddf, _) -> (Iaddf, args) @@ -636,6 +644,14 @@ method select_operation op args _dbg = | (Cintoffloat, _) -> (Iintoffloat, args) | (Cvalueofint, _) -> (Ivalueofint, args) | (Cintofvalue, _) -> (Iintofvalue, args) + | (Catomic {op = Fetch_and_add; size}, [src; dst]) -> + let dst_size = match size with Word | Sixtyfour -> Word_int | Thirtytwo -> Thirtytwo_signed in + let (addr, eloc) = self#select_addressing dst_size dst in + (Iintop_atomic { op = Fetch_and_add; size; addr }, [src; eloc]) + | (Catomic {op = Compare_and_swap; size}, [compare_with; set_to; dst]) -> + let dst_size = match size with Word | Sixtyfour -> Word_int | Thirtytwo -> Thirtytwo_signed in + let (addr, eloc) = self#select_addressing dst_size dst in + (Iintop_atomic { op = Compare_and_swap; size; addr }, [compare_with; set_to; eloc]) | (Ccheckbound, _) -> self#select_arith Icheckbound args | (Cprobe { name; handler_code_sym; }, _) -> @@ -711,12 +727,15 @@ method insert_debug _env desc dbg arg res = method insert _env desc arg res = instr_seq <- instr_cons desc arg res instr_seq -method extract = +method extract_onto o = let rec extract res i = if i == dummy_instr - then res - else extract {i with next = res} i.next in - extract (end_instr ()) instr_seq + then res + else extract {i with next = res} i.next in + extract o instr_seq + +method extract = + self#extract_onto (end_instr ()) (* Insert a sequence of moves from one pseudoreg set to another. *) @@ -1050,9 +1069,12 @@ method emit_expr (env:environment) exp = end | Ctrywith(e1, kind, v, e2, _dbg, _value_kind) -> (* This region is used only to clean up local allocations in the - exceptional path. It need not be ended in the non-exception case. *) + exceptional path. It must not be ended in the non-exception case + as local allocations may be returned from the body of the "try". *) let end_region = - if Config.stack_allocation then begin + if Config.stack_allocation + && match kind with Regular -> true | Delayed _ -> false + then begin let reg = self#regs_for typ_int in self#insert env (Iop Ibeginregion) [| |] reg; fun handler_instruction -> instr_cons (Iop Iendregion) reg [| |] handler_instruction @@ -1535,7 +1557,7 @@ method private emit_tail_sequence env exp = (* Sequentialization of a function definition *) -method emit_fundecl f = +method emit_fundecl ~future_funcnames f = current_function_name := f.Cmm.fun_name; let rargs = List.map @@ -1547,15 +1569,27 @@ method emit_fundecl f = List.fold_right2 (fun (id, _ty) r env -> env_add id r env) f.Cmm.fun_args rargs env_empty in - self#insert_moves env loc_arg rarg; self#emit_tail env f.Cmm.fun_body; let body = self#extract in - instr_iter (fun instr -> self#mark_instr instr.Mach.desc) body; + instr_seq <- dummy_instr; + self#insert_moves env loc_arg rarg; + let polled_body = + if Polling.requires_prologue_poll ~future_funcnames + ~fun_name:f.Cmm.fun_name body + then + instr_cons_debug + (Iop(Ipoll { return_label = None })) [||] [||] f.Cmm.fun_dbg body + else + body + in + let body_with_prologue = self#extract_onto polled_body in + instr_iter (fun instr -> self#mark_instr instr.Mach.desc) body_with_prologue; { fun_name = f.Cmm.fun_name; fun_args = loc_arg; - fun_body = body; + fun_body = body_with_prologue; fun_codegen_options = f.Cmm.fun_codegen_options; fun_dbg = f.Cmm.fun_dbg; + fun_poll = f.Cmm.fun_poll; fun_num_stack_slots = Array.make Proc.num_register_classes 0; fun_contains_calls = !contains_calls; } diff --git a/backend/selectgen.mli b/backend/selectgen.mli index fda57ea267e..f9312129c78 100644 --- a/backend/selectgen.mli +++ b/backend/selectgen.mli @@ -142,12 +142,14 @@ class virtual selector_generic : object above; overloading this is useful if Ispecific instructions need marking *) - (* The following method is the entry point and should not be overridden. *) - method emit_fundecl : Cmm.fundecl -> Mach.fundecl + (* The following method is the entry point and should not be overridden *) + method emit_fundecl : future_funcnames:Misc.Stdlib.String.Set.t + -> Cmm.fundecl -> Mach.fundecl (* The following methods should not be overridden. They cannot be declared "private" in the current implementation because they are not always applied to "self", but ideally they should be private. *) + method extract_onto : Mach.instruction -> Mach.instruction method extract : Mach.instruction method insert : environment -> Mach.instruction_desc -> Reg.t array -> Reg.t array -> unit diff --git a/backend/selection.mli b/backend/selection.mli index 3c055fe0330..0a0680bdcf7 100644 --- a/backend/selection.mli +++ b/backend/selection.mli @@ -16,4 +16,5 @@ (* Selection of pseudo-instructions, assignment of pseudo-registers, sequentialization. *) -val fundecl: Cmm.fundecl -> Mach.fundecl +val fundecl: future_funcnames:Misc.Stdlib.String.Set.t + -> Cmm.fundecl -> Mach.fundecl diff --git a/backend/spill.ml b/backend/spill.ml index 8d4cb29e6c1..d58dc64fb04 100644 --- a/backend/spill.ml +++ b/backend/spill.ml @@ -633,6 +633,7 @@ let fundecl f = fun_args = f.fun_args; fun_body = new_body; fun_codegen_options = f.fun_codegen_options; + fun_poll = f.fun_poll; fun_dbg = f.fun_dbg; fun_num_stack_slots = f.fun_num_stack_slots; fun_contains_calls = f.fun_contains_calls; diff --git a/backend/split.ml b/backend/split.ml index 8a18504e041..6e62e4a0d7b 100644 --- a/backend/split.ml +++ b/backend/split.ml @@ -222,6 +222,7 @@ let fundecl f = fun_args = new_args; fun_body = new_body; fun_codegen_options = f.fun_codegen_options; + fun_poll = f.fun_poll; fun_dbg = f.fun_dbg; fun_num_stack_slots = f.fun_num_stack_slots; fun_contains_calls = f.fun_contains_calls; diff --git a/backend/x86_ast.mli b/backend/x86_ast.mli index 86550a4d9b7..25c054f2f12 100644 --- a/backend/x86_ast.mli +++ b/backend/x86_ast.mli @@ -172,6 +172,8 @@ type instruction = | J of condition * arg | JMP of arg | LEA of arg * arg + | LOCK_CMPXCHG of arg * arg + | LOCK_XADD of arg * arg | LEAVE | MAXSD of arg * arg | MINSD of arg * arg @@ -196,8 +198,8 @@ type instruction = | PUSH of arg | RDTSC | RDPMC - | LFENCE - | SFENCE + | LFENCE + | SFENCE | MFENCE | RET | ROUNDSD of rounding * arg * arg diff --git a/backend/x86_binary_emitter.ml b/backend/x86_binary_emitter.ml index 1c8ec39d7d3..8827322923a 100644 --- a/backend/x86_binary_emitter.ml +++ b/backend/x86_binary_emitter.ml @@ -12,7 +12,7 @@ * Fabrice LE FESSANT (INRIA/OCamlPro) *) -[@@@ocaml.warning "+A-4-9"] +[@@@ocaml.warning "+A-4-9-69"] open X86_ast open X86_proc @@ -1220,6 +1220,30 @@ let emit_LEA b dst src = Format.eprintf "lea src=%a dst=%a@." print_old_arg src print_old_arg dst; assert false +let emit_lock_cmpxchg b dst src = + let rex, rm, reg = match (dst, src) with + | ((Mem _ | Mem64_RIP _) as rm), Reg64 reg -> + rexw, rm, rd_of_reg64 reg + | ((Mem _ | Mem64_RIP _) as rm), Reg32 reg -> + no_rex, rm, rd_of_reg64 reg + | _ -> + Misc.fatal_errorf "lock cmpxchg src=%a dst=%a@." print_old_arg src print_old_arg dst + in + buf_int8 b 0xF0; + emit_mod_rm_reg b rex [ 0x0F; 0xB1 ] rm reg + +let emit_lock_xadd b dst src = + let rex, rm, reg = match (dst, src) with + | ((Mem _ | Mem64_RIP _) as rm), Reg64 reg -> + rexw, rm, rd_of_reg64 reg + | ((Mem _ | Mem64_RIP _) as rm), Reg32 reg -> + no_rex, rm, rd_of_reg64 reg + | _ -> + Misc.fatal_errorf "lock cmpxchg src=%a dst=%a@." print_old_arg src print_old_arg dst + in + buf_int8 b 0xF0; + emit_mod_rm_reg b rex [ 0x0F; 0xC1 ] rm reg + let emit_stack_reg b opcode dst = match dst with | Reg64 reg -> @@ -1537,6 +1561,8 @@ let assemble_instr b loc = function | JMP dst -> emit_jmp b !loc dst | LEAVE -> emit_leave b | LEA (src, dst) -> emit_LEA b dst src + | LOCK_CMPXCHG (src, dst) -> emit_lock_cmpxchg b dst src + | LOCK_XADD (src, dst) -> emit_lock_xadd b dst src | MAXSD (src, dst) -> emit_maxsd b ~dst ~src | MINSD (src, dst) -> emit_minsd b ~dst ~src | MOV (src, dst) -> emit_MOV b dst src @@ -1677,7 +1703,7 @@ let assemble_section arch section = let icount = ref 0 in ArrayLabels.iter section.sec_instrs ~f:(function | NewLabel (lbl, _) -> - String.Tbl.add local_labels lbl !icount + String.Tbl.add local_labels lbl !icount | Ins _ -> incr icount | _ -> ()); diff --git a/backend/x86_dsl.ml b/backend/x86_dsl.ml index 3770214574d..e99711898e8 100644 --- a/backend/x86_dsl.ml +++ b/backend/x86_dsl.ml @@ -123,6 +123,7 @@ module I = struct let bswap x = emit (BSWAP x) let call x = emit (CALL x) let cdq () = emit CDQ + let cmov cond x y = emit (CMOV (cond, x, y)) let cmp x y = emit (CMP (x, y)) let cmpsd cond x y = emit (CMPSD (cond, x, y)) let comisd x y = emit (COMISD (x, y)) @@ -185,6 +186,8 @@ module I = struct let jne = j NE let jp = j P let lea x y = emit (LEA (x, y)) + let lock_cmpxchg x y = emit (LOCK_CMPXCHG (x, y)) + let lock_xadd x y = emit (LOCK_XADD (x, y)) let maxsd x y = emit (MAXSD (x,y)) let minsd x y = emit (MINSD (x,y)) let mov x y = emit (MOV (x, y)) diff --git a/backend/x86_dsl.mli b/backend/x86_dsl.mli index e5c6f8bf86d..f00f56f285c 100644 --- a/backend/x86_dsl.mli +++ b/backend/x86_dsl.mli @@ -118,6 +118,7 @@ module I : sig val bswap: arg -> unit val call: arg -> unit val cdq: unit -> unit + val cmov : condition -> arg -> arg -> unit val cmp: arg -> arg -> unit val cmpsd : float_condition -> arg -> arg -> unit val comisd: arg -> arg -> unit @@ -180,6 +181,8 @@ module I : sig val jne: arg -> unit val jp: arg -> unit val lea: arg -> arg -> unit + val lock_cmpxchg: arg -> arg -> unit + val lock_xadd: arg -> arg -> unit val maxsd: arg -> arg -> unit val minsd: arg -> arg -> unit val mov: arg -> arg -> unit diff --git a/backend/x86_gas.ml b/backend/x86_gas.ml index be66a23e2b6..f8b93745bfc 100644 --- a/backend/x86_gas.ml +++ b/backend/x86_gas.ml @@ -106,6 +106,7 @@ let i1 b s x = bprintf b "\t%s\t%a" s arg x let i1_s b s x = bprintf b "\t%s%s\t%a" s (suf x) arg x let i2 b s x y = bprintf b "\t%s\t%a, %a" s arg x arg y let i2_s b s x y = bprintf b "\t%s%s\t%a, %a" s (suf y) arg x arg y +let i2_sx b s x y = bprintf b "\t%s%s\t%a, %a" s (suf x) arg x arg y let i2_ss b s x y = bprintf b "\t%s%s%s\t%a, %a" s (suf x) (suf y) arg x arg y let i3 b s x y z = bprintf b "\t%s\t%a, %a, %a" s arg x arg y arg z @@ -191,6 +192,8 @@ let print_instr b = function | J (c, arg) -> i1_call_jmp b ("j" ^ string_of_condition c) arg | JMP arg -> i1_call_jmp b "jmp" arg | LEA (arg1, arg2) -> i2_s b "lea" arg1 arg2 + | LOCK_CMPXCHG (arg1, arg2) -> i2_sx b "lock cmpxchg" arg1 arg2 + | LOCK_XADD (arg1, arg2) -> i2_sx b "lock xadd" arg1 arg2 | LEAVE -> i0 b "leave" | MAXSD (arg1, arg2) -> i2 b "maxsd" arg1 arg2 | MINSD (arg1, arg2) -> i2 b "minsd" arg1 arg2 diff --git a/backend/x86_masm.ml b/backend/x86_masm.ml index ece4b566173..0c691eb56fb 100644 --- a/backend/x86_masm.ml +++ b/backend/x86_masm.ml @@ -182,6 +182,8 @@ let print_instr b = function | J (c, arg) -> i1_call_jmp b ("j" ^ string_of_condition c) arg | JMP arg -> i1_call_jmp b "jmp" arg | LEA (arg1, arg2) -> i2 b "lea" arg1 arg2 + | LOCK_CMPXCHG (arg1, arg2) -> i2 b "lock cmpxchg" arg1 arg2 + | LOCK_XADD (arg1, arg2) -> i2 b "lock xadd" arg1 arg2 | LEAVE -> i0 b "leave" | MAXSD (arg1, arg2) -> i2 b "maxsd" arg1 arg2 | MINSD (arg1, arg2) -> i2 b "minsd" arg1 arg2 diff --git a/build_ocaml_compiler.sexp b/build_ocaml_compiler.sexp index 4f286334f57..473d6777fbc 100644 --- a/build_ocaml_compiler.sexp +++ b/build_ocaml_compiler.sexp @@ -8,16 +8,19 @@ uses_autoconf is_flambda_backend build_m32_from_upstream + stack_allocation_by_default )) (features ( normal frame_pointers m32 no_naked_pointers + naked_pointers_checker flambda flambda2 no_flat_float_array perf_demangled_symbols stack_allocation + poll_insertion )) ) diff --git a/configure.ac b/configure.ac index a3701b652df..a4b72cd275f 100644 --- a/configure.ac +++ b/configure.ac @@ -1,6 +1,6 @@ AC_PREREQ([2.69]) AC_INIT([The Flambda backend for OCaml], - 4.11.1+dev0-2020-08-18, + 4.14.0+dev0-2022-12-19, [mshinwell@janestreet.com], [flambda_backend], [http://github.com/ocaml-flambda/flambda_backend]) diff --git a/driver/compiler_hooks.ml b/driver/compiler_hooks.ml index caf9ef99129..8140330925c 100644 --- a/driver/compiler_hooks.ml +++ b/driver/compiler_hooks.ml @@ -17,7 +17,7 @@ type _ pass = | Parse_tree_intf : Parsetree.signature pass | Parse_tree_impl : Parsetree.structure pass | Typed_tree_intf : Typedtree.signature pass - | Typed_tree_impl : (Typedtree.structure * Typedtree.module_coercion) pass + | Typed_tree_impl : Typedtree.implementation pass | Raw_lambda : Lambda.program pass | Lambda : Lambda.program pass | Raw_flambda2 : Flambda2_terms.Flambda_unit.t pass @@ -27,6 +27,7 @@ type _ pass = | Raw_clambda : Clambda.ulambda pass | Clambda : Clambda.ulambda pass + | Mach_polling : Mach.fundecl pass | Mach_combine : Mach.fundecl pass | Mach_cse : Mach.fundecl pass | Mach_spill : Mach.fundecl pass @@ -44,7 +45,7 @@ type t = { mutable parse_tree_intf : (Parsetree.signature -> unit) list; mutable parse_tree_impl : (Parsetree.structure -> unit) list; mutable typed_tree_intf : (Typedtree.signature -> unit) list; - mutable typed_tree_impl : ((Typedtree.structure * Typedtree.module_coercion) -> unit) list; + mutable typed_tree_impl : (Typedtree.implementation -> unit) list; mutable raw_lambda : (Lambda.program -> unit) list; mutable lambda : (Lambda.program -> unit) list; mutable raw_flambda2 : (Flambda2_terms.Flambda_unit.t -> unit) list; @@ -53,6 +54,7 @@ type t = { mutable flambda1 : (Flambda.program -> unit) list; mutable raw_clambda : (Clambda.ulambda -> unit) list; mutable clambda : (Clambda.ulambda -> unit) list; + mutable mach_polling : (Mach.fundecl -> unit) list; mutable mach_combine : (Mach.fundecl -> unit) list; mutable mach_cse : (Mach.fundecl -> unit) list; mutable mach_spill : (Mach.fundecl -> unit) list; @@ -78,6 +80,7 @@ let hooks : t = { flambda1 = []; raw_clambda = []; clambda = []; + mach_polling = []; mach_combine = []; mach_cse = []; mach_spill = []; @@ -111,6 +114,7 @@ let register : type a. a pass -> (a -> unit) -> unit = | Clambda -> hooks.clambda <- f :: hooks.clambda | Mach_combine -> hooks.mach_combine <- f :: hooks.mach_combine + | Mach_polling -> hooks.mach_polling <- f :: hooks.mach_polling | Mach_cse -> hooks.mach_cse <- f :: hooks.mach_cse | Mach_spill -> hooks.mach_spill <- f :: hooks.mach_spill | Mach_live -> hooks.mach_live <- f :: hooks.mach_live @@ -137,6 +141,7 @@ let execute : type a. a pass -> a -> unit = | Flambda1 -> execute_hooks hooks.flambda1 arg | Raw_clambda -> execute_hooks hooks.raw_clambda arg | Clambda -> execute_hooks hooks.clambda arg + | Mach_polling -> execute_hooks hooks.mach_polling arg | Mach_combine -> execute_hooks hooks.mach_combine arg | Mach_cse -> execute_hooks hooks.mach_cse arg | Mach_spill -> execute_hooks hooks.mach_spill arg @@ -165,6 +170,7 @@ let clear : type a. a pass -> unit = | Flambda1 -> hooks.flambda1 <- [] | Raw_clambda -> hooks.raw_clambda <- [] | Clambda -> hooks.clambda <- [] + | Mach_polling -> hooks.mach_polling <- [] | Mach_combine -> hooks.mach_combine <- [] | Mach_cse -> hooks.mach_cse <- [] | Mach_spill -> hooks.mach_spill <- [] diff --git a/driver/compiler_hooks.mli b/driver/compiler_hooks.mli index f78514c9c10..7aefa8b0fbb 100644 --- a/driver/compiler_hooks.mli +++ b/driver/compiler_hooks.mli @@ -30,7 +30,7 @@ type _ pass = | Parse_tree_intf : Parsetree.signature pass | Parse_tree_impl : Parsetree.structure pass | Typed_tree_intf : Typedtree.signature pass - | Typed_tree_impl : (Typedtree.structure * Typedtree.module_coercion) pass + | Typed_tree_impl : Typedtree.implementation pass | Raw_lambda : Lambda.program pass | Lambda : Lambda.program pass | Raw_flambda2 : Flambda2_terms.Flambda_unit.t pass @@ -40,6 +40,7 @@ type _ pass = | Raw_clambda : Clambda.ulambda pass | Clambda : Clambda.ulambda pass + | Mach_polling : Mach.fundecl pass | Mach_combine : Mach.fundecl pass | Mach_cse : Mach.fundecl pass | Mach_spill : Mach.fundecl pass diff --git a/driver/flambda_backend_args.ml b/driver/flambda_backend_args.ml index 86770bd1f98..cd723dc3a55 100644 --- a/driver/flambda_backend_args.ml +++ b/driver/flambda_backend_args.ml @@ -59,6 +59,21 @@ let mk_alloc_check f = let mk_dcheckmach f = "-dcheckmach", Arg.Unit f, " (undocumented)" +let mk_disable_poll_insertion f = + "-disable-poll-insertion", Arg.Unit f, " Do not insert poll points" + +let mk_enable_poll_insertion f = + "-enable-poll-insertion", Arg.Unit f, " Insert poll points" + +let mk_long_frames f = + "-long-frames", Arg.Unit f, " Allow stack frames longer than 2^16 bytes" + +let mk_no_long_frames f = + "-no-long-frames", Arg.Unit f, " Do not allow stack frames longer than 2^16 bytes" + +let mk_debug_long_frames_threshold f = + "-debug-long-frames-threshold", Arg.Int f, "n debug only: set long frames threshold" + let mk_dump_inlining_paths f = "-dump-inlining-paths", Arg.Unit f, " Dump inlining paths when dumping flambda2 terms" @@ -231,6 +246,13 @@ let mk_no_flambda2_expert_can_inline_recursive_functions f = (format_not_default Flambda2.Expert.Default.can_inline_recursive_functions) ;; +let mk_flambda2_expert_max_function_simplify_run f = + "-flambda2-expert-max-function-simplify-run", Arg.Int f, + Printf.sprintf " Do not run simplification of function more\n\ + \ than this (default %d) (Flambda 2 only)" + Flambda2.Expert.Default.max_function_simplify_run +;; + let mk_flambda2_debug_concrete_types_only_on_canonicals f = "-flambda2-debug-concrete-types-only-on-canonicals", Arg.Unit f, Printf.sprintf " Check that concrete\n\ @@ -396,6 +418,10 @@ let mk_dfreshen f = "-dfreshen", Arg.Unit f, " Freshen bound names when printing (Flambda 2 only)" ;; +let mk_dflow f = + "-dflow", Arg.Unit f, " Dump debug info for the flow computation (Flambda 2 only)" +;; + module Debugging = Dwarf_flags (* CR mshinwell: These help texts should show the default values. *) @@ -415,6 +441,17 @@ let mk_no_dwarf_for_startup_file f = "-gno-startup", Arg.Unit f, " Emit the same DWARF information for the\n\ \ startup file as the upstream compiler" +let set_long_frames_threshold n = + if n < 0 then + raise (Arg.Bad "Long frames threshold must be non-negative."); + if n > Flambda_backend_flags.max_long_frames_threshold then + raise + (Arg.Bad + (Printf.sprintf "Long frames threshold too big: 0x%x, \ + must be less or equal to 0x%x" n + Flambda_backend_flags.max_long_frames_threshold)); + Flambda_backend_flags.long_frames_threshold := n + module type Flambda_backend_options = sig val ocamlcfg : unit -> unit val no_ocamlcfg : unit -> unit @@ -432,6 +469,13 @@ module type Flambda_backend_options = sig val alloc_check : unit -> unit val dcheckmach : unit -> unit + val disable_poll_insertion : unit -> unit + val enable_poll_insertion : unit -> unit + + val long_frames : unit -> unit + val no_long_frames : unit -> unit + val long_frames_threshold : int -> unit + val internal_assembler : unit -> unit val flambda2_join_points : unit -> unit @@ -455,6 +499,7 @@ module type Flambda_backend_options = sig val flambda2_expert_max_unboxing_depth : int -> unit val flambda2_expert_can_inline_recursive_functions : unit -> unit val no_flambda2_expert_can_inline_recursive_functions : unit -> unit + val flambda2_expert_max_function_simplify_run : int -> unit val flambda2_debug_concrete_types_only_on_canonicals : unit -> unit val no_flambda2_debug_concrete_types_only_on_canonicals : unit -> unit val flambda2_debug_keep_invalid_handlers : unit -> unit @@ -483,6 +528,7 @@ module type Flambda_backend_options = sig val dflexpect : unit -> unit val dslot_offsets : unit -> unit val dfreshen : unit -> unit + val dflow : unit -> unit end module Make_flambda_backend_options (F : Flambda_backend_options) = @@ -504,6 +550,13 @@ struct mk_alloc_check F.alloc_check; mk_dcheckmach F.dcheckmach; + mk_disable_poll_insertion F.disable_poll_insertion; + mk_enable_poll_insertion F.enable_poll_insertion; + + mk_long_frames F.long_frames; + mk_no_long_frames F.no_long_frames; + mk_debug_long_frames_threshold F.long_frames_threshold; + mk_internal_assembler F.internal_assembler; mk_flambda2_join_points F.flambda2_join_points; @@ -543,6 +596,8 @@ struct F.flambda2_expert_can_inline_recursive_functions; mk_no_flambda2_expert_can_inline_recursive_functions F.no_flambda2_expert_can_inline_recursive_functions; + mk_flambda2_expert_max_function_simplify_run + F.flambda2_expert_max_function_simplify_run; mk_flambda2_debug_concrete_types_only_on_canonicals F.flambda2_debug_concrete_types_only_on_canonicals; mk_no_flambda2_debug_concrete_types_only_on_canonicals @@ -579,6 +634,7 @@ struct mk_dflexpect F.dflexpect; mk_dslot_offsets F.dslot_offsets; mk_dfreshen F.dfreshen; + mk_dflow F.dflow; ] end @@ -611,6 +667,13 @@ module Flambda_backend_options_impl = struct let alloc_check = set' Flambda_backend_flags.alloc_check let dcheckmach = set' Flambda_backend_flags.dump_checkmach + let disable_poll_insertion = set' Flambda_backend_flags.disable_poll_insertion + let enable_poll_insertion = clear' Flambda_backend_flags.disable_poll_insertion + + let long_frames = set' Flambda_backend_flags.allow_long_frames + let no_long_frames = clear' Flambda_backend_flags.allow_long_frames + let long_frames_threshold n = set_long_frames_threshold n + let internal_assembler = set' Flambda_backend_flags.internal_assembler let flambda2_join_points = set Flambda2.join_points @@ -651,6 +714,8 @@ module Flambda_backend_options_impl = struct Flambda2.Expert.can_inline_recursive_functions := Flambda_backend_flags.Set true let no_flambda2_expert_can_inline_recursive_functions () = Flambda2.Expert.can_inline_recursive_functions := Flambda_backend_flags.Set false + let flambda2_expert_max_function_simplify_run runs = + Flambda2.Expert.max_function_simplify_run := Flambda_backend_flags.Set runs let flambda2_debug_concrete_types_only_on_canonicals = set' Flambda2.Debug.concrete_types_only_on_canonicals let no_flambda2_debug_concrete_types_only_on_canonicals = @@ -733,32 +798,33 @@ module Flambda_backend_options_impl = struct let dflexpect = set' Flambda2.Dump.flexpect let dslot_offsets = set' Flambda2.Dump.slot_offsets let dfreshen = set' Flambda2.Dump.freshen + let dflow = set' Flambda2.Dump.flow end module type Debugging_options = sig - val _restrict_to_upstream_dwarf : unit -> unit - val _no_restrict_to_upstream_dwarf : unit -> unit - val _dwarf_for_startup_file : unit -> unit - val _no_dwarf_for_startup_file : unit -> unit + val restrict_to_upstream_dwarf : unit -> unit + val no_restrict_to_upstream_dwarf : unit -> unit + val dwarf_for_startup_file : unit -> unit + val no_dwarf_for_startup_file : unit -> unit end module Make_debugging_options (F : Debugging_options) = struct let list3 = [ - mk_restrict_to_upstream_dwarf F._restrict_to_upstream_dwarf; - mk_no_restrict_to_upstream_dwarf F._no_restrict_to_upstream_dwarf; - mk_dwarf_for_startup_file F._dwarf_for_startup_file; - mk_no_dwarf_for_startup_file F._no_dwarf_for_startup_file; + mk_restrict_to_upstream_dwarf F.restrict_to_upstream_dwarf; + mk_no_restrict_to_upstream_dwarf F.no_restrict_to_upstream_dwarf; + mk_dwarf_for_startup_file F.dwarf_for_startup_file; + mk_no_dwarf_for_startup_file F.no_dwarf_for_startup_file; ] end module Debugging_options_impl = struct - let _restrict_to_upstream_dwarf () = + let restrict_to_upstream_dwarf () = Debugging.restrict_to_upstream_dwarf := true - let _no_restrict_to_upstream_dwarf () = + let no_restrict_to_upstream_dwarf () = Debugging.restrict_to_upstream_dwarf := false - let _dwarf_for_startup_file () = + let dwarf_for_startup_file () = Debugging.dwarf_for_startup_file := true - let _no_dwarf_for_startup_file () = + let no_dwarf_for_startup_file () = Debugging.dwarf_for_startup_file := false end @@ -794,9 +860,6 @@ module Extra_params = struct end; true in - let clear' option = - Compenv.setter ppf (fun b -> b) name [ option ] v; false - in match name with | "internal-assembler" -> set' Flambda_backend_flags.internal_assembler | "ocamlcfg" -> set' Flambda_backend_flags.use_ocamlcfg @@ -808,12 +871,20 @@ module Extra_params = struct | "heap-reduction-threshold" -> set_int' Flambda_backend_flags.heap_reduction_threshold | "alloc-check" -> set' Flambda_backend_flags.alloc_check | "dump-checkmach" -> set' Flambda_backend_flags.dump_checkmach + | "poll-insertion" -> set' Flambda_backend_flags.disable_poll_insertion + | "long-frames" -> set' Flambda_backend_flags.allow_long_frames + | "debug-long-frames-threshold" -> + begin match Compenv.check_int ppf name v with + | Some n -> set_long_frames_threshold n; true + | None -> + raise + (Arg.Bad + (Printf.sprintf "Expected integer between 0 and %d" + Flambda_backend_flags.max_long_frames_threshold)) + end | "dasm-comments" -> set' Flambda_backend_flags.dasm_comments - | "dno-asm-comments" -> clear' Flambda_backend_flags.dasm_comments | "gupstream-dwarf" -> set' Debugging.restrict_to_upstream_dwarf - | "gno-upstream-dwarf" -> clear' Debugging.restrict_to_upstream_dwarf | "gstartup" -> set' Debugging.dwarf_for_startup_file - | "gno-startup" -> clear' Debugging.dwarf_for_startup_file | "flambda2-join-points" -> set Flambda2.join_points | "flambda2-result-types" -> (match String.lowercase_ascii v with @@ -846,6 +917,8 @@ module Extra_params = struct set_int Flambda2.Expert.max_unboxing_depth | "flambda2-expert-can-inline-recursive-functions" -> set Flambda2.Expert.can_inline_recursive_functions + | "flambda2-expert-max-function-simplify-run" -> + set_int Flambda2.Expert.max_function_simplify_run | "flambda2-inline-max-depth" -> Clflags.Int_arg_helper.parse v "Bad syntax in OCAMLPARAM for 'flambda2-inline-max-depth'" diff --git a/driver/flambda_backend_args.mli b/driver/flambda_backend_args.mli index be49b3ec154..145d48f2178 100644 --- a/driver/flambda_backend_args.mli +++ b/driver/flambda_backend_args.mli @@ -36,6 +36,13 @@ module type Flambda_backend_options = sig val alloc_check : unit -> unit val dcheckmach : unit -> unit + val disable_poll_insertion : unit -> unit + val enable_poll_insertion : unit -> unit + + val long_frames : unit -> unit + val no_long_frames : unit -> unit + val long_frames_threshold : int -> unit + val internal_assembler : unit -> unit val flambda2_join_points : unit -> unit @@ -59,6 +66,7 @@ module type Flambda_backend_options = sig val flambda2_expert_max_unboxing_depth : int -> unit val flambda2_expert_can_inline_recursive_functions : unit -> unit val no_flambda2_expert_can_inline_recursive_functions : unit -> unit + val flambda2_expert_max_function_simplify_run : int -> unit val flambda2_debug_concrete_types_only_on_canonicals : unit -> unit val no_flambda2_debug_concrete_types_only_on_canonicals : unit -> unit val flambda2_debug_keep_invalid_handlers : unit -> unit @@ -87,14 +95,15 @@ module type Flambda_backend_options = sig val dflexpect : unit -> unit val dslot_offsets : unit -> unit val dfreshen : unit -> unit + val dflow : unit -> unit end (** Command line arguments required for ocamlopt.*) module type Debugging_options = sig - val _restrict_to_upstream_dwarf : unit -> unit - val _no_restrict_to_upstream_dwarf : unit -> unit - val _dwarf_for_startup_file : unit -> unit - val _no_dwarf_for_startup_file : unit -> unit + val restrict_to_upstream_dwarf : unit -> unit + val no_restrict_to_upstream_dwarf : unit -> unit + val dwarf_for_startup_file : unit -> unit + val no_dwarf_for_startup_file : unit -> unit end (** Command line arguments required for ocamlopt. *) diff --git a/driver/flambda_backend_flags.ml b/driver/flambda_backend_flags.ml index 8726b584224..1b5e2b274d3 100644 --- a/driver/flambda_backend_flags.ml +++ b/driver/flambda_backend_flags.ml @@ -27,6 +27,14 @@ let heap_reduction_threshold = ref default_heap_reduction_threshold (* -heap-red let alloc_check = ref false (* -alloc-check *) let dump_checkmach = ref false (* -dcheckmach *) +let disable_poll_insertion = ref (not Config.poll_insertion) + (* -disable-poll-insertion *) +let allow_long_frames = ref true (* -no-long-frames *) +(* Keep the value of [max_long_frames_threshold] in sync with LONG_FRAME_MARKER + in ocaml/runtime/roots_nat.c *) +let max_long_frames_threshold = 0x7FFF +let long_frames_threshold = ref max_long_frames_threshold (* -debug-long-frames-threshold n *) + type function_result_types = Never | Functors_only | All_functions type opt_level = Oclassic | O2 | O3 type 'a or_default = Set of 'a | Default @@ -115,6 +123,7 @@ module Flambda2 = struct let flexpect = ref false let slot_offsets = ref false let freshen = ref false + let flow = ref false end module Expert = struct @@ -125,6 +134,7 @@ module Flambda2 = struct let max_block_size_for_projections = None let max_unboxing_depth = 3 let can_inline_recursive_functions = false + let max_function_simplify_run = 2 end type flags = { @@ -134,6 +144,7 @@ module Flambda2 = struct max_block_size_for_projections : int option; max_unboxing_depth : int; can_inline_recursive_functions : bool; + max_function_simplify_run : int; } let default = { @@ -143,6 +154,7 @@ module Flambda2 = struct max_block_size_for_projections = Default.max_block_size_for_projections; max_unboxing_depth = Default.max_unboxing_depth; can_inline_recursive_functions = Default.can_inline_recursive_functions; + max_function_simplify_run = Default.max_function_simplify_run; } let oclassic = { @@ -166,6 +178,7 @@ module Flambda2 = struct let max_block_size_for_projections = ref Default let max_unboxing_depth = ref Default let can_inline_recursive_functions = ref Default + let max_function_simplify_run = ref Default end module Debug = struct diff --git a/driver/flambda_backend_flags.mli b/driver/flambda_backend_flags.mli index f07cfc26ba8..0886fc4f6c3 100644 --- a/driver/flambda_backend_flags.mli +++ b/driver/flambda_backend_flags.mli @@ -28,6 +28,11 @@ val heap_reduction_threshold : int ref val alloc_check : bool ref val dump_checkmach : bool ref +val disable_poll_insertion : bool ref +val allow_long_frames : bool ref +val max_long_frames_threshold : int +val long_frames_threshold : int ref + type function_result_types = Never | Functors_only | All_functions type opt_level = Oclassic | O2 | O3 type 'a or_default = Set of 'a | Default @@ -85,6 +90,7 @@ module Flambda2 : sig val flexpect : bool ref val slot_offsets : bool ref val freshen : bool ref + val flow : bool ref end module Expert : sig @@ -95,6 +101,7 @@ module Flambda2 : sig val max_block_size_for_projections : int option val max_unboxing_depth : int val can_inline_recursive_functions : bool + val max_function_simplify_run : int end type flags = { @@ -104,6 +111,7 @@ module Flambda2 : sig max_block_size_for_projections : int option; max_unboxing_depth : int; can_inline_recursive_functions : bool; + max_function_simplify_run : int; } val default_for_opt_level : opt_level or_default -> flags @@ -114,6 +122,7 @@ module Flambda2 : sig val max_block_size_for_projections : int option or_default ref val max_unboxing_depth : int or_default ref val can_inline_recursive_functions : bool or_default ref + val max_function_simplify_run : int or_default ref end module Debug : sig diff --git a/driver/optcompile.ml b/driver/optcompile.ml index 69ed3e29008..0fbe6125edd 100644 --- a/driver/optcompile.ml +++ b/driver/optcompile.ml @@ -45,22 +45,22 @@ let flambda_and_flambda2 i typed ~compile_implementation = { program with Lambda.code } |> print_if i.ppf_dump Clflags.dump_lambda Printlambda.program |> Compiler_hooks.execute_and_pipe Compiler_hooks.Lambda - |> (fun ({ Lambda.module_ident; main_module_block_size; + |> (fun ({ Lambda.compilation_unit; main_module_block_size; required_globals; code }) -> - compile_implementation ~module_ident ~main_module_block_size ~code + compile_implementation ~compilation_unit ~main_module_block_size ~code ~required_globals; Compilenv.save_unit_info (cmx i))) let flambda2_ unix i ~flambda2 ~keep_symbol_tables typed = flambda_and_flambda2 i typed - ~compile_implementation:(fun ~module_ident ~main_module_block_size ~code + ~compile_implementation:(fun ~compilation_unit ~main_module_block_size ~code ~required_globals -> Asmgen.compile_implementation_flambda2 unix ~filename:i.source_file ~prefixname:i.output_prefix ~size:main_module_block_size - ~module_ident + ~compilation_unit ~module_initializer:code ~flambda2 ~ppf_dump:i.ppf_dump @@ -70,11 +70,11 @@ let flambda2_ unix i ~flambda2 ~keep_symbol_tables typed = let flambda unix i backend typed = flambda_and_flambda2 i typed - ~compile_implementation:(fun ~module_ident ~main_module_block_size ~code + ~compile_implementation:(fun ~compilation_unit ~main_module_block_size ~code ~required_globals -> let program : Lambda.program = { Lambda. - module_ident; + compilation_unit; main_module_block_size; required_globals; code; @@ -111,23 +111,17 @@ let clambda unix i backend typed = ~ppf_dump:i.ppf_dump; Compilenv.save_unit_info (cmx i)) -let reset_compilenv ~module_name = - let comp_unit = - Compilation_unit.create (Compilation_unit.Prefix.from_clflags ()) - (Compilation_unit.Name.of_string module_name) - in - Compilenv.reset comp_unit - (* Emit assembly directly from Linear IR *) let emit unix i = - reset_compilenv ~module_name:i.module_name; + Compilenv.reset i.module_name; Asmgen.compile_implementation_linear unix i.output_prefix ~progname:i.source_file let implementation unix ~backend ~flambda2 ~start_from ~source_file ~output_prefix ~keep_symbol_tables = - let backend info typed = - reset_compilenv ~module_name:info.module_name; + let backend info ({ structure; coercion; _ } : Typedtree.implementation) = + Compilenv.reset info.module_name; + let typed = structure, coercion in if Config.flambda then flambda unix info backend typed else if Config.flambda2 @@ -135,11 +129,14 @@ let implementation unix ~backend ~flambda2 ~start_from ~source_file else clambda unix info backend typed in with_info ~source_file ~output_prefix ~dump_ext:"cmx" @@ fun info -> + if !Flambda_backend_flags.internal_assembler then + Emitaux.binary_backend_available := true; match (start_from:Clflags.Compiler_pass.t) with | Parsing -> Compile_common.implementation ~hook_parse_tree:(Compiler_hooks.execute Compiler_hooks.Parse_tree_impl) - ~hook_typed_tree:(Compiler_hooks.execute Compiler_hooks.Typed_tree_impl) + ~hook_typed_tree:(fun (impl : Typedtree.implementation) -> + Compiler_hooks.execute Compiler_hooks.Typed_tree_impl impl) info ~backend | Emit -> emit unix info ~ppf_dump:info.ppf_dump | _ -> Misc.fatal_errorf "Cannot start from %s" diff --git a/driver/optcompile.mli b/driver/optcompile.mli index 6bda02380fa..a7c130573ac 100644 --- a/driver/optcompile.mli +++ b/driver/optcompile.mli @@ -24,7 +24,7 @@ val implementation ppf_dump:Format.formatter -> prefixname:string -> filename:string -> - module_ident:Ident.t -> + compilation_unit:Compilation_unit.t -> module_block_size_in_words:int -> module_initializer:Lambda.lambda -> keep_symbol_tables:bool -> diff --git a/driver/optmaindriver.ml b/driver/optmaindriver.ml index 252d9d55d1d..346883bd1d3 100644 --- a/driver/optmaindriver.ml +++ b/driver/optmaindriver.ml @@ -18,9 +18,6 @@ open Clflags module Backend = struct (* See backend_intf.mli. *) - let pack_prefix_for_global_ident id = - Compilenv.pack_prefix_for_global_ident id - let really_import_approx = Import_approx.really_import_approx let import_symbol = Import_approx.import_symbol @@ -67,7 +64,7 @@ let main unix argv ppf ~flambda2 = " Compute dependencies \ (use 'ocamlopt -depend -help' for details)"]; Clflags.Opt_flag_handler.set Flambda_backend_flags.opt_flag_handler; - Clflags.parse_arguments argv Compenv.anonymous usage; + Compenv.parse_arguments (ref argv) Compenv.anonymous "ocamlopt"; Compmisc.read_clflags_from_env (); if !Clflags.plugin then Compenv.fatal "-plugin is only supported up to OCaml 4.08.0"; @@ -127,7 +124,7 @@ let main unix argv ppf ~flambda2 = Compmisc.init_path (); let target = Compenv.extract_output !output_name in Compmisc.with_ppf_dump ~file_prefix:target (fun ppf_dump -> - Asmlink.link_shared ~ppf_dump + Asmlink.link_shared unix ~ppf_dump (Compenv.get_objfiles ~with_ocamlparam:false) target); Warnings.check_fatal (); end diff --git a/driver/optmaindriver.mli b/driver/optmaindriver.mli index 72fec023424..e55df535178 100644 --- a/driver/optmaindriver.mli +++ b/driver/optmaindriver.mli @@ -26,7 +26,7 @@ val main ppf_dump:Format.formatter -> prefixname:string -> filename:string -> - module_ident:Ident.t -> + compilation_unit:Compilation_unit.t -> module_block_size_in_words:int -> module_initializer:Lambda.lambda -> keep_symbol_tables:bool -> diff --git a/dune b/dune index 6adb27ae087..43635510800 100755 --- a/dune +++ b/dune @@ -58,7 +58,7 @@ ; We should change the code so this "-open" can be removed. ; Likewise fix occurrences of warning 9. (flags - (:standard -principal -w -9)) + (:standard -principal -w -9-69-70)) (ocamlopt_flags (:include %{project_root}/ocamlopt_flags.sexp)) (instrumentation @@ -115,7 +115,6 @@ closure_offsets effect_analysis export_info - export_info_for_pack extract_projections find_recursive_functions flambda @@ -170,6 +169,7 @@ branch_relaxation_intf cfgize cmm_helpers + cmm_builtins cmm_invariants cmm cmmgen @@ -190,6 +190,7 @@ linscan liveness mach + polling printcmm printlinear printmach @@ -270,6 +271,7 @@ (libraries ocamlcommon flambda_backend_common + flambda_backend_utils flambda2_identifiers flambda2_cmx dwarf_ocaml @@ -382,6 +384,7 @@ %{dep:backend/debug/dwarf/dwarf_high/dwarf_high.a} %{dep:backend/debug/dwarf/dwarf_ocaml/dwarf_ocaml.a} %{dep:flambda_backend_common.a} + %{dep:utils/flambda_backend_utils.a} %{dep:middle_end/flambda2/import/flambda2_import.a} %{dep:middle_end/flambda2/ui/flambda2_ui.a} %{dep:middle_end/flambda2/algorithms/flambda2_algorithms.a} @@ -417,6 +420,7 @@ %{dep:backend/debug/dwarf/dwarf_high/dwarf_high.cma} %{dep:backend/debug/dwarf/dwarf_ocaml/dwarf_ocaml.cma} %{dep:flambda_backend_common.cma} + %{dep:utils/flambda_backend_utils.cma} %{dep:middle_end/flambda2/import/flambda2_import.cma} %{dep:middle_end/flambda2/ui/flambda2_ui.cma} %{dep:middle_end/flambda2/algorithms/flambda2_algorithms.cma} @@ -452,6 +456,7 @@ %{dep:backend/debug/dwarf/dwarf_high/dwarf_high.cmxa} %{dep:backend/debug/dwarf/dwarf_ocaml/dwarf_ocaml.cmxa} %{dep:flambda_backend_common.cmxa} + %{dep:utils/flambda_backend_utils.cmxa} %{dep:middle_end/flambda2/import/flambda2_import.cmxa} %{dep:middle_end/flambda2/ui/flambda2_ui.cmxa} %{dep:middle_end/flambda2/algorithms/flambda2_algorithms.cmxa} @@ -489,7 +494,8 @@ compiler-libs/libcompiler_owee_stubs.a) (external/owee/libcompiler_owee_stubs.a as - compiler-libs/libcompiler_owee_stubs_native.a) ; for special_dune compat + compiler-libs/libcompiler_owee_stubs_native.a) + ; for special_dune compat (ocamloptcomp_with_flambda2.cma as compiler-libs/ocamloptcomp.cma) (ocamloptcomp_with_flambda2.cmxa as compiler-libs/ocamloptcomp.cmxa) (ocamloptcomp_with_flambda2.a as compiler-libs/ocamloptcomp.a)) @@ -538,7 +544,6 @@ (closure_offsets.mli as compiler-libs/closure_offsets.mli) (effect_analysis.mli as compiler-libs/effect_analysis.mli) (export_info.mli as compiler-libs/export_info.mli) - (export_info_for_pack.mli as compiler-libs/export_info_for_pack.mli) (extract_projections.mli as compiler-libs/extract_projections.mli) (find_recursive_functions.mli as @@ -689,6 +694,7 @@ (branch_relaxation.mli as compiler-libs/branch_relaxation.mli) (cfgize.mli as compiler-libs/cfgize.mli) (cmm_helpers.mli as compiler-libs/cmm_helpers.mli) + (cmm_builtins.mli as compiler-libs/cmm_builtins.mli) (cmm_invariants.mli as compiler-libs/cmm_invariants.mli) (cmm.mli as compiler-libs/cmm.mli) (cmmgen.mli as compiler-libs/cmmgen.mli) @@ -707,6 +713,7 @@ (linscan.mli as compiler-libs/linscan.mli) (liveness.mli as compiler-libs/liveness.mli) (mach.mli as compiler-libs/mach.mli) + (polling.mli as compiler-libs/polling.mli) (printcmm.mli as compiler-libs/printcmm.mli) (printlinear.mli as compiler-libs/printlinear.mli) (printmach.mli as compiler-libs/printmach.mli) @@ -885,6 +892,12 @@ (.ocamloptcomp.objs/byte/cfgize.cmo as compiler-libs/cfgize.cmo) (.ocamloptcomp.objs/byte/cfgize.cmt as compiler-libs/cfgize.cmt) (.ocamloptcomp.objs/byte/cfgize.cmti as compiler-libs/cfgize.cmti) + (.ocamloptcomp.objs/byte/cmm_builtins.cmi as compiler-libs/cmm_builtins.cmi) + (.ocamloptcomp.objs/byte/cmm_builtins.cmo as compiler-libs/cmm_builtins.cmo) + (.ocamloptcomp.objs/byte/cmm_builtins.cmt as compiler-libs/cmm_builtins.cmt) + (.ocamloptcomp.objs/byte/cmm_builtins.cmti + as + compiler-libs/cmm_builtins.cmti) (.ocamloptcomp.objs/byte/cmm_helpers.cmi as compiler-libs/cmm_helpers.cmi) (.ocamloptcomp.objs/byte/cmm_helpers.cmo as compiler-libs/cmm_helpers.cmo) (.ocamloptcomp.objs/byte/cmm_helpers.cmt as compiler-libs/cmm_helpers.cmt) @@ -1012,6 +1025,10 @@ (.ocamloptcomp.objs/byte/opterrors.cmo as compiler-libs/opterrors.cmo) (.ocamloptcomp.objs/byte/opterrors.cmt as compiler-libs/opterrors.cmt) (.ocamloptcomp.objs/byte/opterrors.cmti as compiler-libs/opterrors.cmti) + (.ocamloptcomp.objs/byte/polling.cmi as compiler-libs/polling.cmi) + (.ocamloptcomp.objs/byte/polling.cmo as compiler-libs/polling.cmo) + (.ocamloptcomp.objs/byte/polling.cmt as compiler-libs/polling.cmt) + (.ocamloptcomp.objs/byte/polling.cmti as compiler-libs/polling.cmti) (.ocamloptcomp.objs/byte/printcmm.cmi as compiler-libs/printcmm.cmi) (.ocamloptcomp.objs/byte/printcmm.cmo as compiler-libs/printcmm.cmo) (.ocamloptcomp.objs/byte/printcmm.cmt as compiler-libs/printcmm.cmt) @@ -1224,7 +1241,6 @@ (.ocamloptcomp.objs/byte/cfg_regalloc_utils.cmti as compiler-libs/cfg_regalloc_utils.cmti) - (.ocamloptcomp.objs/byte/cfg_regalloc_validate.cmi as compiler-libs/cfg_regalloc_validate.cmi) @@ -1232,11 +1248,11 @@ as compiler-libs/cfg_regalloc_validate.cmo) (.ocamloptcomp.objs/byte/cfg_regalloc_validate.cmt - as - compiler-libs/cfg_regalloc_validate.cmt) + as + compiler-libs/cfg_regalloc_validate.cmt) (.ocamloptcomp.objs/byte/cfg_regalloc_validate.cmti - as - compiler-libs/cfg_regalloc_validate.cmti) + as + compiler-libs/cfg_regalloc_validate.cmti) (.ocamloptcomp.objs/byte/cfg_stack_operands.cmi as compiler-libs/cfg_stack_operands.cmi) @@ -1448,6 +1464,9 @@ (.ocamloptcomp.objs/native/cSEgen.cmx as compiler-libs/CSEgen.cmx) (.ocamloptcomp.objs/native/cmm.cmx as compiler-libs/cmm.cmx) (.ocamloptcomp.objs/native/cfgize.cmx as compiler-libs/cfgize.cmx) + (.ocamloptcomp.objs/native/cmm_builtins.cmx + as + compiler-libs/cmm_builtins.cmx) (.ocamloptcomp.objs/native/cmm_helpers.cmx as compiler-libs/cmm_helpers.cmx) @@ -1480,6 +1499,7 @@ (.ocamloptcomp.objs/native/optcompile.cmx as compiler-libs/optcompile.cmx) (.ocamloptcomp.objs/native/opterrors.cmx as compiler-libs/opterrors.cmx) (.ocamloptcomp.objs/native/printcmm.cmx as compiler-libs/printcmm.cmx) + (.ocamloptcomp.objs/native/polling.cmx as compiler-libs/polling.cmx) (.ocamloptcomp.objs/native/printlinear.cmx as compiler-libs/printlinear.cmx) @@ -1533,8 +1553,8 @@ as compiler-libs/cfg_regalloc_utils.cmx) (.ocamloptcomp.objs/native/cfg_regalloc_validate.cmx - as - compiler-libs/cfg_regalloc_validate.cmx) + as + compiler-libs/cfg_regalloc_validate.cmx) (.ocamloptcomp.objs/native/cfg_stack_operands.cmx as compiler-libs/cfg_stack_operands.cmx) @@ -1911,18 +1931,6 @@ (.ocamloptcomp.objs/byte/export_info.cmti as compiler-libs/export_info.cmti) - (.ocamloptcomp.objs/byte/export_info_for_pack.cmi - as - compiler-libs/export_info_for_pack.cmi) - (.ocamloptcomp.objs/byte/export_info_for_pack.cmo - as - compiler-libs/export_info_for_pack.cmo) - (.ocamloptcomp.objs/byte/export_info_for_pack.cmt - as - compiler-libs/export_info_for_pack.cmt) - (.ocamloptcomp.objs/byte/export_info_for_pack.cmti - as - compiler-libs/export_info_for_pack.cmti) (.ocamloptcomp.objs/byte/extract_projections.cmi as compiler-libs/extract_projections.cmi) @@ -2427,10 +2435,18 @@ (.ocamloptcomp.objs/byte/static_exception.cmti as compiler-libs/static_exception.cmti) - (.ocamloptcomp.objs/byte/symbol_utils.cmi as compiler-libs/symbol_utils.cmi) - (.ocamloptcomp.objs/byte/symbol_utils.cmo as compiler-libs/symbol_utils.cmo) - (.ocamloptcomp.objs/byte/symbol_utils.cmt as compiler-libs/symbol_utils.cmt) - (.ocamloptcomp.objs/byte/symbol_utils.cmti as compiler-libs/symbol_utils.cmti) + (.ocamloptcomp.objs/byte/symbol_utils.cmi + as + compiler-libs/symbol_utils.cmi) + (.ocamloptcomp.objs/byte/symbol_utils.cmo + as + compiler-libs/symbol_utils.cmo) + (.ocamloptcomp.objs/byte/symbol_utils.cmt + as + compiler-libs/symbol_utils.cmt) + (.ocamloptcomp.objs/byte/symbol_utils.cmti + as + compiler-libs/symbol_utils.cmti) (.ocamloptcomp.objs/byte/tag.cmi as compiler-libs/tag.cmi) (.ocamloptcomp.objs/byte/tag.cmo as compiler-libs/tag.cmo) (.ocamloptcomp.objs/byte/tag.cmt as compiler-libs/tag.cmt) @@ -2554,9 +2570,6 @@ (.ocamloptcomp.objs/native/export_info.cmx as compiler-libs/export_info.cmx) - (.ocamloptcomp.objs/native/export_info_for_pack.cmx - as - compiler-libs/export_info_for_pack.cmx) (.ocamloptcomp.objs/native/extract_projections.cmx as compiler-libs/extract_projections.cmx) @@ -2680,7 +2693,9 @@ (.ocamloptcomp.objs/native/static_exception.cmx as compiler-libs/static_exception.cmx) - (.ocamloptcomp.objs/native/symbol_utils.cmx as compiler-libs/symbol_utils.cmx) + (.ocamloptcomp.objs/native/symbol_utils.cmx + as + compiler-libs/symbol_utils.cmx) (.ocamloptcomp.objs/native/tag.cmx as compiler-libs/tag.cmx) (.ocamloptcomp.objs/native/traverse_for_exported_symbols.cmx as diff --git a/dune-project b/dune-project index b70c4acee89..1f4aeed8ea1 100644 --- a/dune-project +++ b/dune-project @@ -16,3 +16,4 @@ (package (name ocaml_runtime_stdlib) ) + diff --git a/file_formats/cmx_format.mli b/file_formats/cmx_format.mli index 42128d481fd..0b015ef91fe 100644 --- a/file_formats/cmx_format.mli +++ b/file_formats/cmx_format.mli @@ -36,6 +36,11 @@ type export_info = | Flambda1 of Export_info.t | Flambda2 of Flambda2_cmx.Flambda_cmx_format.t option +type export_info_raw = + | Clambda_raw of Clambda.value_approximation + | Flambda1_raw of Export_info.t + | Flambda2_raw of Flambda2_cmx.Flambda_cmx_format.raw option + type apply_fn := int * Lambda.alloc_mode (* Curry/apply/send functions *) @@ -58,13 +63,30 @@ type unit_infos = (* All compilation units in the .cmx file (i.e. [ui_unit] and any produced via [Asmpackager]) *) - mutable ui_imports_cmi: crcs; (* Interfaces imported *) - mutable ui_imports_cmx: crcs; (* Infos imported *) + mutable ui_imports_cmi: Import_info.t list; + (* Interfaces imported *) + mutable ui_imports_cmx: Import_info.t list; + (* Infos imported *) mutable ui_generic_fns: generic_fns; (* Generic functions needed *) mutable ui_export_info: export_info; mutable ui_checks: checks; mutable ui_force_link: bool } (* Always linked *) +type unit_infos_raw = + { uir_unit: Compilation_unit.t; + uir_defines: Compilation_unit.t list; + uir_imports_cmi: Import_info.t array; + uir_imports_cmx: Import_info.t array; + uir_generic_fns: generic_fns; + uir_export_info: export_info_raw; + uir_checks: checks; + uir_force_link: bool; + uir_section_toc: int array; (* Byte offsets of sections in .cmx + relative to byte immediately after + this record *) + uir_sections_length: int; (* Byte length of all sections *) + } + (* Each .a library has a matching .cmxa file that provides the following infos on the library: *) @@ -77,8 +99,8 @@ type lib_unit_info = li_imports_cmx : Bitmap.t } (* subset of lib_imports_cmx *) type library_infos = - { lib_imports_cmi: (modname * Digest.t option) array; - lib_imports_cmx: (modname * Digest.t option) array; + { lib_imports_cmi: Import_info.t array; + lib_imports_cmx: Import_info.t array; lib_units: lib_unit_info list; lib_generic_fns: generic_fns; (* In the following fields the lists are reversed with respect to diff --git a/middle_end/.ocamlformat b/middle_end/.ocamlformat index 3da0d003a11..a6f157798c0 100644 --- a/middle_end/.ocamlformat +++ b/middle_end/.ocamlformat @@ -7,10 +7,11 @@ cases-exp-indent=2 doc-comments=before dock-collection-brackets=false if-then-else=keyword-first +module-item-spacing=sparse parens-tuple=multi-line-only sequence-blank-line=compact space-around-lists=false space-around-variants=false type-decl=sparse wrap-comments=true -version=0.19.0 +version=0.24.1 diff --git a/middle_end/backend_intf.mli b/middle_end/backend_intf.mli index fba7341b5fc..3d2fcba9b97 100644 --- a/middle_end/backend_intf.mli +++ b/middle_end/backend_intf.mli @@ -19,9 +19,6 @@ (** Knowledge that the middle end needs about the backend. *) module type S = sig - (** Compute the pack prefix for the given identifier. *) - val pack_prefix_for_global_ident : (Ident.t -> Compilation_unit.Prefix.t) - (** If the given approximation is that of a symbol (Value_symbol) or an external (Value_extern), attempt to find a more informative approximation from a previously-written compilation artifact. In the diff --git a/middle_end/clambda.ml b/middle_end/clambda.ml index 6f60c7614e1..5f0414079ae 100644 --- a/middle_end/clambda.ml +++ b/middle_end/clambda.ml @@ -52,7 +52,11 @@ and ulambda = function_label * ulambda list * Lambda.probe * apply_kind * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * apply_kind * Debuginfo.t - | Uclosure of ufunction list * ulambda list + | Uclosure of { + functions : ufunction list ; + not_scanned_slots : ulambda list ; + scanned_slots : ulambda list ; + } | Uoffset of ulambda * int | Ulet of mutable_flag * value_kind * Backend_var.With_provenance.t * ulambda * ulambda @@ -99,6 +103,7 @@ and ufunction = { body : ulambda; dbg : Debuginfo.t; env : Backend_var.t option; + poll : poll_attribute; mode : Lambda.alloc_mode; check : Lambda.check_attribute; } @@ -117,6 +122,7 @@ type function_description = mutable fun_closed: bool; (* True if environment not used *) mutable fun_inline: (Backend_var.With_provenance.t list * ulambda) option; mutable fun_float_const_prop: bool; (* Can propagate FP consts *) + fun_poll: poll_attribute; (* Error on poll/alloc/call *) fun_region: bool; (* If false, may locally allocate in caller's region *) } diff --git a/middle_end/clambda.mli b/middle_end/clambda.mli index f9f9a339b83..f8ac77dde51 100644 --- a/middle_end/clambda.mli +++ b/middle_end/clambda.mli @@ -63,7 +63,11 @@ and ulambda = function_label * ulambda list * Lambda.probe * apply_kind * Debuginfo.t | Ugeneric_apply of ulambda * ulambda list * apply_kind * Debuginfo.t - | Uclosure of ufunction list * ulambda list + | Uclosure of { + functions : ufunction list ; + not_scanned_slots : ulambda list ; + scanned_slots : ulambda list + } | Uoffset of ulambda * int | Ulet of mutable_flag * value_kind * Backend_var.With_provenance.t * ulambda * ulambda @@ -110,6 +114,7 @@ and ufunction = { body : ulambda; dbg : Debuginfo.t; env : Backend_var.t option; + poll : poll_attribute; mode : Lambda.alloc_mode; check : Lambda.check_attribute; } @@ -128,6 +133,7 @@ type function_description = mutable fun_closed: bool; (* True if environment not used *) mutable fun_inline: (Backend_var.With_provenance.t list * ulambda) option; mutable fun_float_const_prop: bool; (* Can propagate FP consts *) + fun_poll: poll_attribute; (* Behaviour for polls *) fun_region: bool; (* If false, may locally allocate in caller's region *) } diff --git a/middle_end/closure/closure.ml b/middle_end/closure/closure.ml index c53fb0b0782..7dabaf9950d 100644 --- a/middle_end/closure/closure.ml +++ b/middle_end/closure/closure.ml @@ -50,22 +50,36 @@ let rec split_list n l = | a::l -> let (l1, l2) = split_list (n-1) l in (a::l1, l2) end -let rec build_closure_env env_param pos = function - [] -> V.Map.empty +let rec add_to_closure_env env_param pos cenv = function + [] -> cenv | id :: rem -> V.Map.add id (Uprim(P.Pfield pos, [Uvar env_param], Debuginfo.none)) - (build_closure_env env_param (pos+1) rem) + (add_to_closure_env env_param (pos+1) cenv rem) + +let is_gc_ignorable kind = + match kind with + | Pintval -> true + | Pgenval | Pfloatval | Pboxedintval _ | Pvariant _ | Parrayval _ -> false + +let split_closure_fv kinds fv = + List.partition (fun id -> is_gc_ignorable (V.Map.find id kinds)) fv (* Auxiliary for accessing globals. We change the name of the global to the name of the corresponding asm symbol. This is done here and no longer in Cmmgen so that approximations stored in .cmx files contain the right names if the -for-pack option is active. *) -let getglobal dbg id = - let symbol = Compilenv.symbol_for_global id |> Linkage_name.to_string in +let getsymbol dbg symbol = + let symbol = Symbol.linkage_name symbol |> Linkage_name.to_string in Uprim (P.Pread_symbol symbol, [], dbg) +let getglobal dbg cu = + getsymbol dbg (Symbol.for_compilation_unit cu) + +let getpredef dbg id = + getsymbol dbg (Symbol.for_predef_ident id) + let region ulam = let is_trivial = match ulam with @@ -93,7 +107,8 @@ let occurs_var var u = | Udirect_apply(_lbl, args, _, _, _) -> List.exists occurs args | Ugeneric_apply(funct, args, _, _) -> occurs funct || List.exists occurs args - | Uclosure(_fundecls, clos) -> List.exists occurs clos + | Uclosure { functions = _ ; not_scanned_slots ; scanned_slots } -> + List.exists occurs not_scanned_slots || List.exists occurs scanned_slots | Uoffset(u, _ofs) -> occurs u | Ulet(_str, _kind, _id, def, body) -> occurs def || occurs body | Uphantom_let _ -> no_phantom_lets () @@ -518,6 +533,8 @@ let simplif_prim_pure ~backend fpc p (args, approxs) dbg = make_const (List.nth l n) | Pfield n, [ Uprim(P.Pmakeblock _, ul, _) ], [approx] when n < List.length ul -> + (* This case is particularly useful for removing allocations + for optional parameters *) (List.nth ul n, field_approx n approx) (* Strings *) | (Pstringlength | Pbyteslength), @@ -525,6 +542,10 @@ let simplif_prim_pure ~backend fpc p (args, approxs) dbg = [ Value_const(Uconst_ref(_, Some (Uconst_string s))) ] -> make_const_int (String.length s) (* Kind test *) + | Pisint, [ Uprim(P.Pmakeblock _, _, _) ], _ -> + (* This case is particularly useful for removing allocations + for optional parameters *) + make_const_bool false | Pisint, _, [a1] -> begin match a1 with | Value_const(Uconst_int _) -> make_const_bool true @@ -592,7 +613,7 @@ let rec substitute loc ((backend, fpc) as st) sb rn ulam = let dbg = subst_debuginfo loc dbg in Ugeneric_apply(substitute loc st sb rn fn, List.map (substitute loc st sb rn) args, kind, dbg) - | Uclosure(defs, env) -> + | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> (* Question: should we rename function labels as well? Otherwise, there is a risk that function labels are not globally unique. This should not happen in the current system because: @@ -601,7 +622,12 @@ let rec substitute loc ((backend, fpc) as st) sb rn ulam = - When we substitute offsets for idents bound by let rec in [close], case [Lletrec], we discard the original let rec body and use only the substituted term. *) - Uclosure(defs, List.map (substitute loc st sb rn) env) + let subst = substitute loc st sb rn in + Uclosure { + functions ; + not_scanned_slots = List.map subst not_scanned_slots ; + scanned_slots = List.map subst scanned_slots + } | Uoffset(u, ofs) -> Uoffset(substitute loc st sb rn u, ofs) | Ulet(str, kind, id, u1, u2) -> let id' = VP.rename id in @@ -706,8 +732,6 @@ let rec substitute loc ((backend, fpc) as st) sb rn ulam = substitute loc st sb rn u2 else substitute loc st sb rn u3 - | Uprim(P.Pmakeblock _, _, _) -> - substitute loc st sb rn u2 | su1 -> Uifthenelse(su1, substitute loc st sb rn u2, substitute loc st sb rn u3, kind) @@ -744,6 +768,8 @@ type env = { cenv : ulambda V.Map.t; fenv : value_approximation V.Map.t; mutable_vars : V.Set.t; + kinds: value_kind V.Map.t; + catch_env : int Int.Map.t; } (* Perform an inline expansion: @@ -792,8 +818,12 @@ let bind_params { backend; mutable_vars; _ } loc fdesc params args funct body = let p1' = VP.rename p1 in let u1, u2 = match VP.name p1, a1 with - | "*opt*", Uprim(P.Pmakeblock(0, Immutable, kind, mode), - [a], dbg) -> + | "*opt*", Uprim(P.Pmakeblock(0, Immutable, kind, mode), [a], dbg) -> + (* This parameter corresponds to an optional parameter, + and although it is used twice pushing the expression down + actually allows us to remove the allocation as it will + appear once under a Pisint primitive and once under a Pfield + primitive (see [simplif_prim_pure]) *) a, Uprim(P.Pmakeblock(0, Immutable, kind, mode), [Uvar (VP.var p1')], dbg) | _ -> @@ -820,9 +850,6 @@ let bind_params { backend; mutable_vars; _ } loc fdesc params args funct body = in aux V.Map.empty params args body -(* Check if a lambda term is ``pure'', - that is without side-effects *and* not containing function definitions *) - let warning_if_forced_inlined ~loc ~attribute warning = if attribute = Always_inlined then Location.prerr_warning (Debuginfo.Scoped_location.to_location loc) @@ -949,7 +976,7 @@ let close_approx_var { fenv; cenv } id = let close_var env id = let (ulam, _app) = close_approx_var env id in ulam -let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = +let rec close ({ backend; fenv; cenv ; mutable_vars; kinds; catch_env } as env) lam = let module B = (val backend : Backend_intf.S) in match lam with | Lvar id -> @@ -1026,6 +1053,11 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = when nargs < nparams -> let first_args = List.map (fun arg -> (V.create_local "arg", arg) ) uargs in + (* CR mshinwell: Edit when Lapply has kinds *) + let kinds = + List.fold_left (fun kinds (arg, _) -> V.Map.add arg Pgenval kinds) + kinds first_args + in let final_args = Array.to_list (Array.init (nparams - nargs) (fun _ -> V.create_local "arg")) in @@ -1042,6 +1074,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = in let funct_var = V.create_local "funct" in let fenv = V.Map.add funct_var fapprox fenv in + let kinds = V.Map.add funct_var Pgenval kinds in let new_clos_mode, kind = (* If the closure has a local suffix, and we've supplied enough args to hit it, then the closure must be local @@ -1056,12 +1089,13 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = in if is_local_mode clos_mode then assert (is_local_mode new_clos_mode); let ret_mode = if fundesc.fun_region then alloc_heap else alloc_local in - let (new_fun, approx) = close { backend; fenv; cenv; mutable_vars } - (Lfunction{ - kind; - return = Pgenval; - params = List.map (fun v -> v, Pgenval) final_args; - body = Lapply{ + let (new_fun, approx) = + close { backend; fenv; cenv; mutable_vars; kinds; catch_env } + (lfunction + ~kind + ~return:Pgenval + ~params:(List.map (fun v -> v, Pgenval) final_args) + ~body:(Lapply{ ap_loc=loc; ap_func=(Lvar funct_var); ap_args=internal_args; @@ -1071,11 +1105,11 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = ap_inlined=Default_inlined; ap_specialised=Default_specialise; ap_probe=None; - }; - loc; - mode = new_clos_mode; - region = fundesc.fun_region; - attr = default_function_attribute}) + }) + ~loc + ~mode:new_clos_mode + ~region:fundesc.fun_region + ~attr:default_function_attribute) in let new_fun = iter first_args @@ -1089,6 +1123,11 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = _approx_res)), uargs) when nargs > nparams -> let args = List.map (fun arg -> V.create_local "arg", arg) uargs in + (* CR mshinwell: Edit when Lapply has kinds *) + let kinds = + List.fold_left (fun kinds (var, _) -> V.Map.add var Pgenval kinds) + kinds args + in let (first_args, rem_args) = split_list nparams args in let first_args = List.map (fun (id, _) -> Uvar id) first_args in let rem_args = List.map (fun (id, _) -> Uvar id) rem_args in @@ -1097,7 +1136,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = fail_if_probe ~probe "Over-application"; let mode' = if fundesc.fun_region then alloc_heap else alloc_local in let body = - Ugeneric_apply(direct_apply env ~loc ~attribute + Ugeneric_apply(direct_apply { env with kinds } ~loc ~attribute fundesc ufunct first_args Rc_normal mode' ~probe, @@ -1134,23 +1173,38 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = Value_unknown) | Llet(str, kind, id, lam, body) -> let (ulam, alam) = close_named env id lam in + let kinds = V.Map.add id kind kinds in begin match alam with | Value_const _ when str = Alias || is_pure ulam -> - close { backend; fenv = (V.Map.add id alam fenv); cenv; mutable_vars } + close { + backend; + fenv = (V.Map.add id alam fenv); + cenv; + mutable_vars; + kinds; + catch_env + } body | _ -> let (ubody, abody) = close - { backend; fenv = (V.Map.add id alam fenv); cenv; mutable_vars } + { backend; + fenv = (V.Map.add id alam fenv); + cenv; + mutable_vars; + kinds; + catch_env + } body in (Ulet(Immutable, kind, VP.create id, ulam, ubody), abody) end | Lmutlet(kind, id, lam, body) -> let (ulam, _) = close_named env id lam in + let kinds = V.Map.add id kind kinds in let env = {env with mutable_vars = V.Set.add id env.mutable_vars} in - let (ubody, abody) = close env body in + let (ubody, abody) = close { env with kinds } body in (Ulet(Mutable, kind, VP.create id, ulam, ubody), abody) | Lletrec(defs, body) -> if List.for_all @@ -1164,8 +1218,22 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = List.fold_right (fun (id, _pos, approx) fenv -> V.Map.add id approx fenv) infos fenv in + let kinds_body = + List.fold_right + (fun (id, _pos, _approx) kinds -> V.Map.add id Pgenval kinds) + infos (V.Map.add clos_ident Pgenval kinds) + in let (ubody, approx) = - close { backend; fenv = fenv_body; cenv; mutable_vars } body in + close + { backend; + fenv = fenv_body; + cenv; + mutable_vars; + kinds = kinds_body; + catch_env + } + body + in let sb = List.fold_right (fun (id, pos, _approx) sb -> @@ -1177,15 +1245,19 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = approx) end else begin (* General case: recursive definition of values *) + let kinds = + List.fold_left (fun kinds (id, _) -> V.Map.add id Pgenval kinds) + kinds defs + in let rec clos_defs = function [] -> ([], fenv) | (id, lam) :: rem -> let (udefs, fenv_body) = clos_defs rem in - let (ulam, approx) = close_named env id lam in + let (ulam, approx) = close_named { env with kinds } id lam in ((VP.create id, ulam) :: udefs, V.Map.add id approx fenv_body) in let (udefs, fenv_body) = clos_defs defs in let (ubody, approx) = - close { backend; fenv = fenv_body; cenv; mutable_vars } body in + close { backend; fenv = fenv_body; cenv; mutable_vars; kinds; catch_env } body in (Uletrec(udefs, ubody), approx) end (* Compile-time constants *) @@ -1208,39 +1280,28 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = | Lprim(Pignore, [arg], _loc) -> let expr, approx = make_const_int 0 in Usequence(fst (close env arg), expr), approx - | Lprim((Pidentity | Pbytes_to_string | Pbytes_of_string | Pobj_magic), + | Lprim(( Pbytes_to_string | Pbytes_of_string | Pobj_magic), [arg], _loc) -> close env arg - | Lprim(Pdirapply pos,[funct;arg], loc) - | Lprim(Prevapply pos,[arg;funct], loc) -> - close env - (Lapply{ - ap_loc=loc; - ap_func=funct; - ap_args=[arg]; - ap_region_close=pos; - ap_mode=alloc_heap; - ap_tailcall=Default_tailcall; - ap_inlined=Default_inlined; - ap_specialised=Default_specialise; - ap_probe=None; - }) - | Lprim(Pgetglobal id, [], loc) -> + | Lprim(Pgetglobal cu, [], loc) -> let dbg = Debuginfo.from_location loc in - check_constant_result (getglobal dbg id) - (Compilenv.global_approx id) + check_constant_result (getglobal dbg cu) + (Compilenv.global_approx cu) + | Lprim(Pgetpredef id, [], loc) -> + let dbg = Debuginfo.from_location loc in + getpredef dbg id, Value_unknown | Lprim(Pfield (n, _), [lam], loc) -> let (ulam, approx) = close env lam in let dbg = Debuginfo.from_location loc in check_constant_result (Uprim(P.Pfield n, [ulam], dbg)) (field_approx n approx) | Lprim(Psetfield(n, is_ptr, init), - [Lprim(Pgetglobal id, [], _); lam], loc)-> + [Lprim(Pgetglobal cu, [], _); lam], loc)-> let (ulam, approx) = close env lam in if approx <> Value_unknown then (!global_approx).(n) <- approx; let dbg = Debuginfo.from_location loc in - (Uprim(P.Psetfield(n, is_ptr, init), [getglobal dbg id; ulam], dbg), + (Uprim(P.Psetfield(n, is_ptr, init), [getglobal dbg cu; ulam], dbg), Value_unknown) | Lprim(Praise k, [arg], loc) -> let (ulam, _approx) = close env arg in @@ -1254,7 +1315,7 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = simplif_prim ~backend !Clflags.float_const_prop p (close_list_approx env args) dbg | Lswitch(arg, sw, dbg, kind) -> - let fn fail = + let fn env fail = let (uarg, _) = close env arg in let const_index, const_actions, fconst = close_switch env sw.sw_consts sw.sw_numconsts fail @@ -1274,17 +1335,18 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = (* NB: failaction might get copied, thus it should be some Lstaticraise *) let fail = sw.sw_failaction in begin match fail with - | None|Some (Lstaticraise (_,_)) -> fn fail + | None|Some (Lstaticraise (_,_)) -> fn env fail | Some lamfail -> if (sw.sw_numconsts - List.length sw.sw_consts) + (sw.sw_numblocks - List.length sw.sw_blocks) > 1 then let i = next_raise_count () in - let ubody,_ = fn (Some (Lstaticraise (i,[]))) + let body_env = { env with catch_env = Int.Map.add i i catch_env } in + let ubody,_ = fn body_env (Some (Lstaticraise (i,[]))) and uhandler,_ = close env lamfail in Ucatch (i,[],ubody,uhandler,kind),Value_unknown - else fn fail + else fn env fail end | Lstringswitch(arg,sw,d,_, kind) -> let uarg,_ = close env arg in @@ -1301,15 +1363,28 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = ud) d in Ustringswitch (uarg,usw,ud,kind),Value_unknown | Lstaticraise (i, args) -> - (Ustaticfail (i, close_list env args), Value_unknown) + let new_i = + match Int.Map.find i catch_env with + | new_i -> new_i + | exception Not_found -> + Misc.fatal_errorf "Static raise %d out of the scope of its handler" i + in + (Ustaticfail (new_i, close_list env args), Value_unknown) | Lstaticcatch(body, (i, vars), handler, kind) -> - let (ubody, _) = close env body in - let (uhandler, _) = close env handler in + let new_i = Lambda.next_raise_count () in + let body_env = { env with catch_env = Int.Map.add i new_i catch_env } in + let (ubody, _) = close body_env body in + let kinds = + List.fold_left (fun kinds (var, k) -> V.Map.add var k kinds) kinds vars + in + let (uhandler, _) = close { env with kinds } handler in let vars = List.map (fun (var, k) -> VP.create var, k) vars in - (Ucatch(i, vars, ubody, uhandler, kind), Value_unknown) + (Ucatch(new_i, vars, ubody, uhandler, kind), Value_unknown) | Ltrywith(body, id, handler, kind) -> let (ubody, _) = close env body in - let (uhandler, _) = close env handler in + let (uhandler, _) = + close { env with kinds = V.Map.add id Pgenval kinds } handler + in (Utrywith(ubody, VP.create id, uhandler, kind), Value_unknown) | Lifthenelse(arg, ifso, ifnot, kind) -> begin match close env arg with @@ -1332,7 +1407,9 @@ let rec close ({ backend; fenv; cenv ; mutable_vars } as env) lam = | Lfor {for_id; for_from; for_to; for_dir; for_body} -> let (ulo, _) = close env for_from in let (uhi, _) = close env for_to in - let (ubody, _) = close env for_body in + let (ubody, _) = + close { env with kinds = V.Map.add for_id Pintval kinds } for_body + in (Ufor(VP.create for_id, ulo, uhi, for_dir, ubody), Value_unknown) | Lassign(id, lam) -> let (ulam, _) = close env lam in @@ -1366,7 +1443,7 @@ and close_named env id = function (* Build a shared closure for a set of mutually recursive functions *) -and close_functions { backend; fenv; cenv; mutable_vars } fun_defs = +and close_functions { backend; fenv; cenv; mutable_vars; kinds; catch_env } fun_defs = let fun_defs = List.flatten (List.map @@ -1390,15 +1467,16 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs = (* Determine the free variables of the functions *) let fv = V.Set.elements (free_variables (Lletrec(fun_defs, lambda_unit))) in + let not_scanned_fv, scanned_fv = split_closure_fv kinds fv in + let not_scanned_fv_size = List.length not_scanned_fv in (* Build the function descriptors for the functions. Initially all functions are assumed not to need their environment parameter. *) let uncurried_defs = List.map (function - (id, Lfunction({kind; params; return; body; attr; loc; mode; region} - as funct)) -> - Lambda.check_lfunction funct; + (id, Lfunction( + {kind; params; return; body; attr; loc; mode; region})) -> let attrib = attr.check in let label = Symbol_utils.for_fun_ident ~compilation_unit:None loc id @@ -1412,6 +1490,7 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs = fun_closed = initially_closed; fun_inline = None; fun_float_const_prop = !Clflags.float_const_prop; + fun_poll = attr.poll; fun_region = region} in let dbg = Debuginfo.from_location loc in (id, params, return, body, mode, attrib, fundesc, dbg) @@ -1423,6 +1502,12 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs = (fun (id, _params, _return, _body, mode, _attrib, fundesc, _dbg) fenv -> V.Map.add id (Value_closure(mode, fundesc, Value_unknown)) fenv) uncurried_defs fenv in + let kinds_rec = + List.fold_right + (fun (id, _params, _return, _body, _mode, _attrib, _fundesc, _dbg) + kinds -> + V.Map.add id Pgenval kinds) + uncurried_defs kinds in (* Determine the offsets of each function's closure in the shared block *) let env_pos = ref (-1) in let clos_offsets = @@ -1441,14 +1526,34 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs = let clos_fundef (id, params, return, body, mode, check, fundesc, dbg) env_pos = let env_param = V.create_local "env" in let cenv_fv = - build_closure_env env_param (fv_pos - env_pos) fv in + add_to_closure_env env_param + (fv_pos - env_pos) V.Map.empty not_scanned_fv + in + let cenv_fv = + add_to_closure_env env_param + (fv_pos - env_pos + not_scanned_fv_size) cenv_fv scanned_fv + in let cenv_body = List.fold_right2 (fun (id, _params, _return, _body, _mode, _attrib, _fundesc, _dbg) pos env -> V.Map.add id (Uoffset(Uvar env_param, pos - env_pos)) env) - uncurried_defs clos_offsets cenv_fv in + uncurried_defs clos_offsets cenv_fv + in + let kinds_body = + List.fold_right + (fun (id, kind) kinds -> V.Map.add id kind kinds) + params (V.Map.add env_param Pgenval kinds_rec) + in let (ubody, approx) = - close { backend; fenv = fenv_rec; cenv = cenv_body; mutable_vars } body + close + { backend; + fenv = fenv_rec; + cenv = cenv_body; + mutable_vars; + kinds = kinds_body; + catch_env + } + body in if !useless_env && occurs_var env_param ubody then raise NotClosed; let fun_params = @@ -1465,6 +1570,7 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs = body = ubody; dbg; env = Some env_param; + poll = fundesc.fun_poll; mode; check; } @@ -1521,9 +1627,14 @@ and close_functions { backend; fenv; cenv; mutable_vars } fun_defs = (* Return the Uclosure node and the list of all identifiers defined, with offsets and approximations. *) let (clos, infos) = List.split clos_info_list in - let fv = if !useless_env then [] else fv in - (Uclosure(clos, - List.map (close_var { backend; fenv; cenv; mutable_vars }) fv), + let not_scanned_fv, scanned_fv = + if !useless_env then [], [] else not_scanned_fv, scanned_fv in + let env = { backend; fenv; cenv; mutable_vars; kinds; catch_env } in + (Uclosure { + functions = clos ; + not_scanned_slots = List.map (close_var env) not_scanned_fv ; + scanned_slots = List.map (close_var env) scanned_fv + }, infos) (* Same, for one non-recursive function *) @@ -1614,9 +1725,10 @@ let collect_exported_structured_constants a = | Uconst c -> const c | Udirect_apply (_, ul, _, _, _) -> List.iter ulam ul | Ugeneric_apply (u, ul, _, _) -> ulam u; List.iter ulam ul - | Uclosure (fl, ul) -> - List.iter (fun f -> ulam f.body) fl; - List.iter ulam ul + | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> + List.iter (fun f -> ulam f.body) functions; + List.iter ulam not_scanned_slots; + List.iter ulam scanned_slots | Uoffset(u, _) -> ulam u | Ulet (_str, _kind, _, u1, u2) -> ulam u1; ulam u2 | Uphantom_let _ -> no_phantom_lets () @@ -1662,14 +1774,14 @@ let intro ~backend ~size lam = Compilenv.set_global_approx(Value_tuple (alloc_heap, !global_approx)); let (ulam, _approx) = close { backend; fenv = V.Map.empty; - cenv = V.Map.empty; mutable_vars = V.Set.empty } lam + cenv = V.Map.empty; mutable_vars = V.Set.empty; + kinds = V.Map.empty; catch_env = Int.Map.empty } lam in let opaque = !Clflags.opaque || Env.is_imported_opaque (Compilation_unit.get_current_exn () - |> Compilation_unit.name - |> Compilation_unit.Name.to_string) + |> Compilation_unit.name) in if opaque then Compilenv.set_global_approx(Value_unknown) diff --git a/middle_end/closure/closure_middle_end.ml b/middle_end/closure/closure_middle_end.ml index a283284c480..21cedc87a53 100644 --- a/middle_end/closure/closure_middle_end.ml +++ b/middle_end/closure/closure_middle_end.ml @@ -38,7 +38,8 @@ let lambda_to_clambda ~backend ~filename:_ ~prefixname:_ ~ppf_dump let current_unit_ident = Compilation_unit.get_current_exn () |> Compilation_unit.name - |> Compilation_unit.Name.persistent_ident + |> Compilation_unit.Name.to_string + |> Ident.create_persistent in { original_idents = []; (* CR-someday lmaurer: Properly construct a [Path.t] from the module name diff --git a/middle_end/compilenv.ml b/middle_end/compilenv.ml index 8f26869bda7..7886599a4cc 100644 --- a/middle_end/compilenv.ml +++ b/middle_end/compilenv.ml @@ -24,12 +24,14 @@ open Config open Cmx_format +module File_sections = Flambda_backend_utils.File_sections + module CU = Compilation_unit type error = Not_a_unit_info of string | Corrupted_unit_info of string - | Illegal_renaming of CU.Name.t * CU.Name.t * string + | Illegal_renaming of CU.t * CU.t * string exception Error of error @@ -130,7 +132,7 @@ let reset compilation_unit = CU.Name.Tbl.clear global_infos_table; Set_of_closures_id.Tbl.clear imported_sets_of_closures_table; Checks.reset cached_checks; - CU.set_current compilation_unit; + CU.set_current (Some compilation_unit); current_unit.ui_unit <- compilation_unit; current_unit.ui_defines <- [compilation_unit]; current_unit.ui_imports_cmi <- []; @@ -156,9 +158,31 @@ let read_unit_info filename = close_in ic; raise(Error(Not_a_unit_info filename)) end; - let ui = (input_value ic : unit_infos) in + let uir = (input_value ic : unit_infos_raw) in + let first_section_offset = pos_in ic in + seek_in ic (first_section_offset + uir.uir_sections_length); let crc = Digest.input ic in - close_in ic; + (* This consumes the channel *) + let sections = File_sections.create uir.uir_section_toc filename ic ~first_section_offset in + let export_info = + match uir.uir_export_info with + | Clambda_raw info -> Clambda info + | Flambda1_raw info -> Flambda1 info + | Flambda2_raw None -> Flambda2 None + | Flambda2_raw (Some info) -> + Flambda2 (Some (Flambda2_cmx.Flambda_cmx_format.from_raw ~sections info)) + in + let ui = { + ui_unit = uir.uir_unit; + ui_defines = uir.uir_defines; + ui_imports_cmi = uir.uir_imports_cmi |> Array.to_list; + ui_imports_cmx = uir.uir_imports_cmx |> Array.to_list; + ui_generic_fns = uir.uir_generic_fns; + ui_export_info = export_info; + ui_checks = uir.uir_checks; + ui_force_link = uir.uir_force_link + } + in (ui, crc) with End_of_file | Failure _ -> close_in ic; @@ -176,47 +200,54 @@ let read_library_info filename = (* Read and cache info on global identifiers *) -let get_unit_info modname = - if CU.Name.equal modname (CU.name current_unit.ui_unit) +let get_unit_info comp_unit = + (* If this fails, it likely means that someone didn't call + [CU.which_cmx_file]. *) + assert (CU.can_access_cmx_file comp_unit ~accessed_by:current_unit.ui_unit); + (* CR lmaurer: Surely this should just compare [comp_unit] to + [current_unit.ui_unit], but doing so seems to break Closure. We should fix + that. *) + if CU.Name.equal (CU.name comp_unit) (CU.name current_unit.ui_unit) then Some current_unit else begin + let cmx_name = CU.name comp_unit in try - CU.Name.Tbl.find global_infos_table modname + CU.Name.Tbl.find global_infos_table cmx_name with Not_found -> let (infos, crc) = - if Env.is_imported_opaque (modname |> CU.Name.to_string) - then (None, None) + if Env.is_imported_opaque cmx_name then (None, None) else begin try let filename = - Load_path.find_uncap ((modname |> CU.Name.to_string) ^ ".cmx") in + Load_path.find_uncap ((cmx_name |> CU.Name.to_string) ^ ".cmx") in let (ui, crc) = read_unit_info filename in - if not (CU.Name.equal (CU.name ui.ui_unit) modname) then - raise(Error(Illegal_renaming(modname, CU.name ui.ui_unit, - filename))); + if not (CU.equal ui.ui_unit comp_unit) then + raise(Error(Illegal_renaming(comp_unit, ui.ui_unit, filename))); cache_checks ui.ui_checks; (Some ui, Some crc) with Not_found -> - let warn = Warnings.No_cmx_file (modname |> CU.Name.to_string) in + let warn = Warnings.No_cmx_file (cmx_name |> CU.Name.to_string) in Location.prerr_warning Location.none warn; (None, None) end in - current_unit.ui_imports_cmx <- - (modname |> CU.Name.to_string, crc) :: current_unit.ui_imports_cmx; - CU.Name.Tbl.add global_infos_table modname infos; + let import = Import_info.create_normal comp_unit ~crc in + current_unit.ui_imports_cmx <- import :: current_unit.ui_imports_cmx; + CU.Name.Tbl.add global_infos_table cmx_name infos; infos end -let get_unit_export_info modname = - match get_unit_info modname with +let which_cmx_file comp_unit = + CU.which_cmx_file comp_unit ~accessed_by:(CU.get_current_exn ()) + +let get_unit_export_info comp_unit = + match get_unit_info comp_unit with | None -> None | Some ui -> Some ui.ui_export_info -let get_global_info global_ident = - assert (Ident.is_global global_ident); - get_unit_info (global_ident |> Ident.name |> CU.Name.of_string) +let get_global_info comp_unit = + get_unit_info (which_cmx_file comp_unit) let get_global_export_info id = match get_global_info id with @@ -236,49 +267,20 @@ let get_clambda_approx ui = | Clambda approx -> approx let toplevel_approx : - (string, Clambda.value_approximation) Hashtbl.t = Hashtbl.create 16 + (CU.t, Clambda.value_approximation) Hashtbl.t = Hashtbl.create 16 let record_global_approx_toplevel () = Hashtbl.add toplevel_approx - (CU.Name.to_string (CU.name current_unit.ui_unit)) + current_unit.ui_unit (get_clambda_approx current_unit) -let global_approx id = - if Ident.is_predef id then Clambda.Value_unknown - else try Hashtbl.find toplevel_approx (Ident.name id) +let global_approx comp_unit = + try Hashtbl.find toplevel_approx comp_unit with Not_found -> - match get_global_info id with + match get_global_info comp_unit with | None -> Clambda.Value_unknown | Some ui -> get_clambda_approx ui -(* Determination of pack prefixes for units and identifiers *) - -let pack_prefix_for_current_unit () = - CU.for_pack_prefix current_unit.ui_unit - -let pack_prefix_for_global_ident id = - if not (Ident.is_global id) then - Misc.fatal_errorf "Identifier %a is not global" Ident.print id - else if Hashtbl.mem toplevel_approx (Ident.name id) then - CU.for_pack_prefix (CU.get_current_exn ()) - else - match get_global_info id with - | Some ui -> CU.for_pack_prefix ui.ui_unit - | None -> - (* If the .cmx file is missing, the prefix is assumed to be empty. *) - CU.Prefix.empty - -let symbol_for_global' id = - assert (Ident.is_global_or_predef id); - let pack_prefix = - if Ident.is_global id then pack_prefix_for_global_ident id - else CU.Prefix.empty - in - Symbol.for_global_or_predef_ident pack_prefix id - -let symbol_for_global id = - symbol_for_global' id |> Symbol.linkage_name - (* Register the approximation of the module being compiled *) let set_global_approx approx = @@ -301,67 +303,19 @@ let flambda2_set_export_info export_info = assert(Config.flambda2); current_unit.ui_export_info <- Flambda2 (Some export_info) -(* Determine which .cmx file to load for a given compilation unit. - This is tricky in the case of packs. It can be done by lining up the - desired compilation unit's full path (i.e. pack prefix then unit name) - against the current unit's full path and observing when/if they diverge. *) -let which_cmx_file desired_comp_unit = - let desired_prefix = CU.for_pack_prefix desired_comp_unit in - if CU.Prefix.is_empty desired_prefix then - (* If the unit we're looking for is not in a pack, then the correct .cmx - file is the one with the same name as the unit, irrespective of any - current pack. *) - CU.name desired_comp_unit - else - let current_comp_unit = Compilation_unit.get_current_exn () in - (* This lines up the full paths as described above. *) - let rec match_components ~current ~desired = - match current, desired with - | current_name::current, desired_name::desired -> - if CU.Name.equal current_name desired_name then - (* The full paths are equal up to the current point; keep going. *) - match_components ~current ~desired - else - (* The paths have diverged. The next component of the desired - path is the .cmx file to load. *) - desired_name - | [], desired_name::_desired -> - (* The whole of the current unit's full path (including the name of - the unit itself) is now known to be a prefix of the desired unit's - pack *prefix*. This means we must be making a pack. The .cmx - file to load is named after the next component of the desired - unit's path (which may in turn be a pack). *) - desired_name - | [], [] -> - (* The paths were equal, so the desired compilation unit is just the - current one. *) - CU.name desired_comp_unit - | _::_, [] -> - (* The current path is longer than the desired unit's path, which - means we're attempting to go back up the pack hierarchy. This is - an error. *) - Misc.fatal_errorf "Compilation unit@ %a@ is inaccessible when \ - compiling compilation unit@ %a" - CU.print desired_comp_unit - CU.print current_comp_unit - in - match_components ~current:(CU.full_path current_comp_unit) - ~desired:(CU.full_path desired_comp_unit) - let approx_for_global comp_unit = if CU.equal comp_unit CU.predef_exn then invalid_arg "approx_for_global with predef_exn compilation unit"; - let comp_unit_name = which_cmx_file comp_unit in - let id = Ident.create_persistent (comp_unit_name |> CU.Name.to_string) in - let modname = Ident.name id |> CU.Name.of_string in - match CU.Name.Tbl.find export_infos_table modname with + let accessible_comp_unit = which_cmx_file comp_unit in + let cmx_name = CU.name accessible_comp_unit in + match CU.Name.Tbl.find export_infos_table cmx_name with | otherwise -> Some otherwise | exception Not_found -> - match get_global_info id with + match get_unit_info accessible_comp_unit with | None -> None | Some ui -> let exported = get_flambda_export_info ui in - CU.Name.Tbl.add export_infos_table modname exported; + CU.Name.Tbl.add export_infos_table cmx_name exported; merged_environment := Export_info.merge !merged_environment exported; Some exported @@ -390,10 +344,55 @@ let need_send_fun n mode = (* Write the description of the current unit *) +(* CR mshinwell: let's think about this later, quadratic algorithm + +let ensure_sharing_between_cmi_and_cmx_imports cmi_imports cmx_imports = + (* If a [CU.t] in the .cmx imports also occurs in the .cmi imports, use + the one in the .cmi imports, to increase sharing. (Such a [CU.t] in + the .cmi imports may already have part of its value shared with the + first [CU.Name.t] component in the .cmi imports, c.f. + [Persistent_env.ensure_crc_sharing], so it's best to pick this [CU.t].) *) + List.map (fun ((comp_unit, crc) as import) -> + match + List.find_map (function + | _, None -> None + | _, Some (comp_unit', _) -> + if CU.equal comp_unit comp_unit' then Some comp_unit' + else None) + cmi_imports + with + | None -> import + | Some comp_unit -> comp_unit, crc) + cmx_imports +*) + let write_unit_info info filename = + let raw_export_info, sections = + match info.ui_export_info with + | Clambda info -> Clambda_raw info, File_sections.empty + | Flambda1 info -> Flambda1_raw info, File_sections.empty + | Flambda2 None -> Flambda2_raw None, File_sections.empty + | Flambda2 (Some info) -> + let info, sections = Flambda2_cmx.Flambda_cmx_format.to_raw info in + Flambda2_raw (Some info), sections + in + let serialized_sections, toc, total_length = File_sections.serialize sections in + let raw_info = { + uir_unit = info.ui_unit; + uir_defines = info.ui_defines; + uir_imports_cmi = Array.of_list info.ui_imports_cmi; + uir_imports_cmx = Array.of_list info.ui_imports_cmx; + uir_generic_fns = info.ui_generic_fns; + uir_export_info = raw_export_info; + uir_checks = info.ui_checks; + uir_force_link = info.ui_force_link; + uir_section_toc = toc; + uir_sections_length = total_length; + } in let oc = open_out_bin filename in output_string oc cmx_magic_number; - output_value oc info; + output_value oc raw_info; + Array.iter (output_string oc) serialized_sections; flush oc; let crc = Digest.file filename in Digest.output oc crc; @@ -463,8 +462,7 @@ let structured_constants () = }) let require_global global_ident = - if not (Ident.is_predef global_ident) then - ignore (get_global_info global_ident : Cmx_format.unit_infos option) + ignore (get_global_info global_ident : Cmx_format.unit_infos option) (* Error report *) @@ -481,8 +479,8 @@ let report_error ppf = function fprintf ppf "%a@ contains the description for unit\ @ %a when %a was expected" Location.print_filename filename - CU.Name.print name - CU.Name.print modname + CU.print name + CU.print modname let () = Location.register_error_of_exn diff --git a/middle_end/compilenv.mli b/middle_end/compilenv.mli index 0d18d71636a..9494861868d 100644 --- a/middle_end/compilenv.mli +++ b/middle_end/compilenv.mli @@ -38,19 +38,7 @@ val reset_info_tables: unit -> unit val current_unit_infos: unit -> unit_infos (* Return the infos for the unit being compiled *) -val pack_prefix_for_current_unit : unit -> Compilation_unit.Prefix.t - (* Return the pack prefix for the unit being compiled *) - -val pack_prefix_for_global_ident : Ident.t -> Compilation_unit.Prefix.t - (* Find the pack prefix for an identifier by reading the .cmx file. - The identifier must be [Global]. *) - -val symbol_for_global: Ident.t -> Linkage_name.t - (* Return the asm symbol that refers to the given global identifier - flambda-only *) -val symbol_for_global': Ident.t -> Symbol.t - (* flambda-only *) -val global_approx: Ident.t -> Clambda.value_approximation +val global_approx: Compilation_unit.t -> Clambda.value_approximation (* Return the approximation for the given global identifier clambda-only *) val set_global_approx: Clambda.value_approximation -> unit @@ -70,11 +58,12 @@ val approx_for_global: Compilation_unit.t -> Export_info.t option (* Loads the exported information declaring the compilation_unit flambda-only *) -val get_global_export_info : Ident.t -> Cmx_format.export_info option +val get_global_export_info : Compilation_unit.t -> Cmx_format.export_info option (* Middle-end-agnostic means of getting the export info found in the .cmx file of the given unit. *) -val get_unit_export_info : Compilation_unit.Name.t -> Cmx_format.export_info option +val get_unit_export_info + : Compilation_unit.t -> Cmx_format.export_info option val flambda2_set_export_info : Flambda2_cmx.Flambda_cmx_format.t -> unit (* Set the export information for the current unit (Flambda 2 only). *) @@ -137,17 +126,23 @@ val cache_unit_info: unit_infos -> unit honored by [symbol_for_global] and [global_approx] without looking at the corresponding .cmx file. *) -val require_global: Ident.t -> unit +val require_global: Compilation_unit.t -> unit (* Enforce a link dependency of the current compilation unit to the required module *) val read_library_info: string -> library_infos +(* CR mshinwell: see comment in .ml +val ensure_sharing_between_cmi_and_cmx_imports : + (_ * (Compilation_unit.t * _) option) list -> + (Compilation_unit.t * 'a) list -> + (Compilation_unit.t * 'a) list +*) + type error = Not_a_unit_info of string | Corrupted_unit_info of string - | Illegal_renaming of - Compilation_unit.Name.t * Compilation_unit.Name.t * string + | Illegal_renaming of Compilation_unit.t * Compilation_unit.t * string exception Error of error diff --git a/middle_end/convert_primitives.ml b/middle_end/convert_primitives.ml index 0989cefb8e5..b94c75c8e80 100644 --- a/middle_end/convert_primitives.ml +++ b/middle_end/convert_primitives.ml @@ -159,11 +159,9 @@ let convert (prim : Lambda.primitive) : Clambda_primitives.primitive = | Pbytes_of_string | Pctconst _ | Pignore - | Prevapply _ - | Pdirapply _ - | Pidentity | Pgetglobal _ | Psetglobal _ + | Pgetpredef _ -> Misc.fatal_errorf "lambda primitive %a can't be converted to \ clambda primitive" diff --git a/middle_end/flambda/augment_specialised_args.ml b/middle_end/flambda/augment_specialised_args.ml index 3740fb1d5ea..024af89169c 100644 --- a/middle_end/flambda/augment_specialised_args.ml +++ b/middle_end/flambda/augment_specialised_args.ml @@ -22,18 +22,19 @@ module B = Inlining_cost.Benefit module Definition = struct type t = - | Existing_inner_free_var of Variable.t - | Projection_from_existing_specialised_arg of Projection.t + | Existing_inner_free_var of Variable.t * Lambda.value_kind + | Projection_from_existing_specialised_arg of Projection.t * Lambda.value_kind include Identifiable.Make (struct type nonrec t = t let compare t1 t2 = match t1, t2 with - | Existing_inner_free_var var1, Existing_inner_free_var var2 -> + | Existing_inner_free_var (var1, _), + Existing_inner_free_var (var2, _) -> Variable.compare var1 var2 - | Projection_from_existing_specialised_arg proj1, - Projection_from_existing_specialised_arg proj2 -> + | Projection_from_existing_specialised_arg (proj1, _), + Projection_from_existing_specialised_arg (proj2, _) -> Projection.compare proj1 proj2 | Existing_inner_free_var _, _ -> -1 | _, Existing_inner_free_var _ -> 1 @@ -45,12 +46,12 @@ module Definition = struct let print ppf t = match t with - | Existing_inner_free_var var -> - Format.fprintf ppf "Existing_inner_free_var %a" - Variable.print var - | Projection_from_existing_specialised_arg projection -> - Format.fprintf ppf "Projection_from_existing_specialised_arg %a" - Projection.print projection + | Existing_inner_free_var (var, kind) -> + Format.fprintf ppf "Existing_inner_free_var (%a, %a)" + Variable.print var Printlambda.value_kind kind + | Projection_from_existing_specialised_arg (projection, kind) -> + Format.fprintf ppf "Projection_from_existing_specialised_arg (%a, %a)" + Projection.print projection Printlambda.value_kind kind let output _ _ = failwith "Definition.output not yet implemented" end) @@ -163,7 +164,7 @@ module Processed_what_to_specialise = struct let existing_outer_var = match definition with | Existing_inner_free_var _ -> None - | Projection_from_existing_specialised_arg projection -> + | Projection_from_existing_specialised_arg (projection, _) -> let projection = lift_projection t ~projection in match Projection.Map.find projection @@ -176,7 +177,7 @@ module Processed_what_to_specialise = struct | Some existing_outer_var -> existing_outer_var, t | None -> match definition with - | Existing_inner_free_var existing_inner_var -> + | Existing_inner_free_var (existing_inner_var, _) -> begin match Variable.Map.find existing_inner_var t.set_of_closures.free_vars @@ -190,7 +191,7 @@ module Processed_what_to_specialise = struct Flambda.print_set_of_closures t.set_of_closures | existing_outer_var -> existing_outer_var.var, t end - | Projection_from_existing_specialised_arg projection -> + | Projection_from_existing_specialised_arg (projection, _) -> let new_outer_var = Variable.rename group in let projection = lift_projection t ~projection in let new_outer_vars_indexed_by_new_lifted_defns = @@ -294,9 +295,10 @@ module Processed_what_to_specialise = struct else let definition : Definition.t = match spec_to.projection with - | None -> Existing_inner_free_var inner_var + | None -> Existing_inner_free_var (inner_var, spec_to.kind) | Some projection -> - Projection_from_existing_specialised_arg projection + Projection_from_existing_specialised_arg + (projection, spec_to.kind) in Definition.Set.add definition definitions) what_to_specialise.set_of_closures.specialised_args @@ -481,15 +483,16 @@ module Make (T : S) = struct let definition : Definition.t = match (definition : Definition.t) with | Existing_inner_free_var _ -> definition - | Projection_from_existing_specialised_arg projection -> + | Projection_from_existing_specialised_arg (projection, kind) -> Projection_from_existing_specialised_arg (Projection.map_projecting_from projection - ~f:find_wrapper_param) + ~f:find_wrapper_param, + kind) in let benefit = match (definition : Definition.t) with | Existing_inner_free_var _ -> benefit - | Projection_from_existing_specialised_arg projection -> + | Projection_from_existing_specialised_arg (projection, _) -> B.add_projection projection benefit in match @@ -500,9 +503,9 @@ module Make (T : S) = struct | new_inner_var_of_wrapper -> let named : Flambda.named = match definition with - | Existing_inner_free_var existing_inner_var -> + | Existing_inner_free_var (existing_inner_var, _) -> Expr (Var existing_inner_var) - | Projection_from_existing_specialised_arg projection -> + | Projection_from_existing_specialised_arg (projection, _) -> Flambda_utils.projection_to_named projection in let wrapper_body = @@ -526,6 +529,7 @@ module Make (T : S) = struct let spec_to : Flambda.specialised_to = { var = spec_to.var; projection; + kind = spec_to.kind; } in Variable.Map.add inner_var spec_to result) @@ -549,6 +553,7 @@ module Make (T : S) = struct ~check:Default_check ~is_a_functor:false ~closure_origin:function_decl.closure_origin + ~poll:Default_poll (* don't propagate attribute to wrappers *) in new_fun_var, new_function_decl, rewritten_existing_specialised_args, benefit @@ -583,11 +588,12 @@ module Make (T : S) = struct | exception Not_found -> assert false | new_outer_var -> match definition with - | Existing_inner_free_var _ -> + | Existing_inner_free_var (_, kind) -> { var = new_outer_var; projection = None; + kind; } - | Projection_from_existing_specialised_arg projection -> + | Projection_from_existing_specialised_arg (projection, kind) -> let projecting_from = Projection.projecting_from projection in assert (Variable.Map.mem projecting_from set_of_closures.specialised_args); @@ -595,6 +601,7 @@ module Make (T : S) = struct (Parameter.Set.vars function_decl.params)); { var = new_outer_var; projection = Some projection; + kind; }) for_one_function.new_definitions_indexed_by_new_inner_vars in @@ -624,7 +631,17 @@ module Make (T : S) = struct function_decl.alloc_mode function_decl.params in let new_params = - List.map (fun p -> Parameter.wrap p last_mode) new_params + List.map (fun p -> + let definition = + Variable.Map.find p + for_one_function.new_definitions_indexed_by_new_inner_vars + in + let kind = + match definition with + | Existing_inner_free_var (_, kind) -> kind + | Projection_from_existing_specialised_arg (_, kind) -> kind + in + Parameter.wrap p last_mode kind) new_params in function_decl.params @ new_params in @@ -643,6 +660,7 @@ module Make (T : S) = struct ~check:function_decl.check ~is_a_functor:function_decl.is_a_functor ~closure_origin + ~poll:function_decl.poll in let funs, direct_call_surrogates = if for_one_function.make_direct_call_surrogates then diff --git a/middle_end/flambda/augment_specialised_args.mli b/middle_end/flambda/augment_specialised_args.mli index 910a2d1532f..949baea0b93 100644 --- a/middle_end/flambda/augment_specialised_args.mli +++ b/middle_end/flambda/augment_specialised_args.mli @@ -18,8 +18,8 @@ module Definition : sig type t = - | Existing_inner_free_var of Variable.t - | Projection_from_existing_specialised_arg of Projection.t + | Existing_inner_free_var of Variable.t * Lambda.value_kind + | Projection_from_existing_specialised_arg of Projection.t * Lambda.value_kind end module What_to_specialise : sig diff --git a/middle_end/flambda/closure_conversion.ml b/middle_end/flambda/closure_conversion.ml index 9dd4da666fa..3ac2c5f2968 100644 --- a/middle_end/flambda/closure_conversion.ml +++ b/middle_end/flambda/closure_conversion.ml @@ -14,7 +14,7 @@ (* *) (**************************************************************************) -[@@@ocaml.warning "+a-4-9-30-40-41-42-66"] +[@@@ocaml.warning "+a-4-9-30-40-41-42-66-69"] open! Int_replace_polymorphic_compare module Env = Closure_conversion_aux.Env @@ -26,17 +26,13 @@ let name_expr = Flambda_utils.name_expr let name_expr_from_var = Flambda_utils.name_expr_from_var type t = { - current_unit_id : Ident.t; + current_unit : Compilation_unit.t; filename : string; backend : (module Backend_intf.S); mutable imported_symbols : Symbol.Set.t; mutable declared_symbols : (Symbol.t * Flambda.constant_defining_value) list; } -let pack_prefix_for_global_ident t = - let module B = (val t.backend : Backend_intf.S) in - B.pack_prefix_for_global_ident - let add_default_argument_wrappers lam = let defs_are_all_functions (defs : (_ * Lambda.lambda) list) = List.for_all (function (_, Lambda.Lfunction _) -> true | _ -> false) defs @@ -107,11 +103,12 @@ let tupled_function_call_stub original_params unboxed_version ~closure_bound_var in (* Tupled functions are always Alloc_heap. See translcore.ml *) let alloc_mode = Lambda.alloc_heap in - let tuple_param = Parameter.wrap tuple_param_var alloc_mode in + let tuple_param = Parameter.wrap tuple_param_var alloc_mode Pgenval in Flambda.create_function_declaration ~params:[tuple_param] ~alloc_mode ~region ~body ~stub:true ~inline:Default_inline ~specialise:Default_specialise ~check:Default_check ~is_a_functor:false ~closure_origin:(Closure_origin.create (Closure_id.wrap closure_bound_var)) + ~poll:Default_poll (* don't propogate attribute to wrappers *) let register_const t (constant:Flambda.constant_defining_value) name : Flambda.constant_defining_value_block_field * Internal_variable_names.t = @@ -182,14 +179,14 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = match lam with | Lvar id -> begin match Env.find_var_exn env id with - | var -> Var var + | var, _kind -> Var var | exception Not_found -> Misc.fatal_errorf "Closure_conversion.close: unbound identifier %a" Ident.print id end | Lmutvar id -> begin match Env.find_mutable_var_exn env id with - | mut_var -> + | mut_var, _kind -> name_expr (Read_mutable mut_var) ~name:Names.read_mutable | exception Not_found -> Misc.fatal_errorf @@ -199,13 +196,12 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = | Lconst cst -> let cst, name = close_const t cst in name_expr cst ~name - | Llet ((Strict | Alias | StrictOpt), _value_kind, id, defining_expr, body) -> - (* TODO: keep value_kind in flambda *) + | Llet ((Strict | Alias | StrictOpt), value_kind, id, defining_expr, body) -> let var = Variable.create_with_same_name_as_ident id in let defining_expr = close_let_bound_expression t var env defining_expr in - let body = close t (Env.add_var env id var) body in + let body = close t (Env.add_var env id var value_kind) body in Flambda.create_let var defining_expr body | Lmutlet (block_kind, id, defining_expr, body) -> let mut_var = Mutable_variable.create_with_same_name_as_ident id in @@ -213,7 +209,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = let defining_expr = close_let_bound_expression t var env defining_expr in - let body = close t (Env.add_mutable_var env id mut_var) body in + let body = close t (Env.add_mutable_var env id mut_var block_kind) body in Flambda.create_let var defining_expr (Let_mutable { var = mut_var; @@ -232,7 +228,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = let set_of_closures = let decl = Function_decl.create ~let_rec_ident:None ~closure_bound_var ~kind ~mode - ~region ~params:(List.map fst params) ~body ~attr ~loc + ~region ~params ~body ~attr ~loc in close_functions t env (Function_decls.create [decl]) in @@ -267,7 +263,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = | Lletrec (defs, body) -> let env = List.fold_right (fun (id, _) env -> - Env.add_var env id (Variable.create_with_same_name_as_ident id)) + Env.add_var env id (Variable.create_with_same_name_as_ident id) Pgenval) defs env in let function_declarations = @@ -283,7 +279,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = let function_declaration = Function_decl.create ~let_rec_ident:(Some let_rec_ident) ~closure_bound_var ~kind ~mode ~region - ~params:(List.map fst params) ~body ~attr ~loc + ~params ~body ~attr ~loc in Some function_declaration | _ -> None) @@ -308,7 +304,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = List.fold_left (fun body decl -> let let_rec_ident = Function_decl.let_rec_ident decl in let closure_bound_var = Function_decl.closure_bound_var decl in - let let_bound_var = Env.find_var env let_rec_ident in + let let_bound_var, _kind = Env.find_var env let_rec_ident in (* Inside the body of the [let], each function is referred to by a [Project_closure] expression, which projects from the set of closures. *) @@ -327,7 +323,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = individual closures. *) let defs = List.map (fun (id, def) -> - let var = Env.find_var env id in + let var, _kind = Env.find_var env id in var, close_let_bound_expression t ~let_rec_ident:id var env def) defs in @@ -425,7 +421,7 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = (If_then_else (cond, arg2, Var const_false, Pintval))) | Lprim ((Psequand | Psequor), _, _) -> Misc.fatal_error "Psequand / Psequor must have exactly two arguments" - | Lprim ((Pidentity | Pbytes_to_string | Pbytes_of_string | Pobj_magic), + | Lprim ((Pbytes_to_string | Pbytes_of_string | Pobj_magic), [arg], _) -> close t env arg | Lprim (Pignore, [arg], _) -> @@ -435,24 +431,6 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = in Flambda.create_let var defining_expr (name_expr (Const (Int 0)) ~name:Names.unit) - | Lprim (Pdirapply pos, [funct; arg], loc) - | Lprim (Prevapply pos, [arg; funct], loc) -> - let apply : Lambda.lambda_apply = - { ap_func = funct; - ap_args = [arg]; - ap_region_close = pos; - ap_mode = Lambda.alloc_heap; - ap_loc = loc; - (* CR-someday lwhite: it would be nice to be able to give - application attributes to functions applied with the application - operators. *) - ap_tailcall = Default_tailcall; - ap_inlined = Default_inlined; - ap_specialised = Default_specialise; - ap_probe = None; - } - in - close t env (Lambda.Lapply apply) | Lprim (Praise kind, [arg], loc) -> let arg_var = Variable.create Names.raise_arg in let dbg = Debuginfo.from_location loc in @@ -479,22 +457,21 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = close t env (Lambda.Llet(Strict, Pgenval, Ident.create_local "dummy", arg, Lconst const)) - | Lprim (Pfield _, [Lprim (Pgetglobal id, [],_)], _) - when Ident.same id t.current_unit_id -> + | Lprim (Pfield _, [Lprim (Pgetglobal cu, [],_)], _) + when Compilation_unit.equal cu t.current_unit -> Misc.fatal_errorf "[Pfield (Pgetglobal ...)] for the current compilation \ unit is forbidden upon entry to the middle end" | Lprim (Psetfield (_, _, _), [Lprim (Pgetglobal _, [], _); _], _) -> Misc.fatal_errorf "[Psetfield (Pgetglobal ...)] is \ forbidden upon entry to the middle end" - | Lprim (Pgetglobal id, [], _) when Ident.is_predef id -> + | Lprim (Pgetpredef id, [], _) -> + assert (Ident.is_predef id); let symbol = Symbol.for_predef_ident id in t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols; name_expr (Symbol symbol) ~name:Names.predef_exn - | Lprim (Pgetglobal id, [], _) -> - assert (not (Ident.same id t.current_unit_id)); - let symbol = - Symbol.for_global_or_predef_ident ((pack_prefix_for_global_ident t) id) id - in + | Lprim (Pgetglobal cu, [], _) -> + assert (not (Compilation_unit.equal cu t.current_unit)); + let symbol = Symbol.for_compilation_unit cu in t.imported_symbols <- Symbol.Set.add symbol t.imported_symbols; name_expr (Symbol symbol) ~name:Names.pgetglobal | Lprim (lambda_p, args, loc) -> @@ -548,15 +525,16 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = | Lstaticcatch (body, (i, ids), handler, kind) -> let st_exn = Static_exception.create () in let env = Env.add_static_exception env i st_exn in - let ids = List.map fst ids in let vars = - List.map (fun ident -> Variable.create_with_same_name_as_ident ident) ids + List.map (fun (ident, kind) -> + (Variable.create_with_same_name_as_ident ident, kind)) ids in - Static_catch (st_exn, vars, close t env body, - close t (Env.add_vars env ids vars) handler, kind) + Static_catch (st_exn, List.map fst vars, close t env body, + close t (Env.add_vars env (List.map fst ids) vars) handler, kind) | Ltrywith (body, id, handler, kind) -> let var = Variable.create_with_same_name_as_ident id in - Try_with (close t env body, var, close t (Env.add_var env id var) handler, + Try_with (close t env body, var, + close t (Env.add_var env id var Pgenval) handler, kind) | Lifthenelse (cond, ifso, ifnot, kind) -> let cond = close t env cond in @@ -574,12 +552,12 @@ let rec close t env (lam : Lambda.lambda) : Flambda.t = let bound_var = Variable.create_with_same_name_as_ident for_id in let from_value = Variable.create Names.for_from in let to_value = Variable.create Names.for_to in - let body = close t (Env.add_var env for_id bound_var) for_body in + let body = close t (Env.add_var env for_id bound_var Pintval) for_body in Flambda.create_let from_value (Expr (close t env for_from)) (Flambda.create_let to_value (Expr (close t env for_to)) (For { bound_var; from_value; to_value; direction=for_dir; body; })) | Lassign (id, new_value) -> - let being_assigned = + let being_assigned, _kind = match Env.find_mutable_var_exn env id with | being_assigned -> being_assigned | exception Not_found -> @@ -619,8 +597,8 @@ and close_functions t external_env function_declarations : Flambda.named = This induces a renaming on [Function_decl.free_idents]; the results of that renaming are stored in [free_variables]. *) let closure_env = - List.fold_right (fun id env -> - Env.add_var env id (Variable.create_with_same_name_as_ident id)) + List.fold_right (fun (id, kind) env -> + Env.add_var env id (Variable.create_with_same_name_as_ident id) kind) params closure_env_without_parameters in (* If the function is the wrapper for a function with an optional @@ -628,7 +606,7 @@ and close_functions t external_env function_declarations : Flambda.named = CR-someday pchambart: eta-expansion wrapper for a primitive are not marked as stub but certainly should *) let stub = Function_decl.stub decl in - let param_vars = List.map (Env.find_var closure_env) params in + let param_vars = List.map (fun (id, _) -> Env.find_var closure_env id) params in let nheap = match Function_decl.mode decl, Function_decl.kind decl with | _, Curried {nlocal} -> List.length params - nlocal @@ -636,11 +614,11 @@ and close_functions t external_env function_declarations : Flambda.named = | Alloc_local, Tupled -> Misc.fatal_error "Closure_conversion: Tupled Alloc_local function found" in - let params = List.mapi (fun i v -> + let params = List.mapi (fun i (v, kind) -> let alloc_mode = if i < nheap then Lambda.alloc_heap else Lambda.alloc_local in - Parameter.wrap v alloc_mode) param_vars + Parameter.wrap v alloc_mode kind) param_vars in let closure_bound_var = Function_decl.closure_bound_var decl in let unboxed_version = Variable.rename closure_bound_var in @@ -657,6 +635,7 @@ and close_functions t external_env function_declarations : Flambda.named = ~check:(Function_decl.check decl) ~is_a_functor:(Function_decl.is_a_functor decl) ~closure_origin + ~poll:(Function_decl.poll_attribute decl) in match Function_decl.kind decl with | Curried _ -> @@ -664,7 +643,7 @@ and close_functions t external_env function_declarations : Flambda.named = | Tupled -> let unboxed_version = Variable.rename closure_bound_var in let generic_function_stub = - tupled_function_call_stub param_vars unboxed_version + tupled_function_call_stub (List.map fst param_vars) unboxed_version ~closure_bound_var ~region in Variable.Map.add unboxed_version fun_decl @@ -684,13 +663,12 @@ and close_functions t external_env function_declarations : Flambda.named = let set_of_closures = let free_vars = Ident.Set.fold (fun var map -> - let internal_var = + let internal_var, _ = Env.find_var closure_env_without_parameters var in + let var, kind = Env.find_var external_env var in let external_var : Flambda.specialised_to = - { var = Env.find_var external_env var; - projection = None; - } + { var ; projection = None; kind } in Variable.Map.add internal_var external_var map) all_free_idents Variable.Map.empty @@ -715,7 +693,7 @@ and close_let_bound_expression t ?let_rec_ident let_bound_var env in let decl = Function_decl.create ~let_rec_ident ~closure_bound_var ~kind ~mode ~region - ~params:(List.map fst params) ~body ~attr ~loc + ~params ~body ~attr ~loc in let set_of_closures_var = Variable.rename let_bound_var in let set_of_closures = @@ -731,27 +709,19 @@ and close_let_bound_expression t ?let_rec_ident let_bound_var env ~var:let_bound_var)) | lam -> Expr (close t env lam) -let lambda_to_flambda ~backend ~module_ident ~size ~filename lam +let lambda_to_flambda ~backend ~compilation_unit ~size ~filename lam : Flambda.program = let lam = add_default_argument_wrappers lam in - let compilation_unit = Compilation_unit.get_current_exn () in - let current_unit_id = - Compilation_unit.name compilation_unit - |> Compilation_unit.Name.to_string - |> Ident.create_persistent - in + let current_unit = Compilation_unit.get_current_exn () in let t = - { current_unit_id; + { current_unit; filename; backend; imported_symbols = Symbol.Set.empty; declared_symbols = []; } in - let module_symbol = - let pack_prefix = Compilation_unit.Prefix.from_clflags () in - Symbol.for_global_or_predef_ident pack_prefix module_ident - in + let module_symbol = Symbol.for_compilation_unit compilation_unit in let block_symbol = let var = Variable.create Internal_variable_names.module_as_block in Symbol_utils.Flambda.for_variable var diff --git a/middle_end/flambda/closure_conversion.mli b/middle_end/flambda/closure_conversion.mli index f5fab0a7ed1..32fc984a44b 100644 --- a/middle_end/flambda/closure_conversion.mli +++ b/middle_end/flambda/closure_conversion.mli @@ -46,7 +46,7 @@ *) val lambda_to_flambda : backend:(module Backend_intf.S) - -> module_ident:Ident.t + -> compilation_unit:Compilation_unit.t -> size:int -> filename:string -> Lambda.lambda diff --git a/middle_end/flambda/closure_conversion_aux.ml b/middle_end/flambda/closure_conversion_aux.ml index bbe6a4cfc23..41dc76abe00 100644 --- a/middle_end/flambda/closure_conversion_aux.ml +++ b/middle_end/flambda/closure_conversion_aux.ml @@ -19,8 +19,8 @@ open! Int_replace_polymorphic_compare module Env = struct type t = { - variables : Variable.t Ident.tbl; - mutable_variables : Mutable_variable.t Ident.tbl; + variables : (Variable.t * Lambda.value_kind) Ident.tbl; + mutable_variables : (Mutable_variable.t * Lambda.value_kind) Ident.tbl; static_exceptions : Static_exception.t Numbers.Int.Map.t; globals : Symbol.t Numbers.Int.Map.t; at_toplevel : bool; @@ -37,8 +37,10 @@ module Env = struct let clear_local_bindings env = { empty with globals = env.globals } - let add_var t id var = { t with variables = Ident.add id var t.variables } - let add_vars t ids vars = List.fold_left2 add_var t ids vars + let add_var t id var kind = + { t with variables = Ident.add id (var, kind) t.variables } + let add_vars t ids vars = + List.fold_left2 (fun t id (var, kind) -> add_var t id var kind) t ids vars let find_var t id = try Ident.find_same id t.variables @@ -50,8 +52,9 @@ module Env = struct let find_var_exn t id = Ident.find_same id t.variables - let add_mutable_var t id mutable_var = - { t with mutable_variables = Ident.add id mutable_var t.mutable_variables } + let add_mutable_var t id mutable_var kind = + let mutable_variables = Ident.add id (mutable_var, kind) t.mutable_variables in + { t with mutable_variables } let find_mutable_var_exn t id = Ident.find_same id t.mutable_variables @@ -89,7 +92,7 @@ module Function_decls = struct kind : Lambda.function_kind; mode : Lambda.alloc_mode; region : bool; - params : Ident.t list; + params : (Ident.t * Lambda.value_kind) list; body : Lambda.lambda; free_idents_of_body : Ident.Set.t; attr : Lambda.function_attribute; @@ -128,6 +131,7 @@ module Function_decls = struct let check t = t.attr.check let is_a_functor t = t.attr.is_a_functor let stub t = t.attr.stub + let poll_attribute t = t.attr.poll let loc t = t.loc end @@ -164,7 +168,7 @@ module Function_decls = struct difference *) let all_free_idents function_decls = set_diff (set_diff (all_free_idents function_decls) - (all_params function_decls)) + (List.map fst (all_params function_decls))) (let_rec_idents function_decls) let create (function_decls : Function_decl.t list) = @@ -181,11 +185,13 @@ module Function_decls = struct (* For "let rec"-bound functions. *) List.fold_right (fun function_decl env -> Env.add_var env (Function_decl.let_rec_ident function_decl) - (Function_decl.closure_bound_var function_decl)) + (Function_decl.closure_bound_var function_decl) Pgenval) t.function_decls (Env.clear_local_bindings external_env) in (* For free variables. *) Ident.Set.fold (fun id env -> - Env.add_var env id (Variable.create_with_same_name_as_ident id)) + let _, kind = Env.find_var external_env id in + Env.add_var env id (Variable.create_with_same_name_as_ident id) kind + ) t.all_free_idents closure_env end diff --git a/middle_end/flambda/closure_conversion_aux.mli b/middle_end/flambda/closure_conversion_aux.mli index 3471c743ced..595a34759e6 100644 --- a/middle_end/flambda/closure_conversion_aux.mli +++ b/middle_end/flambda/closure_conversion_aux.mli @@ -26,14 +26,16 @@ module Env : sig val empty : t - val add_var : t -> Ident.t -> Variable.t -> t - val add_vars : t -> Ident.t list -> Variable.t list -> t + val add_var : t -> Ident.t -> Variable.t -> Lambda.value_kind -> t + val add_vars : t -> Ident.t list -> (Variable.t * Lambda.value_kind) list -> t - val find_var : t -> Ident.t -> Variable.t - val find_var_exn : t -> Ident.t -> Variable.t + val find_var : t -> Ident.t -> Variable.t * Lambda.value_kind + val find_var_exn : t -> Ident.t -> Variable.t * Lambda.value_kind - val add_mutable_var : t -> Ident.t -> Mutable_variable.t -> t - val find_mutable_var_exn : t -> Ident.t -> Mutable_variable.t + val add_mutable_var : + t -> Ident.t -> Mutable_variable.t -> Lambda.value_kind -> t + val find_mutable_var_exn : + t -> Ident.t -> Mutable_variable.t * Lambda.value_kind val add_static_exception : t -> int -> Static_exception.t -> t val find_static_exception : t -> int -> Static_exception.t @@ -58,7 +60,7 @@ module Function_decls : sig -> kind:Lambda.function_kind -> mode:Lambda.alloc_mode -> region:bool - -> params:Ident.t list + -> params:(Ident.t * Lambda.value_kind) list -> body:Lambda.lambda -> attr:Lambda.function_attribute -> loc:Lambda.scoped_location @@ -69,7 +71,7 @@ module Function_decls : sig val kind : t -> Lambda.function_kind val mode : t -> Lambda.alloc_mode val region : t -> bool - val params : t -> Ident.t list + val params : t -> (Ident.t * Lambda.value_kind) list val body : t -> Lambda.lambda val inline : t -> Lambda.inline_attribute val specialise : t -> Lambda.specialise_attribute @@ -77,6 +79,7 @@ module Function_decls : sig val is_a_functor : t -> bool val stub : t -> bool val loc : t -> Lambda.scoped_location + val poll_attribute : t -> Lambda.poll_attribute (* Like [all_free_idents], but for just one function. *) val free_idents : t -> Ident.Set.t diff --git a/middle_end/flambda/closure_offsets.ml b/middle_end/flambda/closure_offsets.ml index 51a09f02cb3..ea5954e8af8 100644 --- a/middle_end/flambda/closure_offsets.ml +++ b/middle_end/flambda/closure_offsets.ml @@ -68,9 +68,18 @@ let add_closure_offsets let map = Var_within_closure.Map.add var_within_closure pos map in (map, pos + 1) in + let gc_invisible_free_vars, gc_visible_free_vars = + Variable.Map.partition (fun _ (free_var : Flambda.specialised_to) -> + Lambda.equal_value_kind free_var.kind Pintval) + free_vars + in + let free_variable_offsets, free_variable_pos = + Variable.Map.fold assign_free_variable_offset + gc_invisible_free_vars (free_variable_offsets, free_variable_pos) + in let free_variable_offsets, _ = Variable.Map.fold assign_free_variable_offset - free_vars (free_variable_offsets, free_variable_pos) + gc_visible_free_vars (free_variable_offsets, free_variable_pos) in { function_offsets; free_variable_offsets; diff --git a/middle_end/flambda/export_info_for_pack.ml b/middle_end/flambda/export_info_for_pack.ml index f2d5dfd6e75..89154a17072 100644 --- a/middle_end/flambda/export_info_for_pack.ml +++ b/middle_end/flambda/export_info_for_pack.ml @@ -143,23 +143,8 @@ let rec import_code_for_pack units pack expr = and import_function_declarations_for_pack_aux units pack (function_decls : Flambda.function_declarations) = - let funs = - Variable.Map.map - (fun (function_decl : Flambda.function_declaration) -> - Flambda.create_function_declaration - ~params:function_decl.params ~alloc_mode:function_decl.alloc_mode - ~region:function_decl.region - ~body:(import_code_for_pack units pack function_decl.body) - ~stub:function_decl.stub - ~inline:function_decl.inline - ~specialise:function_decl.specialise - ~check:function_decl.check - ~is_a_functor:function_decl.is_a_functor - ~closure_origin:function_decl.closure_origin) - function_decls.funs - in Flambda.import_function_declarations_for_pack - (Flambda.update_function_declarations function_decls ~funs) + function_decls (import_set_of_closures_id_for_pack units pack) (import_set_of_closures_origin_for_pack units pack) diff --git a/middle_end/flambda/export_info_for_pack.mli b/middle_end/flambda/export_info_for_pack.mli deleted file mode 100644 index c1dbfb7015f..00000000000 --- a/middle_end/flambda/export_info_for_pack.mli +++ /dev/null @@ -1,34 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart, OCamlPro *) -(* Mark Shinwell and Leo White, Jane Street Europe *) -(* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -[@@@ocaml.warning "+a-4-9-30-40-41-42"] - -(** Transformations on export information that are only used for the - building of packs. *) - -(** Transform the information from [exported] to be - suitable to be reexported as the information for a pack named [pack] - containing units [pack_units]. - It mainly changes symbols of units [pack_units] to refer to - [pack] instead. *) -val import_for_pack - : pack_units:Compilation_unit.Set.t - -> pack:Compilation_unit.Prefix.t - -> Export_info.t - -> Export_info.t - -(** Drops the state after importing several units in the same pack. *) -val clear_import_state : unit -> unit diff --git a/middle_end/flambda/flambda.ml b/middle_end/flambda/flambda.ml index 2aefbd72322..c4ef871d9ae 100644 --- a/middle_end/flambda/flambda.ml +++ b/middle_end/flambda/flambda.ml @@ -59,6 +59,7 @@ type project_var = Projection.project_var type specialised_to = { var : Variable.t; projection : Projection.t option; + kind : Lambda.value_kind; } type t = @@ -139,6 +140,7 @@ and function_declaration = { specialise : Lambda.specialise_attribute; check : Lambda.check_attribute; is_a_functor : bool; + poll: Lambda.poll_attribute; } and switch = { @@ -187,11 +189,15 @@ module Int = Numbers.Int let print_specialised_to ppf (spec_to : specialised_to) = match spec_to.projection with - | None -> fprintf ppf "%a" Variable.print spec_to.var + | None -> + fprintf ppf "%a[%a]" + Variable.print spec_to.var + Printlambda.value_kind spec_to.kind | Some projection -> - fprintf ppf "%a(= %a)" + fprintf ppf "%a(= %a)[%a]" Variable.print spec_to.var Projection.print projection + Printlambda.value_kind spec_to.kind (* CR-soon mshinwell: delete uses of old names *) let print_project_var = Projection.print_project_var @@ -1047,6 +1053,7 @@ let update_body_of_function_declaration (func_decl: function_declaration) check = func_decl.check; specialise = func_decl.specialise; is_a_functor = func_decl.is_a_functor; + poll = func_decl.poll; } let rec check_param_modes mode = function @@ -1062,7 +1069,7 @@ let create_function_declaration ~params ~alloc_mode ~region ~body ~stub ~(specialise : Lambda.specialise_attribute) ~(check : Lambda.check_attribute) ~is_a_functor - ~closure_origin + ~closure_origin ~poll : function_declaration = begin match stub, inline with | true, (Never_inline | Default_inline) @@ -1097,6 +1104,7 @@ let create_function_declaration ~params ~alloc_mode ~region ~body ~stub specialise; check; is_a_functor; + poll; } let update_function_declaration_body fun_decl ~body = @@ -1320,6 +1328,7 @@ let equal_specialised_to (spec_to1 : specialised_to) | Some _, None | None, Some _ -> false | Some proj1, Some proj2 -> Projection.equal proj1 proj2 end + && Lambda.equal_value_kind spec_to1.kind spec_to2.kind let compare_project_var = Projection.compare_project_var let compare_project_closure = Projection.compare_project_closure diff --git a/middle_end/flambda/flambda.mli b/middle_end/flambda/flambda.mli index fae516fee94..67fe32c0716 100644 --- a/middle_end/flambda/flambda.mli +++ b/middle_end/flambda/flambda.mli @@ -87,6 +87,7 @@ type specialised_to = { [specialised_args] respectively) in the same set of closures. As such, this field describes a relation of projections between either the [free_vars] or the [specialised_args]. *) + kind : Lambda.value_kind; } (** Flambda terms are partitioned in a pseudo-ANF manner; many terms are @@ -340,6 +341,8 @@ and function_declaration = private { (** Check function properties requirements from the source code *) is_a_functor : bool; (** Whether the function is known definitively to be a functor. *) + poll: Lambda.poll_attribute; + (** Behaviour for polls *) } (** Equivalent to the similar type in [Lambda]. *) @@ -572,6 +575,7 @@ val create_function_declaration -> check:Lambda.check_attribute -> is_a_functor:bool -> closure_origin:Closure_origin.t + -> poll:Lambda.poll_attribute -> function_declaration (** Create a function declaration based on another function declaration *) diff --git a/middle_end/flambda/flambda_middle_end.ml b/middle_end/flambda/flambda_middle_end.ml index ec235cf9635..feb12f60a97 100644 --- a/middle_end/flambda/flambda_middle_end.ml +++ b/middle_end/flambda/flambda_middle_end.ml @@ -31,7 +31,7 @@ let _dump_function_sizes flam = set_of_closures.function_decls.funs) let lambda_to_flambda ~ppf_dump ~prefixname ~backend ~size ~filename - ~module_ident ~module_initializer = + ~compilation_unit ~module_initializer = Profile.record_call "flambda" (fun () -> let previous_warning_reporter = !Location.warning_reporter in let module WarningSet = @@ -82,7 +82,7 @@ let lambda_to_flambda ~ppf_dump ~prefixname ~backend ~size ~filename (fun () -> module_initializer |> Closure_conversion.lambda_to_flambda ~backend - ~module_ident ~size ~filename) + ~compilation_unit ~size ~filename) in Compiler_hooks.execute Compiler_hooks.Raw_flambda1 flam; if !Clflags.dump_rawflambda @@ -220,7 +220,7 @@ let lambda_to_clambda ~backend ~filename ~prefixname ~ppf_dump lambda_to_flambda ~ppf_dump ~prefixname ~backend ~size:program.main_module_block_size ~filename - ~module_ident:program.module_ident + ~compilation_unit:program.compilation_unit ~module_initializer:program.code in let export = Build_export_info.build_transient program in diff --git a/middle_end/flambda/flambda_to_clambda.ml b/middle_end/flambda/flambda_to_clambda.ml index 021c3601922..1bf5a98ab26 100644 --- a/middle_end/flambda/flambda_to_clambda.ml +++ b/middle_end/flambda/flambda_to_clambda.ml @@ -14,10 +14,11 @@ (* *) (**************************************************************************) -[@@@ocaml.warning "+a-4-9-30-40-41-42"] +[@@@ocaml.warning "+a-4-9-30-40-41-42-69"] module V = Backend_var module VP = Backend_var.With_provenance +module Int = Misc.Stdlib.Int type 'a for_one_or_more_units = { fun_offset_table : int Closure_id.Map.t; @@ -144,7 +145,6 @@ end = struct { subst : Clambda.ulambda Variable.Map.t; var : V.t Variable.Map.t; mutable_var : V.t Mutable_variable.Map.t; - toplevel : bool; allocated_constant_for_symbol : Allocated_const.t Symbol.Map.t; } @@ -152,7 +152,6 @@ end = struct { subst = Variable.Map.empty; var = Variable.Map.empty; mutable_var = Mutable_variable.Map.empty; - toplevel = false; allocated_constant_for_symbol = Symbol.Map.empty; } @@ -454,7 +453,7 @@ and to_clambda_switch t env cases num_keys default = List.iter (fun (key, lam) -> index.(key) <- store.act_store () lam; - smallest_key := min key !smallest_key + smallest_key := Int.min key !smallest_key ) cases; if !smallest_key < num_keys then begin @@ -581,17 +580,28 @@ and to_clambda_set_of_closures t env body = to_clambda t env_body function_decl.body; dbg = function_decl.dbg; env = Some env_var; + poll = function_decl.poll; mode = set_of_closures.alloc_mode; check = function_decl.check; } in - let funs = List.map to_clambda_function all_functions in - let free_vars = - Variable.Map.bindings (Variable.Map.map ( - fun (free_var : Flambda.specialised_to) -> - subst_var env free_var.var) free_vars) + let functions = List.map to_clambda_function all_functions in + let not_scanned_fv, scanned_fv = + Variable.Map.partition (fun _ (free_var : Flambda.specialised_to) -> + Lambda.equal_value_kind free_var.kind Pintval) + free_vars in - Uclosure (funs, List.map snd free_vars) + let to_closure_args free_vars = + List.map snd ( + Variable.Map.bindings (Variable.Map.map ( + fun (free_var : Flambda.specialised_to) -> + subst_var env free_var.var) free_vars)) + in + Uclosure { + functions ; + not_scanned_slots = to_closure_args not_scanned_fv ; + scanned_slots = to_closure_args scanned_fv + } and to_clambda_closed_set_of_closures t env symbol ({ function_decls; } : Flambda.set_of_closures) @@ -636,6 +646,7 @@ and to_clambda_closed_set_of_closures t env symbol body; dbg = function_decl.dbg; env = None; + poll = function_decl.poll; mode = Lambda.alloc_heap; check = function_decl.check; } diff --git a/middle_end/flambda/flambda_utils.ml b/middle_end/flambda/flambda_utils.ml index 2f1ddc0d0e1..180ce15c4ae 100644 --- a/middle_end/flambda/flambda_utils.ml +++ b/middle_end/flambda/flambda_utils.ml @@ -343,16 +343,16 @@ let toplevel_substitution_named sb named = | _ -> assert false let make_closure_declaration - ~is_classic_mode ~id ~alloc_mode ~region ~body ~params ~stub : Flambda.t = - let free_variables = Flambda.free_variables body in + ~is_classic_mode ~id ~alloc_mode ~region ~body ~params ~free_variables : Flambda.t = let param_set = Parameter.Set.vars params in - if not (Variable.Set.subset param_set free_variables) then begin + let free_variables_set = Variable.Map.keys free_variables in + if not (Variable.Set.subset param_set free_variables_set) then begin Misc.fatal_error "Flambda_utils.make_closure_declaration" end; let sb = Variable.Set.fold (fun id sb -> Variable.Map.add id (Variable.rename id) sb) - free_variables Variable.Map.empty + free_variables_set Variable.Map.empty in (* CR-soon mshinwell: try to eliminate this [toplevel_substitution]. This function is only called from [Inline_and_simplify], so we should be able @@ -363,17 +363,20 @@ let make_closure_declaration let function_declaration = Flambda.create_function_declaration ~params:(List.map subst_param params) ~alloc_mode ~region - ~body ~stub ~inline:Default_inline + ~body ~stub:true ~inline:Default_inline ~specialise:Default_specialise ~check:Default_check ~is_a_functor:false ~closure_origin:(Closure_origin.create (Closure_id.wrap id)) + ~poll:Default_poll in - assert (Variable.Set.equal (Variable.Set.map subst free_variables) + assert (Variable.Set.equal (Variable.Set.map subst free_variables_set) function_declaration.free_variables); let free_vars = Variable.Map.fold (fun id id' fv' -> + let kind = Variable.Map.find id free_variables in let spec_to : Flambda.specialised_to = { var = id; projection = None; + kind; } in Variable.Map.add id' spec_to fv') diff --git a/middle_end/flambda/flambda_utils.mli b/middle_end/flambda/flambda_utils.mli index 49bfeeab1b7..735763c92a2 100644 --- a/middle_end/flambda/flambda_utils.mli +++ b/middle_end/flambda/flambda_utils.mli @@ -69,7 +69,7 @@ val make_closure_declaration -> region:bool -> body:Flambda.t -> params:Parameter.t list - -> stub:bool + -> free_variables:Lambda.value_kind Variable.Map.t -> Flambda.t val toplevel_substitution diff --git a/middle_end/flambda/freshening.ml b/middle_end/flambda/freshening.ml index 80ade3bde03..53560ffd935 100644 --- a/middle_end/flambda/freshening.ml +++ b/middle_end/flambda/freshening.ml @@ -328,6 +328,7 @@ module Project_var = struct ~check:func_decl.check ~is_a_functor:func_decl.is_a_functor ~closure_origin:func_decl.closure_origin + ~poll:func_decl.poll in function_decl, subst in diff --git a/middle_end/flambda/inline_and_simplify.ml b/middle_end/flambda/inline_and_simplify.ml index 34980cc9f44..f9e08e956b8 100644 --- a/middle_end/flambda/inline_and_simplify.ml +++ b/middle_end/flambda/inline_and_simplify.ml @@ -616,6 +616,7 @@ and simplify_set_of_closures original_env r ~check:function_decl.check ~is_a_functor:function_decl.is_a_functor ~closure_origin:function_decl.closure_origin + ~poll:function_decl.poll in let used_params' = Flambda.used_params function_decl in Variable.Map.add fun_var function_decl funs, @@ -858,13 +859,20 @@ and simplify_partial_application env r ~lhs_of_application Variable.rename ~debug_info:(Closure_id.debug_info closure_id_being_applied) (Closure_id.unwrap closure_id_being_applied) in + let free_variables = + Variable.Map.of_list + (List.map (fun p -> Parameter.var p, Parameter.kind p) freshened_params) + in + let free_variables = + Variable.Map.add lhs_of_application Lambda.Pgenval free_variables + in Flambda_utils.make_closure_declaration ~id:closure_variable ~is_classic_mode:false ~body ~alloc_mode:partial_mode ~region:function_decl.A.region ~params:remaining_args - ~stub:true + ~free_variables in let with_known_args = Flambda_utils.bind @@ -1499,6 +1507,7 @@ and duplicate_function ~env ~(set_of_closures : Flambda.set_of_closures) ~check:function_decl.check ~is_a_functor:function_decl.is_a_functor ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var)) + ~poll:function_decl.poll in function_decl, specialised_args diff --git a/middle_end/flambda/inline_and_simplify_aux.ml b/middle_end/flambda/inline_and_simplify_aux.ml index 7ed42be4f5b..618957141f7 100644 --- a/middle_end/flambda/inline_and_simplify_aux.ml +++ b/middle_end/flambda/inline_and_simplify_aux.ml @@ -16,6 +16,7 @@ [@@@ocaml.warning "+a-4-9-30-40-41-42-66"] open! Int_replace_polymorphic_compare +module Int = Misc.Stdlib.Int module Env = struct type scope = Current | Outer @@ -333,7 +334,7 @@ module Env = struct try Closure_origin.Map.find id t.inlining_counts with Not_found -> - max 1 (Clflags.Int_arg_helper.get + Int.max 1 (Clflags.Int_arg_helper.get ~key:t.round !Clflags.inline_max_unroll) in inlining_count > 0 @@ -343,7 +344,7 @@ module Env = struct try Closure_origin.Map.find id t.inlining_counts with Not_found -> - max 1 (Clflags.Int_arg_helper.get + Int.max 1 (Clflags.Int_arg_helper.get ~key:t.round !Clflags.inline_max_unroll) in let inlining_counts = @@ -575,8 +576,7 @@ let prepare_to_simplify_set_of_closures ~env let approx = E.find_exn env var in (* The projections are freshened below in one step, once we know the closure freshening substitution. *) - let projection = external_var.projection in - ({ var; projection; } : Flambda.specialised_to), approx) + ({ external_var with var } : Flambda.specialised_to), approx) set_of_closures.free_vars in let specialised_args = @@ -602,8 +602,7 @@ let prepare_to_simplify_set_of_closures ~env | None -> var | Some var -> var in - let projection = spec_to.projection in - Some ({ var; projection; } : Flambda.specialised_to)) + Some ({ spec_to with var } : Flambda.specialised_to)) in let environment_before_cleaning = env in (* [E.local] helps us to catch bugs whereby variables escape their scope. *) diff --git a/middle_end/flambda/inlining_cost.ml b/middle_end/flambda/inlining_cost.ml index b360220041a..acc7b2db777 100644 --- a/middle_end/flambda/inlining_cost.ml +++ b/middle_end/flambda/inlining_cost.ml @@ -16,6 +16,7 @@ [@@@ocaml.warning "+a-4-9-30-40-41-42-66"] open! Int_replace_polymorphic_compare +module Int = Misc.Stdlib.Int (* Simple approximation of the space cost of a primitive. *) @@ -93,8 +94,12 @@ let lambda_smaller' lam ~than:threshold = List.iter (fun (_, lam) -> lambda_named_size lam) bindings; lambda_size body | Switch (_, sw) -> - let aux = function _::_::_ -> size := !size + 5 | _ -> () in - aux sw.consts; aux sw.blocks; + let cost cases = + let size = List.length cases in + if size <= 1 then 0 + else 3 + size + in + size := !size + cost sw.consts + cost sw.blocks; List.iter (fun (_, lam) -> lambda_size lam) sw.consts; List.iter (fun (_, lam) -> lambda_size lam) sw.blocks; Option.iter lambda_size sw.failaction @@ -180,7 +185,7 @@ module Threshold = struct | Never_inline, _ -> Never_inline | _, Never_inline -> Never_inline | Can_inline_if_no_larger_than i1, Can_inline_if_no_larger_than i2 -> - Can_inline_if_no_larger_than (min i1 i2) + Can_inline_if_no_larger_than (Int.min i1 i2) let equal t1 t2 = match t1, t2 with @@ -682,7 +687,7 @@ let maximum_interesting_size_of_function_body_base = let inline_call_cost = cost !Clflags.inline_call_cost ~round in direct_call_size + (inline_call_cost * benefit_factor) in - max_cost := max !max_cost max_size + max_cost := Int.max !max_cost max_size done; !max_cost end @@ -695,7 +700,7 @@ let maximum_interesting_size_of_function_body_multiplier = let inline_prim_cost = cost !Clflags.inline_prim_cost ~round in inline_prim_cost * benefit_factor in - max_cost := max !max_cost max_size + max_cost := Int.max !max_cost max_size done; !max_cost end diff --git a/middle_end/flambda/inlining_transforms.ml b/middle_end/flambda/inlining_transforms.ml index 7fc0e82d6e8..1387c3d7f15 100644 --- a/middle_end/flambda/inlining_transforms.ml +++ b/middle_end/flambda/inlining_transforms.ml @@ -295,6 +295,7 @@ let register_arguments ~specialised_args ~invariant_params [old_params_to_new_outside] then also add it to the new specialised args. *) let add_param ~specialised_args ~state ~param = let alloc_mode = Parameter.alloc_mode param in + let kind = Parameter.kind param in let param = Parameter.var param in let new_param = Variable.rename param in let old_inside_to_new_inside = @@ -316,7 +317,7 @@ let add_param ~specialised_args ~state ~param = | None -> state.new_specialised_args_with_old_projections | Some new_outside_var -> let new_spec : Flambda.specialised_to = - { var = new_outside_var; projection = None } + { var = new_outside_var; projection = None; kind } in Variable.Map.add new_param new_spec state.new_specialised_args_with_old_projections @@ -326,7 +327,7 @@ let add_param ~specialised_args ~state ~param = { state with old_inside_to_new_inside; new_specialised_args_with_old_projections } in - state, Parameter.wrap new_param alloc_mode + state, Parameter.wrap new_param alloc_mode kind (* Add a let binding for an old fun_var, add it to the new free variables, and add it to [old_inside_to_new_inside] *) @@ -343,7 +344,7 @@ let add_fun_var ~lhs_of_application ~closure_id_being_applied ~state ~fun_var = in let let_bindings = (outside_var, expr) :: state.let_bindings in let spec : Flambda.specialised_to = - { var = outside_var; projection = None; } + { var = outside_var; projection = None; kind = Pgenval } in let new_free_vars_with_old_projections = Variable.Map.add inside_var spec state.new_free_vars_with_old_projections @@ -546,6 +547,7 @@ let rewrite_function ~lhs_of_application ~closure_id_being_applied ~check:function_body.check ~is_a_functor:function_body.is_a_functor ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var)) + ~poll:function_body.poll in let new_funs = Variable.Map.add new_fun_var new_function_decl state.new_funs diff --git a/middle_end/flambda/invariant_params.ml b/middle_end/flambda/invariant_params.ml index 979ec1418cc..890f65b6c3b 100644 --- a/middle_end/flambda/invariant_params.ml +++ b/middle_end/flambda/invariant_params.ml @@ -299,7 +299,7 @@ let analyse_functions ~param_to_param Notice that having (f, x) <- (g, a) and (f, x) <- (g, b) does not make x not unchanging. This is because (g, a) and (g, b) represent necessarily - different values only if g is the externaly called function. If some + different values only if g is the externally called function. If some value where created during the execution of the function that could flow to (g, a), then (g, a) <- Top, so (f, x) <- Top. diff --git a/middle_end/flambda/parameter.ml b/middle_end/flambda/parameter.ml index 93607e4e384..7ff5625ccdc 100644 --- a/middle_end/flambda/parameter.ml +++ b/middle_end/flambda/parameter.ml @@ -24,33 +24,40 @@ open! Int_replace_polymorphic_compare type parameter = { var : Variable.t; mode : Lambda.alloc_mode; + kind : Lambda.value_kind; } -let wrap var mode = { var; mode } +let wrap var mode kind = { var; mode; kind } let var p = p.var let alloc_mode p = p.mode +let kind p = p.kind module M = Identifiable.Make (struct type t = parameter - let compare { var = var1; mode = _ } { var = var2; mode = _ } = + let compare + { var = var1; mode = _ ; kind = _ } + { var = var2; mode = _ ; kind = _ } = Variable.compare var1 var2 - let equal { var = var1; mode = _ } { var = var2; mode = _ } = + let equal + { var = var1; mode = _ ; kind = _ } + { var = var2; mode = _ ; kind = _ } = Variable.equal var1 var2 - let hash { var; mode = _ } = + let hash { var; mode = _ ; kind = _ } = Variable.hash var - let print ppf { var; mode } = + let print ppf { var; mode ; kind } = let mode = match mode with | Lambda.Alloc_heap -> "" | Lambda.Alloc_local -> "[->L]" in - Format.fprintf ppf "%a%s" Variable.print var mode + Format.fprintf ppf "%a%s[%a]" + Variable.print var mode Printlambda.value_kind kind - let output o { var; mode = _ } = + let output o { var; mode = _ ; kind = _ } = Variable.output o var end) @@ -65,10 +72,10 @@ module Set = struct end let rename ?current_compilation_unit p = - { var = Variable.rename ?current_compilation_unit p.var; mode = p.mode } + { p with var = Variable.rename ?current_compilation_unit p.var } -let map_var f { var; mode } = { var = f var; mode } +let map_var f { var ; mode ; kind } = { var = f var; mode; kind } module List = struct - let vars params = List.map (fun { var; mode=_ } -> var) params + let vars params = List.map (fun { var ; mode = _ ; kind = _ } -> var) params end diff --git a/middle_end/flambda/parameter.mli b/middle_end/flambda/parameter.mli index 4687d4d0fd9..3c99abe20cc 100644 --- a/middle_end/flambda/parameter.mli +++ b/middle_end/flambda/parameter.mli @@ -23,7 +23,7 @@ type t type parameter = t (** Make a parameter from a variable with default attributes *) -val wrap : Variable.t -> Lambda.alloc_mode -> t +val wrap : Variable.t -> Lambda.alloc_mode -> Lambda.value_kind -> t val var : t -> Variable.t @@ -31,6 +31,8 @@ val var : t -> Variable.t up to and including this parameter *) val alloc_mode : t -> Lambda.alloc_mode +val kind : t -> Lambda.value_kind + (** Rename the inner variable of the parameter *) val rename : ?current_compilation_unit:Compilation_unit.t diff --git a/middle_end/flambda/remove_unused_arguments.ml b/middle_end/flambda/remove_unused_arguments.ml index 145ea689a46..52efe97f566 100644 --- a/middle_end/flambda/remove_unused_arguments.ml +++ b/middle_end/flambda/remove_unused_arguments.ml @@ -46,6 +46,7 @@ let remove_params unused (fun_decl: Flambda.function_declaration) ~specialise:fun_decl.specialise ~check:fun_decl.check ~is_a_functor:fun_decl.is_a_functor ~closure_origin:(Closure_origin.create (Closure_id.wrap new_fun_var)) + ~poll:fun_decl.poll let make_stub unused var (fun_decl : Flambda.function_declaration) ~specialised_args ~additional_specialised_args = @@ -112,6 +113,7 @@ let make_stub unused var (fun_decl : Flambda.function_declaration) ~check:Default_check ~is_a_functor:fun_decl.is_a_functor ~closure_origin:fun_decl.closure_origin + ~poll:Default_poll (* don't propagate attribute to wrappers *) in function_decl, renamed, additional_specialised_args diff --git a/middle_end/flambda/simple_value_approx.ml b/middle_end/flambda/simple_value_approx.ml index 28c535a94dc..7c82d027f03 100644 --- a/middle_end/flambda/simple_value_approx.ml +++ b/middle_end/flambda/simple_value_approx.ml @@ -83,6 +83,7 @@ and function_body = { check : Lambda.check_attribute; is_a_functor : bool; body : Flambda.t; + poll: Lambda.poll_attribute; } and function_declaration = { @@ -948,7 +949,8 @@ let function_declaration_approx ~keep_body fun_var check = fun_decl.check; is_a_functor = fun_decl.is_a_functor; free_variables = fun_decl.free_variables; - free_symbols = fun_decl.free_symbols; } + free_symbols = fun_decl.free_symbols; + poll = fun_decl.poll } end in { function_body; diff --git a/middle_end/flambda/simple_value_approx.mli b/middle_end/flambda/simple_value_approx.mli index 34476fc65eb..46551f7e5a8 100644 --- a/middle_end/flambda/simple_value_approx.mli +++ b/middle_end/flambda/simple_value_approx.mli @@ -159,6 +159,7 @@ and function_body = private { check : Lambda.check_attribute; is_a_functor : bool; body : Flambda.t; + poll: Lambda.poll_attribute; } and function_declaration = private { diff --git a/middle_end/flambda/un_anf.ml b/middle_end/flambda/un_anf.ml index 8f484f10b31..87e04cddc7b 100644 --- a/middle_end/flambda/un_anf.ml +++ b/middle_end/flambda/un_anf.ml @@ -14,7 +14,7 @@ (* *) (**************************************************************************) -[@@@ocaml.warning "+a-4-30-40-41-42"] +[@@@ocaml.warning "+a-4-30-40-41-42-69"] (* CR-someday vlaviron for mshinwell: I believe that the phantom lets introduced in un_anf (when the new debug_full flag is enabled) bind mostly variables @@ -144,11 +144,12 @@ let make_var_info (clam : Clambda.ulambda) : var_info = List.iter (loop ~depth) args; ignore_apply_kind info; ignore_debuginfo dbg - | Uclosure (functions, captured_variables) -> - List.iter (loop ~depth) captured_variables; + | Uclosure { functions; not_scanned_slots ; scanned_slots } -> + List.iter (loop ~depth) not_scanned_slots; + List.iter (loop ~depth) scanned_slots; List.iter (fun ( { Clambda. label; arity=_; params; return; body; dbg; env; mode=_; - check=_} as clos) -> + check=_; poll=_ } as clos) -> (match closure_environment_var clos with | None -> () | Some env_var -> @@ -321,11 +322,12 @@ let let_bound_vars_that_can_be_moved var_info (clam : Clambda.ulambda) = examine_argument_list (args @ [func]); ignore_apply_kind info; ignore_debuginfo dbg - | Uclosure (functions, captured_variables) -> - ignore_ulambda_list captured_variables; + | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> + ignore_ulambda_list not_scanned_slots; + ignore_ulambda_list scanned_slots; (* Start a new let stack for speed. *) List.iter (fun {Clambda. label; arity=_; params; return; body; dbg; env; mode=_; - check=_} -> + check=_; poll=_} -> ignore_function_label label; ignore_params_with_value_kind params; ignore_value_kind return; @@ -501,7 +503,7 @@ let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda) let func = substitute_let_moveable is_let_moveable env func in let args = substitute_let_moveable_list is_let_moveable env args in Ugeneric_apply (func, args, kind, dbg) - | Uclosure (functions, variables_bound_by_the_closure) -> + | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> let functions = List.map (fun (ufunction : Clambda.ufunction) -> { ufunction with @@ -509,11 +511,15 @@ let rec substitute_let_moveable is_let_moveable env (clam : Clambda.ulambda) }) functions in - let variables_bound_by_the_closure = + let not_scanned_slots = substitute_let_moveable_list is_let_moveable env - variables_bound_by_the_closure + not_scanned_slots in - Uclosure (functions, variables_bound_by_the_closure) + let scanned_slots = + substitute_let_moveable_list is_let_moveable env + scanned_slots + in + Uclosure { functions ; not_scanned_slots; scanned_slots } | Uoffset (clam, n) -> let clam = substitute_let_moveable is_let_moveable env clam in Uoffset (clam, n) @@ -701,7 +707,7 @@ let rec un_anf_and_moveable var_info env (clam : Clambda.ulambda) let func = un_anf var_info env func in let args = un_anf_list var_info env args in Ugeneric_apply (func, args, kind, dbg), Fixed - | Uclosure (functions, variables_bound_by_the_closure) -> + | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> let functions = List.map (fun (ufunction : Clambda.ufunction) -> { ufunction with @@ -709,10 +715,9 @@ let rec un_anf_and_moveable var_info env (clam : Clambda.ulambda) }) functions in - let variables_bound_by_the_closure = - un_anf_list var_info env variables_bound_by_the_closure - in - Uclosure (functions, variables_bound_by_the_closure), Fixed + let not_scanned_slots = un_anf_list var_info env not_scanned_slots in + let scanned_slots = un_anf_list var_info env scanned_slots in + Uclosure { functions ; not_scanned_slots ; scanned_slots }, Fixed | Uoffset (clam, n) -> let clam, moveable = un_anf_and_moveable var_info env clam in Uoffset (clam, n), both_moveable Moveable moveable diff --git a/middle_end/flambda/unbox_closures.ml b/middle_end/flambda/unbox_closures.ml index 5c86bed3da7..2045ca90c38 100644 --- a/middle_end/flambda/unbox_closures.ml +++ b/middle_end/flambda/unbox_closures.ml @@ -76,9 +76,10 @@ module Transform = struct set_of_closures.function_decls in Variable.Set.fold (fun inner_free_var what_to_specialise -> + let kind = (Variable.Map.find inner_free_var set_of_closures.free_vars).kind in W.new_specialised_arg what_to_specialise ~fun_var ~group:inner_free_var - ~definition:(Existing_inner_free_var inner_free_var)) + ~definition:(Existing_inner_free_var (inner_free_var, kind))) bound_by_the_closure what_to_specialise) end diff --git a/middle_end/flambda/unbox_free_vars_of_closures.ml b/middle_end/flambda/unbox_free_vars_of_closures.ml index 7a4e48ed44e..a9a20422bd5 100644 --- a/middle_end/flambda/unbox_free_vars_of_closures.ml +++ b/middle_end/flambda/unbox_free_vars_of_closures.ml @@ -104,6 +104,7 @@ let run ~env ~(set_of_closures : Flambda.set_of_closures) = "new inner" and a fresh "new outer" var, since we know the definition is not a duplicate. *) let projecting_from = Projection.projecting_from projection in + let kind = (Variable.Map.find projecting_from set_of_closures.free_vars).kind in let new_inner_var = Variable.rename projecting_from in let new_outer_var = Variable.rename projecting_from in let definitions_indexed_by_new_inner_vars = @@ -117,6 +118,7 @@ let run ~env ~(set_of_closures : Flambda.set_of_closures) = let new_outer_var : Flambda.specialised_to = { var = new_outer_var; projection = Some projection; + kind; } in let additional_free_vars = diff --git a/middle_end/flambda/unbox_specialised_args.ml b/middle_end/flambda/unbox_specialised_args.ml index 428e7f9608b..ac928428a08 100644 --- a/middle_end/flambda/unbox_specialised_args.ml +++ b/middle_end/flambda/unbox_specialised_args.ml @@ -51,10 +51,11 @@ module Transform = struct what_to_specialise -> let group = Projection.projecting_from projection in assert (Variable.Map.mem group set_of_closures.specialised_args); + let kind = (Variable.Map.find group set_of_closures.specialised_args).kind in let what_to_specialise = W.new_specialised_arg what_to_specialise ~fun_var ~group ~definition:(Projection_from_existing_specialised_arg - projection) + (projection, kind)) in match Variable.Map.find group invariant_params_flow with | exception Not_found -> what_to_specialise @@ -80,6 +81,7 @@ module Transform = struct corresponding inner specialised arg of [target_fun_var]. (The outer vars referenced in the projection remain unchanged.) *) + let kind = (Variable.Map.find target_spec_arg set_of_closures.specialised_args).kind in let projection = Projection.map_projecting_from projection ~f:(fun var -> @@ -89,7 +91,7 @@ module Transform = struct W.new_specialised_arg what_to_specialise ~fun_var:target_fun_var ~group ~definition: - (Projection_from_existing_specialised_arg projection) + (Projection_from_existing_specialised_arg (projection, kind)) end) flow what_to_specialise) diff --git a/middle_end/flambda2/.ocamlformat b/middle_end/flambda2/.ocamlformat index 202fa911346..448b8f3be1a 100644 --- a/middle_end/flambda2/.ocamlformat +++ b/middle_end/flambda2/.ocamlformat @@ -5,10 +5,11 @@ cases-exp-indent=2 doc-comments=before dock-collection-brackets=false if-then-else=keyword-first +module-item-spacing=sparse parens-tuple=multi-line-only sequence-blank-line=compact space-around-lists=false space-around-variants=false type-decl=sparse wrap-comments=true -version=0.19.0 +version=0.24.1 diff --git a/middle_end/flambda2/cmx/dune b/middle_end/flambda2/cmx/dune index 92d4ce244de..8c243fbdeae 100644 --- a/middle_end/flambda2/cmx/dune +++ b/middle_end/flambda2/cmx/dune @@ -35,6 +35,7 @@ (:standard -O3)) (libraries ocamlcommon + flambda_backend_utils flambda2_algorithms flambda2_bound_identifiers flambda2_identifiers diff --git a/middle_end/flambda2/cmx/exported_code.ml b/middle_end/flambda2/cmx/exported_code.ml index c6880a4f024..a7ef320c49d 100644 --- a/middle_end/flambda2/cmx/exported_code.ml +++ b/middle_end/flambda2/cmx/exported_code.ml @@ -15,6 +15,8 @@ module C = Code +type raw = Code_or_metadata.raw Code_id.Map.t + type t = Code_or_metadata.t Code_id.Map.t let print ppf t = Code_id.Map.print Code_or_metadata.print ppf t @@ -118,3 +120,12 @@ let iter_code t ~f = (fun _code_id code_or_metadata -> Code_or_metadata.iter_code code_or_metadata ~f) t + +let from_raw ~sections t = + Code_id.Map.map (Code_or_metadata.from_raw ~sections) t + +let to_raw ~add_section t = + Code_id.Map.map (Code_or_metadata.to_raw ~add_section) t + +let map_raw_index map_index t = + Code_id.Map.map (Code_or_metadata.map_raw_index map_index) t diff --git a/middle_end/flambda2/cmx/exported_code.mli b/middle_end/flambda2/cmx/exported_code.mli index 2e03ddea09d..93c9a78a654 100644 --- a/middle_end/flambda2/cmx/exported_code.mli +++ b/middle_end/flambda2/cmx/exported_code.mli @@ -15,6 +15,8 @@ type t +type raw + include Contains_ids.S with type t := t val apply_renaming : Code_id.t Code_id.Map.t -> Renaming.t -> t -> t @@ -49,3 +51,9 @@ val remove_unused_value_slots_from_result_types_and_shortcut_aliases : t val iter_code : t -> f:(Code.t -> unit) -> unit + +val from_raw : sections:Flambda_backend_utils.File_sections.t -> raw -> t + +val to_raw : add_section:(Obj.t -> int) -> t -> raw + +val map_raw_index : (int -> int) -> raw -> raw diff --git a/middle_end/flambda2/cmx/flambda_cmx.ml b/middle_end/flambda2/cmx/flambda_cmx.ml index 5852cc5bd63..05f23a0c2d3 100644 --- a/middle_end/flambda2/cmx/flambda_cmx.ml +++ b/middle_end/flambda2/cmx/flambda_cmx.ml @@ -19,22 +19,28 @@ module T = Flambda2_types module TE = Flambda2_types.Typing_env type loader = - { get_global_info : Compilation_unit.t -> Flambda_cmx_format.t option; + { get_module_info : Compilation_unit.t -> Flambda_cmx_format.t option; mutable imported_names : Name.Set.t; mutable imported_code : Exported_code.t; - mutable imported_units : TE.Serializable.t option Compilation_unit.Map.t + mutable imported_units : + TE.Serializable.t option Compilation_unit.Name.Map.t } let load_cmx_file_contents loader comp_unit = - match Compilation_unit.Map.find comp_unit loader.imported_units with + let accessible_comp_unit = + Compilation_unit.which_cmx_file comp_unit + ~accessed_by:(Compilation_unit.get_current_exn ()) + in + let cmx_file = Compilation_unit.name accessible_comp_unit in + match Compilation_unit.Name.Map.find cmx_file loader.imported_units with | typing_env_or_none -> typing_env_or_none | exception Not_found -> ( - match loader.get_global_info comp_unit with + match loader.get_module_info accessible_comp_unit with | None -> (* To make things easier to think about, we never retry after a .cmx load fails. *) loader.imported_units - <- Compilation_unit.Map.add comp_unit None loader.imported_units; + <- Compilation_unit.Name.Map.add cmx_file None loader.imported_units; None | Some cmx -> let typing_env, all_code = @@ -47,7 +53,7 @@ let load_cmx_file_contents loader comp_unit = let offsets = Flambda_cmx_format.exported_offsets cmx in Exported_offsets.import_offsets offsets; loader.imported_units - <- Compilation_unit.Map.add comp_unit (Some typing_env) + <- Compilation_unit.Name.Map.add cmx_file (Some typing_env) loader.imported_units; Some typing_env) @@ -67,32 +73,32 @@ let load_symbol_approx loader symbol : Code_or_metadata.t Value_approximation.t in T.Typing_env.Serializable.extract_symbol_approx typing_env symbol find_code -let all_predefined_exception_symbols ~symbol_for_global = +let all_predefined_exception_symbols () = + let symbol_for_global id = + Flambda2_import.Symbol.for_predef_ident id |> Symbol.create_wrapped + in Predef.all_predef_exns |> List.map symbol_for_global |> Symbol.Set.of_list -let predefined_exception_typing_env ~symbol_for_global = - let comp_unit = Compilation_unit.get_current_exn () in - Compilation_unit.set_current Compilation_unit.predef_exn; +let predefined_exception_typing_env () = + let comp_unit = Compilation_unit.get_current () in + Compilation_unit.set_current (Some Compilation_unit.predef_exn); let typing_env = - TE.Serializable.predefined_exceptions - (all_predefined_exception_symbols ~symbol_for_global) + TE.Serializable.predefined_exceptions (all_predefined_exception_symbols ()) in Compilation_unit.set_current comp_unit; typing_env -let create_loader ~get_global_info ~symbol_for_global = +let create_loader ~get_module_info = let loader = - { get_global_info; + { get_module_info; imported_names = Name.Set.empty; imported_code = Exported_code.empty; - imported_units = Compilation_unit.Map.empty + imported_units = Compilation_unit.Name.Map.empty } in - let predefined_exception_typing_env = - predefined_exception_typing_env ~symbol_for_global - in + let predefined_exception_typing_env = predefined_exception_typing_env () in loader.imported_units - <- Compilation_unit.Map.singleton Compilation_unit.predef_exn + <- Compilation_unit.Name.Map.singleton Compilation_unit.Name.predef_exn (Some predefined_exception_typing_env); loader.imported_names <- TE.Serializable.name_domain predefined_exception_typing_env; diff --git a/middle_end/flambda2/cmx/flambda_cmx.mli b/middle_end/flambda2/cmx/flambda_cmx.mli index 9f8cc12ac50..383c166121e 100644 --- a/middle_end/flambda2/cmx/flambda_cmx.mli +++ b/middle_end/flambda2/cmx/flambda_cmx.mli @@ -20,9 +20,7 @@ type loader val create_loader : - get_global_info:(Compilation_unit.t -> Flambda_cmx_format.t option) -> - symbol_for_global:(Ident.t -> Symbol.t) -> - loader + get_module_info:(Compilation_unit.t -> Flambda_cmx_format.t option) -> loader val get_imported_names : loader -> unit -> Name.Set.t diff --git a/middle_end/flambda2/cmx/flambda_cmx_format.ml b/middle_end/flambda2/cmx/flambda_cmx_format.ml index acb539ba0cb..e102dc21372 100644 --- a/middle_end/flambda2/cmx/flambda_cmx_format.ml +++ b/middle_end/flambda2/cmx/flambda_cmx_format.ml @@ -16,6 +16,8 @@ (** Contents of middle-end-specific portion of .cmx files when using Flambda. *) +module File_sections = Flambda_backend_utils.File_sections + type table_data = { symbols : (Symbol.t * Symbol.exported) list; variables : (Variable.t * Variable.exported) list; @@ -28,13 +30,30 @@ type table_data = type t0 = { original_compilation_unit : Compilation_unit.t; final_typing_env : Flambda2_types.Typing_env.Serializable.t; - all_code : Exported_code.t; + all_code : Exported_code.raw; exported_offsets : Exported_offsets.t; used_value_slots : Value_slot.Set.t; table_data : table_data } -type t = t0 list +type raw = t0 list + +type t = raw * File_sections.t + +let to_raw (t, sections) = t, sections + +let from_raw ~sections t = t, sections + +type current_sections = + { mutable sections_rev : Obj.t list; + mutable num_sections : int + } + +let add_section cs section = + let n = cs.num_sections in + cs.sections_rev <- section :: cs.sections_rev; + cs.num_sections <- n + 1; + n let create ~final_typing_env ~all_code ~exported_offsets ~used_value_slots = let typing_env_exported_ids = @@ -79,13 +98,18 @@ let create ~final_typing_env ~all_code ~exported_offsets ~used_value_slots = let table_data = { symbols; variables; simples; consts; code_ids; continuations } in - [ { original_compilation_unit = Compilation_unit.get_current_exn (); - final_typing_env; - all_code; - exported_offsets; - used_value_slots; - table_data - } ] + let sections = { sections_rev = []; num_sections = 0 } in + let all_code = + Exported_code.to_raw ~add_section:(add_section sections) all_code + in + ( [ { original_compilation_unit = Compilation_unit.get_current_exn (); + final_typing_env; + all_code; + exported_offsets; + used_value_slots; + table_data + } ], + File_sections.from_array (Array.of_list (List.rev sections.sections_rev)) ) module Make_importer (S : sig type t @@ -94,18 +118,9 @@ module Make_importer (S : sig val import : exported -> t - val map_compilation_unit : - (Compilation_unit.t -> Compilation_unit.t) -> exported -> exported - include Container_types.S with type t := t end) : sig val import : (S.t * S.exported) list -> S.t S.Map.t - - val update_for_pack : - pack_units:Compilation_unit.Set.t -> - pack:Compilation_unit.t -> - (S.t * S.exported) list -> - (S.t * S.exported) list end = struct let import from_table_data = (* The returned map gives the hash collisions. *) @@ -114,16 +129,6 @@ end = struct let new_key = S.import exported in if key == new_key then import_map else S.Map.add key new_key import_map) S.Map.empty from_table_data - - let update_for_pack ~pack_units ~pack from_table_data = - let update_cu unit = - if Compilation_unit.Set.mem unit pack_units then pack else unit - in - List.map - (fun (symbol, exported) -> - let exported = S.map_compilation_unit update_cu exported in - symbol, exported) - from_table_data end [@@inline always] @@ -134,7 +139,7 @@ module Const_importer = Make_importer (Reg_width_const) module Code_id_importer = Make_importer (Code_id) module Continuation_importer = Make_importer (Continuation) -let import_typing_env_and_code0 t = +let import_typing_env_and_code0 ~sections t = let symbols = Symbol_importer.import t.table_data.symbols in let variables = Variable_importer.import t.table_data.variables in let simples = Simple_importer.import t.table_data.simples in @@ -151,71 +156,37 @@ let import_typing_env_and_code0 t = Flambda2_types.Typing_env.Serializable.apply_renaming t.final_typing_env renaming in - let all_code = Exported_code.apply_renaming code_ids renaming t.all_code in + let all_code = Exported_code.from_raw ~sections t.all_code in + let all_code = Exported_code.apply_renaming code_ids renaming all_code in typing_env, all_code -let import_typing_env_and_code t = +let import_typing_env_and_code (t, sections) = match t with | [] -> Misc.fatal_error "Flambda cmx info should never be empty" - | [t0] -> import_typing_env_and_code0 t0 + | [t0] -> import_typing_env_and_code0 ~sections t0 | t0 :: rem -> List.fold_left (fun (typing_env, code) t0 -> - let typing_env0, code0 = import_typing_env_and_code0 t0 in + let typing_env0, code0 = import_typing_env_and_code0 ~sections t0 in let typing_env = Flambda2_types.Typing_env.Serializable.merge typing_env typing_env0 in let code = Exported_code.merge code code0 in typing_env, code) - (import_typing_env_and_code0 t0) + (import_typing_env_and_code0 ~sections t0) rem -let exported_offsets t = +let exported_offsets (t, _) = List.fold_left (fun offsets t0 -> Exported_offsets.merge offsets t0.exported_offsets) Exported_offsets.empty t -let functions_info t = - List.fold_left - (fun code t0 -> Exported_code.merge code t0.all_code) - Exported_code.empty t - -let with_exported_offsets t exported_offsets = +let with_exported_offsets (t, sections) exported_offsets = match t with - | [t0] -> [{ t0 with exported_offsets }] + | [t0] -> [{ t0 with exported_offsets }], sections | [] | _ :: _ :: _ -> Misc.fatal_error "Cannot set exported offsets on multiple units" -let update_for_pack0 ~pack_units ~pack t = - let symbols = - Symbol_importer.update_for_pack ~pack_units ~pack t.table_data.symbols - in - let variables = - Variable_importer.update_for_pack ~pack_units ~pack t.table_data.variables - in - let simples = - Simple_importer.update_for_pack ~pack_units ~pack t.table_data.simples - in - let consts = - Const_importer.update_for_pack ~pack_units ~pack t.table_data.consts - in - let code_ids = - Code_id_importer.update_for_pack ~pack_units ~pack t.table_data.code_ids - in - let continuations = - Continuation_importer.update_for_pack ~pack_units ~pack - t.table_data.continuations - in - let table_data = - { symbols; variables; simples; consts; code_ids; continuations } - in - { t with table_data } - -let update_for_pack ~pack_units ~pack t_opt = - match t_opt with - | None -> None - | Some t -> Some (List.map (update_for_pack0 ~pack_units ~pack) t) - let merge t1_opt t2_opt = match t1_opt, t2_opt with | None, None -> None @@ -224,30 +195,42 @@ let merge t1_opt t2_opt = Misc.fatal_error "Some pack units do not have their export info set.\n\ Flambda doesn't support packing opaque and normal units together." - | Some t1, Some t2 -> Some (t1 @ t2) + | Some (t1, sections1), Some (t2, sections2) -> + (* Put the sections of t2 before the sections of t1, so that + right-associative merge is linear *) + let nsections = File_sections.concat sections2 sections1 in + let n = File_sections.length sections2 in + let t1 = + List.map + (fun t0 -> + { t0 with + all_code = Exported_code.map_raw_index (fun x -> x + n) t0.all_code + }) + t1 + in + Some (t1 @ t2, nsections) -let print0 ppf t = +let print0 ~sections ppf t = Format.fprintf ppf "@[Original unit:@ %a@]@;" Compilation_unit.print t.original_compilation_unit; - Compilation_unit.set_current t.original_compilation_unit; - let typing_env, code = import_typing_env_and_code0 t in + Compilation_unit.set_current (Some t.original_compilation_unit); + let typing_env, code = import_typing_env_and_code0 ~sections t in Format.fprintf ppf "@[Typing env:@ %a@]@;" Flambda2_types.Typing_env.Serializable.print typing_env; Format.fprintf ppf "@[Code:@ %a@]@;" Exported_code.print code; Format.fprintf ppf "@[Offsets:@ %a@]@;" Exported_offsets.print t.exported_offsets -let [@ocamlformat "disable"] print ppf t = +let print ppf (t, sections) = let rec print_rest ppf = function | [] -> () | t0 :: t -> - Format.fprintf ppf "@ (%a)" - print0 t0; + Format.fprintf ppf "@ (%a)" (print0 ~sections) t0; print_rest ppf t in match t with | [] -> assert false - | [ t0 ] -> print0 ppf t0 + | [t0] -> print0 ~sections ppf t0 | t0 :: t -> - Format.fprintf ppf "Packed units:@ @[(%a)%a@]" - print0 t0 print_rest t + Format.fprintf ppf "Packed units:@ @[(%a)%a@]" (print0 ~sections) t0 + print_rest t diff --git a/middle_end/flambda2/cmx/flambda_cmx_format.mli b/middle_end/flambda2/cmx/flambda_cmx_format.mli index 0c3c8694a8d..2b2253d11d2 100644 --- a/middle_end/flambda2/cmx/flambda_cmx_format.mli +++ b/middle_end/flambda2/cmx/flambda_cmx_format.mli @@ -18,6 +18,12 @@ type t +type raw + +val to_raw : t -> raw * Flambda_backend_utils.File_sections.t + +val from_raw : sections:Flambda_backend_utils.File_sections.t -> raw -> t + val create : final_typing_env:Flambda2_types.Typing_env.Serializable.t -> all_code:Exported_code.t -> @@ -30,18 +36,8 @@ val import_typing_env_and_code : val exported_offsets : t -> Exported_offsets.t -val functions_info : t -> Exported_code.t - val with_exported_offsets : t -> Exported_offsets.t -> t -(** Rename the compilation units for packed modules to the pack unit, so that - file lookups search for the right cmx *) -val update_for_pack : - pack_units:Compilation_unit.Set.t -> - pack:Compilation_unit.t -> - t option -> - t option - (** Aggregate several cmx into one for packs *) val merge : t option -> t option -> t option diff --git a/middle_end/flambda2/compare/compare.ml b/middle_end/flambda2/compare/compare.ml index 9915955a4fb..5250f7867cc 100644 --- a/middle_end/flambda2/compare/compare.ml +++ b/middle_end/flambda2/compare/compare.ml @@ -242,10 +242,10 @@ let subst_unary_primitive env (p : Flambda_primitive.unary_primitive) : let move_from = subst_function_slot env move_from in let move_to = subst_function_slot env move_to in Project_function_slot { move_from; move_to } - | Project_value_slot { project_from; value_slot } -> + | Project_value_slot { project_from; value_slot; kind } -> let project_from = subst_function_slot env project_from in let value_slot = subst_value_slot env value_slot in - Project_value_slot { project_from; value_slot } + Project_value_slot { project_from; value_slot; kind } | _ -> p let subst_primitive env (p : Flambda_primitive.t) : Flambda_primitive.t = @@ -270,8 +270,8 @@ let subst_set_of_closures env set = let value_slots = Set_of_closures.value_slots set |> Value_slot.Map.bindings - |> List.map (fun (var, simple) -> - subst_value_slot env var, subst_simple env simple) + |> List.map (fun (var, (simple, kind)) -> + subst_value_slot env var, (subst_simple env simple, kind)) |> Value_slot.Map.of_list in Set_of_closures.create Alloc_mode.For_allocations.heap ~value_slots decls @@ -631,15 +631,26 @@ let unary_prim_ops env (prim_op1 : Flambda_primitive.unary_primitive) Flambda_primitive.Project_function_slot { move_from = move_from1'; move_to = move_to1' }) | ( Project_value_slot - { project_from = function_slot1; value_slot = value_slot1 }, + { project_from = function_slot1; + value_slot = value_slot1; + kind = kind1 + }, Project_value_slot - { project_from = function_slot2; value_slot = value_slot2 } ) -> - pairs ~f1:function_slots ~f2:value_slots env - (function_slot1, value_slot1) - (function_slot2, value_slot2) - |> Comparison.map ~f:(fun (function_slot1', value_slot1') -> + { project_from = function_slot2; + value_slot = value_slot2; + kind = kind2 + } ) -> + triples ~f1:function_slots ~f2:value_slots + ~f3:(Comparator.of_predicate Flambda_kind.With_subkind.equal) + env + (function_slot1, value_slot1, kind1) + (function_slot2, value_slot2, kind2) + |> Comparison.map ~f:(fun (function_slot1', value_slot1', kind1') -> Flambda_primitive.Project_value_slot - { project_from = function_slot1'; value_slot = value_slot1' }) + { project_from = function_slot1'; + value_slot = value_slot1'; + kind = kind1' + }) | _, _ -> if Flambda_primitive.equal_unary_primitive prim_op1 prim_op2 then Equivalent @@ -738,21 +749,22 @@ let sets_of_closures env set1 set2 : Set_of_closures.t Comparison.t = * similar (and less worrisome) with function slots. *) let value_slots_by_value set = Value_slot.Map.bindings (Set_of_closures.value_slots set) - |> List.map (fun (var, value) -> subst_simple env value, var) + |> List.map (fun (var, (value, kind)) -> kind, subst_simple env value, var) in (* We want to process the whole map to find new correspondences between * value slots, so we need to remember whether we've found any mismatches *) let ok = ref true in let () = - let compare (value1, _var1) (value2, _var2) = - Simple.compare value1 value2 + let compare (kind1, value1, _var1) (kind2, value2, _var2) = + let c = Flambda_kind.With_subkind.compare kind1 kind2 in + if c = 0 then Simple.compare value1 value2 else c in iter2_merged (value_slots_by_value set1) (value_slots_by_value set2) ~compare ~f:(fun elt1 elt2 -> match elt1, elt2 with | None, None -> () | Some _, None | None, Some _ -> ok := false - | Some (_value1, var1), Some (_value2, var2) -> ( + | Some (_kind1, _value1, var1), Some (_kind2, _value2, var2) -> ( match value_slots env var1 var2 with | Equivalent -> () | Different { approximant = _ } -> ok := false)) diff --git a/middle_end/flambda2/dune b/middle_end/flambda2/dune index cc24eb60628..b4f40e33b53 100644 --- a/middle_end/flambda2/dune +++ b/middle_end/flambda2/dune @@ -3,12 +3,13 @@ (env (_ (flags - (:standard -w +a-30-40-41-42)))) + (:standard -w +a-30-40-41-42-69-70)))) (library (name flambda2) (wrapped false) - (instrumentation (backend bisect_ppx)) + (instrumentation + (backend bisect_ppx)) (flags (:standard -principal diff --git a/middle_end/flambda2/flambda2.ml b/middle_end/flambda2/flambda2.ml index 195d3a5332e..0a2b199429a 100644 --- a/middle_end/flambda2/flambda2.ml +++ b/middle_end/flambda2/flambda2.ml @@ -17,29 +17,21 @@ (* Unlike most of the rest of Flambda 2, this file depends on ocamloptcomp, meaning it can call [Compilenv]. *) -let symbol_for_global id = - Compilenv.symbol_for_global' id |> Flambda2_identifiers.Symbol.create_wrapped - -let get_global_info comp_unit = +let get_module_info comp_unit = + let cmx_name = Compilation_unit.name comp_unit in (* Typing information for predefined exceptions should be populated directly by the callee. *) - if Compilation_unit.equal comp_unit Compilation_unit.predef_exn + if Compilation_unit.Name.equal cmx_name Compilation_unit.Name.predef_exn then Misc.fatal_error "get_global_info is not for use with predefined exception compilation \ units"; - if Compilation_unit.equal comp_unit - (Flambda2_identifiers.Symbol.external_symbols_compilation_unit ()) + if Compilation_unit.Name.equal cmx_name + (Flambda2_identifiers.Symbol.external_symbols_compilation_unit () + |> Compilation_unit.name) then None else - (* CR lmaurer: It feels like there should be a - [Compilenv.get_global_info_for_unit] here, but I'm not quite sure how to - implement it. *) - let id = - Compilation_unit.name comp_unit - |> Compilation_unit.Name.to_string |> Ident.create_persistent - in - match Compilenv.get_global_export_info id with + match Compilenv.get_unit_export_info comp_unit with | None | Some (Flambda2 None) -> None | Some (Flambda2 (Some info)) -> Some info | Some (Clambda _) -> @@ -48,12 +40,12 @@ let get_global_info comp_unit = Misc.fatal_errorf "The .cmx file for unit %a was compiled with the Closure middle-end, \ not Flambda 2, and cannot be loaded" - Compilation_unit.print comp_unit + Compilation_unit.Name.print cmx_name | Some (Flambda1 _) -> Misc.fatal_errorf "The .cmx file for unit %a was compiled with the Flambda 1 middle-end, \ not Flambda 2, and cannot be loaded" - Compilation_unit.print comp_unit + Compilation_unit.Name.print cmx_name let print_rawflambda ppf unit = if Flambda_features.dump_rawflambda () @@ -93,7 +85,7 @@ let output_flexpect ~ml_filename ~raw_flambda:old_unit new_unit = Print_fexpr.expect_test_spec ppf test; Format.pp_print_flush ppf ()) -let lambda_to_cmm ~ppf_dump:ppf ~prefixname ~filename ~module_ident +let lambda_to_cmm ~ppf_dump:ppf ~prefixname ~filename ~compilation_unit ~module_block_size_in_words ~module_initializer ~keep_symbol_tables = (* Make sure -linscan is enabled in classic mode. Doing this here to be sure it happens exactly when -Oclassic is in effect, which we don't know at CLI @@ -119,15 +111,13 @@ let lambda_to_cmm ~ppf_dump:ppf ~prefixname ~filename ~module_ident "Cannot compile on targets where floats are not word-width when the \ float array optimisation is enabled"; let run () = - let cmx_loader = - Flambda_cmx.create_loader ~get_global_info ~symbol_for_global - in + let cmx_loader = Flambda_cmx.create_loader ~get_module_info in let (Mode mode) = Flambda_features.mode () in let raw_flambda, close_program_metadata = Profile.record_call "lambda_to_flambda" (fun () -> - Lambda_to_flambda.lambda_to_flambda ~mode ~symbol_for_global - ~big_endian:Arch.big_endian ~cmx_loader ~module_ident - ~module_block_size_in_words module_initializer) + Lambda_to_flambda.lambda_to_flambda ~mode ~big_endian:Arch.big_endian + ~cmx_loader ~compilation_unit ~module_block_size_in_words + module_initializer) in Compiler_hooks.execute Raw_flambda2 raw_flambda; print_rawflambda ppf raw_flambda; diff --git a/middle_end/flambda2/flambda2.mli b/middle_end/flambda2/flambda2.mli index 6daeb009ba3..34d46647100 100644 --- a/middle_end/flambda2/flambda2.mli +++ b/middle_end/flambda2/flambda2.mli @@ -21,13 +21,11 @@ val lambda_to_cmm : ppf_dump:Format.formatter -> prefixname:string -> filename:string -> - module_ident:Ident.t -> + compilation_unit:Compilation_unit.t -> module_block_size_in_words:int -> module_initializer:Lambda.lambda -> keep_symbol_tables:bool -> Cmm.phrase list -val symbol_for_global : Ident.t -> Flambda2_identifiers.Symbol.t - -val get_global_info : +val get_module_info : Compilation_unit.t -> Flambda2_cmx.Flambda_cmx_format.t option diff --git a/middle_end/flambda2/from_lambda/closure_conversion.ml b/middle_end/flambda2/from_lambda/closure_conversion.ml index 1004b4ee04d..57ce92acbab 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion.ml @@ -48,10 +48,6 @@ type close_functions_result = correctly compute the free names of [Code]. *) let use_of_symbol_as_simple acc symbol = acc, Simple.symbol symbol -let symbol_for_ident acc env id = - let symbol = Env.symbol_for_global env id in - use_of_symbol_as_simple acc symbol - let declare_symbol_for_function_slot env ident function_slot : Env.t * Symbol.t = let symbol = @@ -59,7 +55,10 @@ let declare_symbol_for_function_slot env ident function_slot : Env.t * Symbol.t (Compilation_unit.get_current_exn ()) (Linkage_name.of_string (Function_slot.to_string function_slot)) in - let env = Env.add_simple_to_substitute env ident (Simple.symbol symbol) in + let env = + Env.add_simple_to_substitute env ident (Simple.symbol symbol) + K.With_subkind.any_value + in env, symbol let register_const0 acc constant name = @@ -167,16 +166,18 @@ let close_const acc const = let named = Named.create_simple simple in acc, named, name -let find_simple_from_id env id = +let find_simple_from_id_with_kind env id = match Env.find_simple_to_substitute_exn env id with - | simple -> simple + | simple, kind -> simple, kind | exception Not_found -> ( match Env.find_var_exn env id with | exception Not_found -> Misc.fatal_errorf "find_simple_from_id: Cannot find [Ident] %a in environment" Ident.print id - | var -> Simple.var var) + | var, kind -> Simple.var var, kind) + +let find_simple_from_id env id = fst (find_simple_from_id_with_kind env id) (* CR mshinwell: Avoid the double lookup *) let find_simple acc env (simple : IR.simple) = @@ -189,6 +190,17 @@ let find_simple acc env (simple : IR.simple) = let find_simples acc env ids = List.fold_left_map (fun acc id -> find_simple acc env id) acc ids +let find_value_approximation acc env simple = + Simple.pattern_match' simple + ~var:(fun var ~coercion:_ -> Env.find_var_approximation env var) + ~symbol:(fun sym ~coercion:_ -> Acc.find_symbol_approximation acc sym) + ~const:(fun const -> + match Reg_width_const.descr const with + | Tagged_immediate i -> Value_approximation.Value_int i + | Naked_immediate _ | Naked_float _ | Naked_int32 _ | Naked_int64 _ + | Naked_nativeint _ -> + Value_approximation.Value_unknown) + module Inlining = struct include Closure_conversion_aux.Inlining @@ -209,25 +221,22 @@ module Inlining = struct | Some (Value_symbol _) | Some (Value_int _) | Some (Block_approximation _) -> assert false - | Some (Closure_approximation { code = Metadata_only _; _ }) -> - Inlining_report.record_decision_at_call_site_for_known_function ~tracker - ~apply ~pass:After_closure_conversion ~unrolling_depth:None - ~callee:(Inlining_history.Absolute.empty compilation_unit) - ~are_rebuilding_terms Definition_says_not_to_inline; - Not_inlinable - | Some (Closure_approximation { code = Code_present code; _ }) -> + | Some (Closure_approximation { code; _ }) -> + let metadata = Code_or_metadata.code_metadata code in let fun_params_length = - Code.params_arity code |> Flambda_arity.With_subkinds.to_arity - |> Flambda_arity.length + Code_metadata.params_arity metadata + |> Flambda_arity.With_subkinds.to_arity |> Flambda_arity.length in - if fun_params_length > List.length (Apply_expr.args apply) + if (not (Code_or_metadata.code_present code)) + || fun_params_length > List.length (Apply_expr.args apply) then ( Inlining_report.record_decision_at_call_site_for_known_function ~tracker ~apply ~pass:After_closure_conversion ~unrolling_depth:None - ~callee:(Code.absolute_history code) + ~callee:(Inlining_history.Absolute.empty compilation_unit) ~are_rebuilding_terms Definition_says_not_to_inline; Not_inlinable) else + let code = Code_or_metadata.get_code code in let inlined_call = Apply_expr.inlined apply in let decision, res = match inlined_call with @@ -448,7 +457,8 @@ let close_c_call acc env ~loc ~let_bound_var let prim = P.Unary (Reinterpret_int64_as_float, arg) in let acc, return_result = Apply_cont_with_acc.create acc return_continuation - ~args:[Simple.var result] ~dbg + ~args:[Simple.var result] + ~dbg in let acc, return_result_expr = Expr_with_acc.create_apply_cont acc return_result @@ -585,13 +595,22 @@ let close_primitive acc env ~let_bound_var named (prim : Lambda.primitive) ~args in close_c_call acc env ~loc ~let_bound_var prim ~args exn_continuation dbg ~current_region k - | Pgetglobal id, [] -> - let is_predef_exn = Ident.is_predef id in - if not (is_predef_exn || not (Ident.same id (Env.current_unit_id env))) + | Pgetglobal cu, [] -> + if Compilation_unit.equal cu (Env.current_unit env) then - Misc.fatal_errorf "Non-predef Pgetglobal %a in the same unit" Ident.print - id; - let acc, simple = symbol_for_ident acc env id in + Misc.fatal_errorf "Pgetglobal %a in the same unit" Compilation_unit.print + cu; + let symbol = + Flambda2_import.Symbol.for_compilation_unit cu |> Symbol.create_wrapped + in + let acc, simple = use_of_symbol_as_simple acc symbol in + let named = Named.create_simple simple in + k acc (Some named) + | Pgetpredef id, [] -> + let symbol = + Flambda2_import.Symbol.for_predef_ident id |> Symbol.create_wrapped + in + let acc, simple = use_of_symbol_as_simple acc symbol in let named = Named.create_simple simple in k acc (Some named) | Praise raise_kind, [_] -> @@ -637,12 +656,12 @@ let close_primitive acc env ~let_bound_var named (prim : Lambda.primitive) ~args Misc.fatal_error "Unexpected empty float block in [Closure_conversion]" | Pmakearray (_, _, _mode) -> register_const0 acc Static_const.empty_array "empty_array" - | Pidentity | Pbytes_to_string | Pbytes_of_string | Pignore | Prevapply _ - | Pdirapply _ | Pgetglobal _ | Psetglobal _ | Pfield _ | Pfield_computed _ - | Psetfield _ | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ - | Pduprecord _ | Pccall _ | Praise _ | Psequand | Psequor | Pnot | Pnegint - | Paddint | Psubint | Pmulint | Pdivint _ | Pmodint _ | Pandint | Porint - | Pxorint | Plslint | Plsrint | Pasrint | Pintcomp _ | Pcompare_ints + | Pbytes_to_string | Pbytes_of_string | Pignore | Pgetglobal _ + | Psetglobal _ | Pgetpredef _ | Pfield _ | Pfield_computed _ | Psetfield _ + | Psetfield_computed _ | Pfloatfield _ | Psetfloatfield _ | Pduprecord _ + | Pccall _ | Praise _ | Psequand | Psequor | Pnot | Pnegint | Paddint + | Psubint | Pmulint | Pdivint _ | Pmodint _ | Pandint | Porint | Pxorint + | Plslint | Plsrint | Pasrint | Pintcomp _ | Pcompare_ints | Pcompare_floats | Pcompare_bints _ | Poffsetint _ | Poffsetref _ | Pintoffloat | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ | Pfloatcomp _ | Pstringlength @@ -682,11 +701,8 @@ let close_named acc env ~let_bound_var (named : IR.named) (k : Acc.t -> Named.t option -> Expr_with_acc.t) : Expr_with_acc.t = match named with | Simple (Var id) -> - let acc, simple = - if not (Ident.is_predef id) - then find_simple acc env (Var id) - else symbol_for_ident acc env id - in + assert (not (Ident.is_global_or_predef id)); + let acc, simple = find_simple acc env (Var id) in let named = Named.create_simple simple in k acc (Some named) | Simple (Const cst) -> @@ -701,9 +717,13 @@ let close_named acc env ~let_bound_var (named : IR.named) ~register_const_string:(fun acc -> register_const_string acc) prim Debuginfo.none (fun acc named -> k acc (Some named)) - | Begin_region -> + | Begin_region { try_region_parent } -> let prim : Lambda_to_flambda_primitives_helpers.expr_primitive = - Nullary Begin_region + match try_region_parent with + | None -> Nullary Begin_region + | Some try_region_parent -> + let try_region_parent = find_simple_from_id env try_region_parent in + Unary (Begin_try_region, Simple try_region_parent) in Lambda_to_flambda_primitives_helpers.bind_rec acc None ~register_const_string:(fun acc -> register_const_string acc) @@ -720,15 +740,16 @@ let close_named acc env ~let_bound_var (named : IR.named) (fun acc named -> k acc (Some named)) | Prim { prim; args; loc; exn_continuation; region } -> close_primitive acc env ~let_bound_var named prim ~args loc exn_continuation - ~current_region:(Env.find_var env region) k + ~current_region:(fst (Env.find_var env region)) + k -let close_let acc env id user_visible defining_expr +let close_let acc env id user_visible kind defining_expr ~(body : Acc.t -> Env.t -> Expr_with_acc.t) : Expr_with_acc.t = - let body_env, var = Env.add_var_like env id user_visible in + let body_env, var = Env.add_var_like env id user_visible kind in let cont acc (defining_expr : Named.t option) = match defining_expr with | Some (Simple simple) -> - let body_env = Env.add_simple_to_substitute env id simple in + let body_env = Env.add_simple_to_substitute env id simple kind in body acc body_env | None -> body acc body_env | Some (Prim ((Nullary Begin_region | Unary (End_region, _)), _)) @@ -745,16 +766,16 @@ let close_let acc env id user_visible defining_expr List.map (fun field -> match Simple.must_be_symbol field with - | None -> Env.find_value_approximation body_env field + | None -> find_value_approximation acc body_env field | Some (sym, _) -> Value_approximation.Value_symbol sym) fields |> Array.of_list in Some - (Env.add_block_approximation body_env (Name.var var) approxs + (Env.add_block_approximation body_env var approxs (Alloc_mode.For_allocations.as_type alloc_mode)) | Prim (Binary (Block_load _, block, field), _) -> ( - match Env.find_value_approximation body_env block with + match find_value_approximation acc body_env block with | Value_unknown -> Some body_env | Closure_approximation _ | Value_symbol _ | Value_int _ -> (* Here we assume [block] has already been substituted as a known @@ -792,10 +813,9 @@ let close_let acc env id user_visible defining_expr (* In spirit, this is the same as the simple case but more cumbersome to detect, we have to remove the now useless let-binding later. *) - Some (Env.add_simple_to_substitute env id (Simple.symbol sym)) - | _ -> - Some (Env.add_value_approximation body_env (Name.var var) approx)) - ) + Some + (Env.add_simple_to_substitute env id (Simple.symbol sym) kind) + | _ -> Some (Env.add_var_approximation body_env var approx))) | _ -> Some body_env in let var = VB.create var Name_mode.normal in @@ -824,17 +844,16 @@ let close_let_cont acc env ~name ~is_exn_handler ~params Misc.fatal_errorf "[Let_cont]s marked as exception handlers must be [Nonrecursive]: %a" Continuation.print name); - let params_with_kinds = params in - let handler_env, params = - Env.add_vars_like env - (List.map - (fun (param, user_visible, _kind) -> param, user_visible) - params) + let params_with_kinds = + List.map + (fun (param, user_visible, kind) -> + param, user_visible, K.With_subkind.from_lambda kind) + params in + let handler_env, params = Env.add_vars_like env params_with_kinds in let handler_params = List.map2 - (fun param (_, _, kind) -> - BP.create param (K.With_subkind.from_lambda kind)) + (fun param (_, _, kind) -> BP.create param kind) params params_with_kinds |> Bound_parameters.create in @@ -844,13 +863,11 @@ let close_let_cont acc env ~name ~is_exn_handler ~params | None -> handler_env | Some args -> List.fold_left2 - (fun env arg_approx (param, (param_id, _, _)) -> - let env = - Env.add_value_approximation env (Name.var param) arg_approx - in + (fun env arg_approx (param, (param_id, _, kind)) -> + let env = Env.add_var_approximation env param arg_approx in match (arg_approx : Env.value_approximation) with | Value_symbol s | Closure_approximation { symbol = Some s; _ } -> - Env.add_simple_to_substitute env param_id (Simple.symbol s) + Env.add_simple_to_substitute env param_id (Simple.symbol s) kind | _ -> env) handler_env args (List.combine params params_with_kinds) @@ -885,7 +902,7 @@ let close_exact_or_unknown_apply acc env let callee = find_simple_from_id env func in let current_region = match replace_region with - | None -> Env.find_var env region + | None -> fst (Env.find_var env region) | Some region -> region in let mode = Alloc_mode.For_types.from_lambda mode in @@ -958,7 +975,7 @@ let close_exact_or_unknown_apply acc env let close_apply_cont acc env ~dbg cont trap_action args : Expr_with_acc.t = let acc, args = find_simples acc env args in let trap_action = close_trap_action_opt trap_action in - let args_approx = List.map (Env.find_value_approximation env) args in + let args_approx = List.map (find_value_approximation acc env) args in let acc, apply_cont = Apply_cont_with_acc.create acc ?trap_action ~args_approx cont ~args ~dbg in @@ -970,7 +987,7 @@ let close_switch acc env ~condition_dbg scrutinee (sw : IR.switch) : let untagged_scrutinee = Variable.create "untagged" in let untagged_scrutinee' = VB.create untagged_scrutinee Name_mode.normal in let known_const_scrutinee = - match Env.find_value_approximation env scrutinee with + match find_value_approximation acc env scrutinee with | Value_approximation.Value_int i -> Some i | _ -> None in @@ -982,7 +999,7 @@ let close_switch acc env ~condition_dbg scrutinee (sw : IR.switch) : (fun acc (case, cont, trap_action, args) -> let trap_action = close_trap_action_opt trap_action in let acc, args = find_simples acc env args in - let args_approx = List.map (Env.find_value_approximation env) args in + let args_approx = List.map (find_value_approximation acc env) args in let action acc = Apply_cont_with_acc.create acc ?trap_action ~args_approx cont ~args ~dbg:condition_dbg @@ -1089,8 +1106,28 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot decl let params = Function_decl.params decl in let return = Function_decl.return decl in let return_continuation = Function_decl.return_continuation decl in - let recursive = Function_decl.recursive decl in + let acc, exn_continuation = + close_exn_continuation acc external_env + (Function_decl.exn_continuation decl) + in + assert ( + match Exn_continuation.extra_args exn_continuation with + | [] -> true + | _ :: _ -> false); let my_closure = Variable.create "my_closure" in + let recursive = Function_decl.recursive decl in + (* Mark function available for loopify only if it is a single recursive + function *) + let is_single_recursive_function = + match recursive, Function_decls.to_list function_declarations with + | Recursive, [_] -> true + | Recursive, ([] | _ :: _ :: _) -> false + | Non_recursive, _ -> false + in + let acc = + Acc.push_closure_info acc ~return_continuation ~exn_continuation ~my_closure + ~is_purely_tailrec:is_single_recursive_function + in let my_region = Function_decl.my_region decl in let function_slot = Function_decl.function_slot decl in let my_depth = Variable.create "my_depth" in @@ -1165,8 +1202,11 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot decl in let simple = Simple.with_coercion (Simple.var var) coerce_to_deeper in let approx = Function_slot.Map.find function_slot approx_map in - let env = Env.add_simple_to_substitute env let_rec_ident simple in - let env = Env.add_value_approximation env (Name.var var) approx in + let env = + Env.add_simple_to_substitute env let_rec_ident simple + K.With_subkind.any_value + in + let env = Env.add_var_approximation env var approx in to_bind, env) (Variable.Map.empty, closure_env) (Function_decls.to_list function_declarations) @@ -1174,23 +1214,25 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot decl let closure_env = Ident.Map.fold (fun id var env -> - Simple.pattern_match - (find_simple_from_id external_env id) - ~const:(fun _ -> assert false) - ~name:(fun name ~coercion:_ -> - Env.add_approximation_alias (Env.add_var env id var) name - (Name.var var))) + let simple, kind = find_simple_from_id_with_kind external_env id in + Env.add_var_approximation + (Env.add_var env id var kind) + var + (find_value_approximation acc env simple)) value_slots_for_idents closure_env in let closure_env = List.fold_right - (fun (id, _) env -> - let env, _var = Env.add_var_like env id User_visible in + (fun (id, kind) env -> + let env, _var = + Env.add_var_like env id User_visible (K.With_subkind.from_lambda kind) + in env) params closure_env in let closure_env, my_region = Env.add_var_like closure_env my_region Not_user_visible + K.With_subkind.region in let closure_env = Env.with_depth closure_env my_depth in let closure_env, absolute_history, relative_history = @@ -1210,7 +1252,7 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot decl as stubs but certainly should be. *) let stub = Function_decl.stub decl in let param_vars = - List.map (fun (id, kind) -> Env.find_var closure_env id, kind) params + List.map (fun (id, kind) -> fst (Env.find_var closure_env id), kind) params in let params = List.map @@ -1261,7 +1303,11 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot decl let named = Named.create_prim (Unary - ( Project_value_slot { project_from = function_slot; value_slot }, + ( Project_value_slot + { project_from = function_slot; + value_slot; + kind = K.With_subkind.any_value + }, my_closure' )) Debuginfo.none in @@ -1276,14 +1322,6 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot decl Let_with_acc.create acc bound (Named.create_rec_info next_depth_expr) ~body in let cost_metrics = Acc.cost_metrics acc in - let acc, exn_continuation = - close_exn_continuation acc external_env - (Function_decl.exn_continuation decl) - in - assert ( - match Exn_continuation.extra_args exn_continuation with - | [] -> true - | _ :: _ -> false); let inline : Inline_attribute.t = (* We make a decision based on [fallback_inlining_heuristic] here to try to mimic Closure's behaviour as closely as possible, particularly when there @@ -1317,6 +1355,7 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot decl |> Acc.remove_continuation_from_free_names (Exn_continuation.exn_handler exn_continuation) in + let closure_info, acc = Acc.pop_closure_info acc in let params_arity = Bound_parameters.arity_with_subkinds params in let is_tupled = match Function_decl.kind decl with Curried _ -> false | Tupled -> true @@ -1328,6 +1367,15 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot decl then Function_decl_inlining_decision_type.Stub else Function_decl_inlining_decision_type.Not_yet_decided in + let loopify : Loopify_attribute.t = + match Function_decl.loop decl with + | Always_loop -> Always_loopify + | Never_loop -> Never_loopify + | Default_loop -> + if closure_info.is_purely_tailrec + then Default_loopify_and_tailrec + else Default_loopify_and_not_tailrec + in let code = Code.create code_id ~params_and_body ~free_names_of_params_and_body:(Acc.free_names acc) ~params_arity @@ -1338,6 +1386,8 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot decl ~contains_no_escaping_local_allocs: (Function_decl.contains_no_escaping_local_allocs decl) ~stub ~inline + ~poll_attribute: + (Poll_attribute.from_lambda (Function_decl.poll_attribute decl)) ~check:(Check_attribute.from_lambda (Function_decl.check_attribute decl)) ~is_a_functor:(Function_decl.is_a_functor decl) ~recursive ~newer_version_of:None ~cost_metrics @@ -1345,7 +1395,7 @@ let close_one_function acc ~code_id ~external_env ~by_function_slot decl ~dbg ~is_tupled ~is_my_closure_used: (Function_params_and_body.is_my_closure_used params_and_body) - ~inlining_decision ~absolute_history ~relative_history + ~inlining_decision ~absolute_history ~relative_history ~loopify in let approx = let code = Code_or_metadata.create code in @@ -1377,7 +1427,7 @@ let close_functions acc external_env ~current_region function_declarations = let has_non_var_subst, subst_var = match Env.find_simple_to_substitute_exn external_env id with | exception Not_found -> false, None - | simple -> + | simple, _kind -> Simple.pattern_match simple ~const:(fun _ -> true, None) ~name:(fun name ~coercion:_ -> @@ -1444,6 +1494,9 @@ let close_functions acc external_env ~current_region function_declarations = let result_arity = Flambda_arity.With_subkinds.create [K.With_subkind.from_lambda return] in + let poll_attribute = + Poll_attribute.from_lambda (Function_decl.poll_attribute decl) + in let check = Check_attribute.from_lambda (Function_decl.check_attribute decl) in @@ -1462,6 +1515,7 @@ let close_functions acc external_env ~current_region function_declarations = ~contains_no_escaping_local_allocs: (Function_decl.contains_no_escaping_local_allocs decl) ~stub:(Function_decl.stub decl) ~inline:Never_inline ~check + ~poll_attribute ~is_a_functor:(Function_decl.is_a_functor decl) ~recursive:(Function_decl.recursive decl) ~newer_version_of:None ~cost_metrics @@ -1470,6 +1524,7 @@ let close_functions acc external_env ~current_region function_declarations = ~inlining_decision:Recursive ~absolute_history:(Inlining_history.Absolute.empty compilation_unit) ~relative_history:Inlining_history.Relative.empty + ~loopify:Never_loopify in let code = Code_or_metadata.create_metadata_only metadata in let approx = @@ -1479,11 +1534,11 @@ let close_functions acc external_env ~current_region function_declarations = Function_slot.Map.add function_slot approx approx_map) Function_slot.Map.empty func_decl_list in - let external_env, symbol_map = + let acc, external_env, symbol_map = if can_be_lifted then Ident.Map.fold - (fun ident function_slot (env, symbol_map) -> + (fun ident function_slot (acc, env, symbol_map) -> let env, symbol = declare_symbol_for_function_slot env ident function_slot in @@ -1496,13 +1551,11 @@ let close_functions acc external_env ~current_region function_declarations = | _ -> assert false (* see above *) in - let env = - Env.add_value_approximation env (Name.symbol symbol) approx - in - env, Function_slot.Map.add function_slot symbol symbol_map) + let acc = Acc.add_symbol_approximation acc symbol approx in + acc, env, Function_slot.Map.add function_slot symbol symbol_map) function_slots_from_idents - (external_env, Function_slot.Map.empty) - else external_env, Function_slot.Map.empty + (acc, external_env, Function_slot.Map.empty) + else acc, external_env, Function_slot.Map.empty in let acc, approximations = List.fold_left @@ -1548,11 +1601,13 @@ let close_functions acc external_env ~current_region function_declarations = let value_slots = Ident.Map.fold (fun id value_slot map -> - let external_simple = find_simple_from_id external_env id in + let external_simple, kind = + find_simple_from_id_with_kind external_env id + in (* We're sure [external_simple] is a variable since [value_slot_from_idents] has already filtered constants and symbols out. *) - Value_slot.Map.add value_slot external_simple map) + Value_slot.Map.add value_slot (external_simple, kind) map) value_slots_from_idents Value_slot.Map.empty in let set_of_closures = @@ -1589,12 +1644,14 @@ let close_functions acc external_env ~current_region function_declarations = let close_let_rec acc env ~function_declarations ~(body : Acc.t -> Env.t -> Expr_with_acc.t) ~current_region = - let current_region = Env.find_var env current_region in + let current_region = fst (Env.find_var env current_region) in let env = List.fold_right (fun decl env -> let id = Function_decl.let_rec_ident decl in - let env, _var = Env.add_var_like env id User_visible in + let env, _var = + Env.add_var_like env id User_visible K.With_subkind.any_value + in env) function_declarations env in @@ -1602,7 +1659,9 @@ let close_let_rec acc env ~function_declarations List.fold_left (fun (fun_vars_map, ident_map) decl -> let ident = Function_decl.let_rec_ident decl in - let fun_var = VB.create (Env.find_var env ident) Name_mode.normal in + let fun_var = + VB.create (fst (Env.find_var env ident)) Name_mode.normal + in let function_slot = Function_decl.function_slot decl in ( Function_slot.Map.add function_slot fun_var fun_vars_map, Function_slot.Map.add function_slot ident ident_map )) @@ -1640,15 +1699,16 @@ let close_let_rec acc env ~function_declarations in match closed_functions with | Lifted symbols -> - let env = + let acc, env = Function_slot.Lmap.fold - (fun function_slot (symbol, approx) env -> + (fun function_slot (symbol, approx) (acc, env) -> let ident = Function_slot.Map.find function_slot ident_map in let env = Env.add_simple_to_substitute env ident (Simple.symbol symbol) + K.With_subkind.any_value in - Env.add_value_approximation env (Name.symbol symbol) approx) - symbols env + Acc.add_symbol_approximation acc symbol approx, env) + symbols (acc, env) in body acc env | Dynamic (set_of_closures, approximations) -> @@ -1680,7 +1740,7 @@ let close_let_rec acc env ~function_declarations Function_slot.Map.fold (fun function_slot fun_var env -> let approx = Function_slot.Map.find function_slot approximations in - Env.add_value_approximation env (Name.var (VB.var fun_var)) approx) + Env.add_var_approximation env (VB.var fun_var) approx) fun_vars_map env in let acc, body = body acc env in @@ -1714,13 +1774,19 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) IR.{ exn_handler = Continuation.create (); extra_args = [] } in let all_args = args @ List.map (fun (a, _) -> IR.Var a) params in + let result_mode = + if contains_no_escaping_local_allocs + then Lambda.alloc_heap + else Lambda.alloc_local + in let fbody acc env = close_exact_or_unknown_apply acc env { apply with kind = Function; args = all_args; continuation = return_continuation; - exn_continuation + exn_continuation; + mode = result_mode } (Some approx) ~replace_region:None in @@ -1730,8 +1796,11 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) specialise = Default_specialise; local = Default_local; check = Default_check; + loop = Default_loop; is_a_functor = false; - stub = false + stub = true; + poll = Default_poll; + tmc_candidate = false } in let free_idents_of_body = @@ -1752,21 +1821,25 @@ let wrap_partial_application acc env apply_continuation (apply : IR.apply) let num_supplied_local_args = args_arity - num_leading_heap_params in Lambda.alloc_local, num_trailing_local_params - num_supplied_local_args in + if not (Lambda.sub_mode closure_alloc_mode apply.IR.mode) + then + Misc.fatal_errorf "Partial application of %a with wrong mode at %s" + Ident.print apply.IR.func + (Debuginfo.Scoped_location.string_of_scoped_location apply.IR.loc); let function_declarations = (* CR keryan: Same as above, better kind for return type *) [ Function_decl.create ~let_rec_ident:(Some wrapper_id) ~function_slot ~kind:(Lambda.Curried { nlocal = num_trailing_local_params }) ~params ~return:Lambda.Pgenval ~return_continuation ~exn_continuation ~my_region:apply.region ~body:fbody ~attr ~loc:apply.loc - ~free_idents_of_body ~stub:true ~closure_alloc_mode - ~num_trailing_local_params ~contains_no_escaping_local_allocs - Recursive.Non_recursive ] + ~free_idents_of_body ~closure_alloc_mode ~num_trailing_local_params + ~contains_no_escaping_local_allocs Recursive.Non_recursive ] in let body acc env = let arg = find_simple_from_id env wrapper_id in let acc, apply_cont = Apply_cont_with_acc.create acc - ~args_approx:[Env.find_value_approximation env arg] + ~args_approx:[find_value_approximation acc env arg] apply_continuation ~args:[arg] ~dbg:Debuginfo.none in Expr_with_acc.create_apply_cont acc apply_cont @@ -1794,7 +1867,7 @@ let wrap_over_application acc env full_call (apply : IR.apply) over_args in let apply_region = match needs_region with - | None -> Env.find_var env apply.region + | None -> fst (Env.find_var env apply.region) | Some (region, _) -> region in let perform_over_application acc = @@ -1812,12 +1885,10 @@ let wrap_over_application acc env full_call (apply : IR.apply) over_args | Rc_normal | Rc_close_at_apply -> Apply.Position.Normal | Rc_nontail -> Apply.Position.Nontail in - let alloc_mode = - if contains_no_escaping_local_allocs - then Alloc_mode.For_types.heap - else Alloc_mode.For_types.unknown () + let call_kind = + Call_kind.indirect_function_call_unknown_arity + (Alloc_mode.For_types.from_lambda apply.mode) in - let call_kind = Call_kind.indirect_function_call_unknown_arity alloc_mode in let continuation = match needs_region with | None -> apply_return_continuation @@ -1884,7 +1955,7 @@ type call_args_split = let close_apply acc env (apply : IR.apply) : Expr_with_acc.t = let callee = find_simple_from_id env apply.func in - let approx = Env.find_value_approximation env callee in + let approx = find_value_approximation acc env callee in let code_info = match approx with | Closure_approximation { code; _ } -> @@ -1956,8 +2027,13 @@ let close_apply acc env (apply : IR.apply) : Expr_with_acc.t = ~contains_no_escaping_local_allocs | Over_app (args, remaining_args) -> let full_args_call apply_continuation ~region acc = + let mode = + if contains_no_escaping_local_allocs + then Lambda.alloc_heap + else Lambda.alloc_local + in close_exact_or_unknown_apply acc env - { apply with args; continuation = apply_continuation } + { apply with args; continuation = apply_continuation; mode } (Some approx) ~replace_region:(Some region) in wrap_over_application acc env full_args_call apply remaining_args @@ -2055,22 +2131,24 @@ let bind_code_and_sets_of_closures all_code sets_of_closures acc body = defining_expr ~body) (acc, body) components -let close_program (type mode) ~(mode : mode Flambda_features.mode) - ~symbol_for_global ~big_endian ~cmx_loader ~module_ident - ~module_block_size_in_words ~program ~prog_return_cont ~exn_continuation - ~toplevel_my_region : mode close_program_result = - let env = Env.create ~symbol_for_global ~big_endian ~cmx_loader in +let close_program (type mode) ~(mode : mode Flambda_features.mode) ~big_endian + ~cmx_loader ~compilation_unit ~module_block_size_in_words ~program + ~prog_return_cont ~exn_continuation ~toplevel_my_region : + mode close_program_result = + let env = Env.create ~big_endian in let module_symbol = - symbol_for_global (Ident.create_persistent (Ident.name module_ident)) + Symbol.create_wrapped + (Flambda2_import.Symbol.for_compilation_unit compilation_unit) in let module_block_tag = Tag.Scannable.zero in let module_block_var = Variable.create "module_block" in let return_cont = Continuation.create ~sort:Toplevel_return () in let env, toplevel_my_region = Env.add_var_like env toplevel_my_region Not_user_visible + Flambda_kind.With_subkind.region in let slot_offsets = Slot_offsets.empty in - let acc = Acc.create ~symbol_for_global ~slot_offsets in + let acc = Acc.create ~slot_offsets ~cmx_loader in let load_fields_body acc = let field_vars = List.init module_block_size_in_words (fun pos -> @@ -2204,6 +2282,9 @@ let close_program (type mode) ~(mode : mode Flambda_features.mode) defining_expr ~body) (acc, body) (Acc.declared_symbols acc) in + if Option.is_some (Acc.top_closure_info acc) + then + Misc.fatal_error "Information on nested closures should be empty at the end"; let get_code_metadata code_id = Code_id.Map.find code_id (Acc.code acc) |> Code.code_metadata in diff --git a/middle_end/flambda2/from_lambda/closure_conversion.mli b/middle_end/flambda2/from_lambda/closure_conversion.mli index bbfc508501c..d5f25b53426 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion.mli +++ b/middle_end/flambda2/from_lambda/closure_conversion.mli @@ -27,6 +27,7 @@ val close_let : Env.t -> Ident.t -> IR.user_visible -> + Flambda_kind.With_subkind.t -> IR.named -> body:(Acc.t -> Env.t -> Expr_with_acc.t) -> Expr_with_acc.t @@ -79,10 +80,9 @@ type 'a close_program_result = Flambda_unit.t * 'a close_program_metadata val close_program : mode:'mode Flambda_features.mode -> - symbol_for_global:(Ident.t -> Symbol.t) -> big_endian:bool -> cmx_loader:Flambda_cmx.loader -> - module_ident:Ident.t -> + compilation_unit:Compilation_unit.t -> module_block_size_in_words:int -> program:(Acc.t -> Env.t -> Expr_with_acc.t) -> prog_return_cont:Continuation.t -> diff --git a/middle_end/flambda2/from_lambda/closure_conversion_aux.ml b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml index 83add67da6b..2f82945c360 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion_aux.ml +++ b/middle_end/flambda2/from_lambda/closure_conversion_aux.ml @@ -35,7 +35,7 @@ module IR = struct type named = | Simple of simple | Get_tag of Ident.t - | Begin_region + | Begin_region of { try_region_parent : Ident.t option } | End_region of Ident.t | Prim of { prim : Lambda.primitive; @@ -84,7 +84,10 @@ module IR = struct | Simple (Var id) -> Ident.print ppf id | Simple (Const cst) -> Printlambda.structured_constant ppf cst | Get_tag id -> fprintf ppf "@[<2>(Gettag %a)@]" Ident.print id - | Begin_region -> fprintf ppf "Begin_region" + | Begin_region { try_region_parent = None } -> fprintf ppf "Begin_region" + | Begin_region { try_region_parent = Some try_region_parent } -> + fprintf ppf "@[<2>(Begin_region@ (try_region_parent %a))@]" Ident.print + try_region_parent | End_region id -> fprintf ppf "@[<2>(End_region@ %a)@]" Ident.print id | Prim { prim; args; _ } -> fprintf ppf "@[<2>(%a %a)@]" Printlambda.primitive prim @@ -101,7 +104,7 @@ module Inlining = struct let inline_threshold = Clflags.Float_arg_helper.get ~key:0 !Clflags.inline_threshold in - let magic_scale_constant = 8. in + let magic_scale_constant = 20. in int_of_float (inline_threshold *. magic_scale_constant) let definition_inlining_decision inline cost_metrics = @@ -128,120 +131,59 @@ module Env = struct type value_approximation = Code_or_metadata.t Value_approximation.t type t = - { variables : Variable.t Ident.Map.t; + { variables : (Variable.t * Flambda_kind.With_subkind.t) Ident.Map.t; globals : Symbol.t Numeric_types.Int.Map.t; - simples_to_substitute : Simple.t Ident.Map.t; - current_unit_id : Ident.t; + simples_to_substitute : + (Simple.t * Flambda_kind.With_subkind.t) Ident.Map.t; + current_unit : Compilation_unit.t; current_depth : Variable.t option; - symbol_for_global : Ident.t -> Symbol.t; - value_approximations : value_approximation Name.Map.t; - approximation_for_external_symbol : Symbol.t -> value_approximation; + value_approximations : value_approximation Variable.Map.t; big_endian : bool; path_to_root : Debuginfo.Scoped_location.t; inlining_history_tracker : Inlining_history.Tracker.t } - let current_unit_id t = t.current_unit_id - - let symbol_for_global t = t.symbol_for_global + let current_unit t = t.current_unit let big_endian t = t.big_endian let current_depth t = t.current_depth - let approximation_loader loader = - let externals = ref Symbol.Map.empty in - fun symbol -> - match Symbol.Map.find symbol !externals with - | approx -> approx - | exception Not_found -> - let approx = Flambda_cmx.load_symbol_approx loader symbol in - (if Flambda_features.check_invariants () - then - match approx with - | Value_symbol sym -> - Misc.fatal_errorf - "Closure_conversion: approximation loader returned a Symbol \ - approximation (%a) for symbol %a" - Symbol.print sym Symbol.print symbol - | Value_unknown | Value_int _ | Closure_approximation _ - | Block_approximation _ -> - ()); - let rec filter_inlinable approx = - match (approx : value_approximation) with - | Value_unknown | Value_symbol _ | Value_int _ - | Closure_approximation { code = Metadata_only _; _ } -> - approx - | Block_approximation (approxs, alloc_mode) -> - let approxs = Array.map filter_inlinable approxs in - Value_approximation.Block_approximation (approxs, alloc_mode) - | Closure_approximation - { code_id; function_slot; code = Code_present code; _ } -> ( - match[@ocaml.warning "-fragile-match"] - Inlining.definition_inlining_decision (Code.inline code) - (Code.cost_metrics code) - with - | Attribute_inline | Small_function _ -> approx - | _ -> - Value_approximation.Closure_approximation - { code_id; - function_slot; - code = Code_or_metadata.(remember_only_metadata (create code)); - symbol = None - }) - in - let approx = filter_inlinable approx in - externals := Symbol.Map.add symbol approx !externals; - approx - - let create ~symbol_for_global ~big_endian ~cmx_loader = - let compilation_unit = Compilation_unit.get_current_exn () in - let current_unit_id = - Compilation_unit.name compilation_unit - |> Compilation_unit.Name.to_string |> Ident.create_persistent - in + let create ~big_endian = + let current_unit = Compilation_unit.get_current_exn () in { variables = Ident.Map.empty; globals = Numeric_types.Int.Map.empty; simples_to_substitute = Ident.Map.empty; - current_unit_id; + current_unit; current_depth = None; - value_approximations = Name.Map.empty; - approximation_for_external_symbol = - (if Flambda_features.classic_mode () - then approximation_loader cmx_loader - else fun _symbol -> Value_approximation.Value_unknown); - symbol_for_global; + value_approximations = Variable.Map.empty; big_endian; path_to_root = Debuginfo.Scoped_location.Loc_unknown; - inlining_history_tracker = Inlining_history.Tracker.empty compilation_unit + inlining_history_tracker = Inlining_history.Tracker.empty current_unit } let clear_local_bindings { variables = _; globals; simples_to_substitute; - current_unit_id; - symbol_for_global; + current_unit; current_depth; value_approximations; - approximation_for_external_symbol; big_endian; path_to_root; inlining_history_tracker } = let simples_to_substitute = Ident.Map.filter - (fun _ simple -> not (Simple.is_var simple)) + (fun _ (simple, _kind) -> not (Simple.is_var simple)) simples_to_substitute in { variables = Ident.Map.empty; globals; simples_to_substitute; - current_unit_id; + current_unit; current_depth; value_approximations; - approximation_for_external_symbol; - symbol_for_global; big_endian; path_to_root; inlining_history_tracker @@ -249,35 +191,37 @@ module Env = struct let with_depth t depth_var = { t with current_depth = Some depth_var } - let add_var t id var = { t with variables = Ident.Map.add id var t.variables } + let add_var t id var kind = + { t with variables = Ident.Map.add id (var, kind) t.variables } - let add_vars t ids vars = List.fold_left2 add_var t ids vars + let add_vars t ids vars = + List.fold_left2 (fun t id (var, kind) -> add_var t id var kind) t ids vars let add_var_map t map = { t with variables = Ident.Map.union_right t.variables map } - let add_var_like t id (user_visible : IR.user_visible) = + let add_var_like t id (user_visible : IR.user_visible) kind = let user_visible = match user_visible with | Not_user_visible -> None | User_visible -> Some () in let var = Variable.create_with_same_name_as_ident ?user_visible id in - add_var t id var, var + add_var t id var kind, var let add_vars_like t ids = let vars = List.map - (fun (id, (user_visible : IR.user_visible)) -> + (fun (id, (user_visible : IR.user_visible), kind) -> let user_visible = match user_visible with | Not_user_visible -> None | User_visible -> Some () in - Variable.create_with_same_name_as_ident ?user_visible id) + Variable.create_with_same_name_as_ident ?user_visible id, kind) ids in - add_vars t (List.map fst ids) vars, vars + add_vars t (List.map (fun (id, _, _) -> id) ids) vars, List.map fst vars let find_var t id = try Ident.Map.find id t.variables @@ -288,9 +232,9 @@ module Env = struct let find_var_exn t id = Ident.Map.find id t.variables - let find_name t id = Name.var (find_var t id) + let find_name t id = Name.var (fst (find_var t id)) - let find_name_exn t id = Name.var (find_var_exn t id) + let find_name_exn t id = Name.var (fst (find_var_exn t id)) let find_vars t ids = List.map (fun id -> find_var t id) ids @@ -303,13 +247,14 @@ module Env = struct Misc.fatal_error ("Closure_conversion.Env.find_global: global " ^ string_of_int pos) - let add_simple_to_substitute t id simple = + let add_simple_to_substitute t id simple kind = if Ident.Map.mem id t.simples_to_substitute then Misc.fatal_errorf "Cannot redefine [Simple] associated with %a" Ident.print id; { t with - simples_to_substitute = Ident.Map.add id simple t.simples_to_substitute + simples_to_substitute = + Ident.Map.add id (simple, kind) t.simples_to_substitute } let add_simple_to_substitute_map t map = @@ -321,36 +266,23 @@ module Env = struct let find_simple_to_substitute_exn t id = Ident.Map.find id t.simples_to_substitute - let add_value_approximation t name approx = + let add_var_approximation t var approx = if Value_approximation.is_unknown approx then t else { t with - value_approximations = Name.Map.add name approx t.value_approximations + value_approximations = + Variable.Map.add var approx t.value_approximations } - let add_block_approximation t name approxs alloc_mode = + let add_block_approximation t var approxs alloc_mode = if Array.for_all Value_approximation.is_unknown approxs then t - else - add_value_approximation t name (Block_approximation (approxs, alloc_mode)) + else add_var_approximation t var (Block_approximation (approxs, alloc_mode)) - let find_value_approximation t simple = - Simple.pattern_match simple - ~const:(fun _ -> Value_approximation.Value_unknown) - ~name:(fun name ~coercion:_ -> - try Name.Map.find name t.value_approximations - with Not_found -> - Name.pattern_match name - ~var:(fun _ -> Value_approximation.Value_unknown) - ~symbol:t.approximation_for_external_symbol) - - let add_approximation_alias t name alias = - match find_value_approximation t (Simple.name name) with - | Value_unknown -> t - | ( Value_symbol _ | Value_int _ | Closure_approximation _ - | Block_approximation _ ) as approx -> - add_value_approximation t alias approx + let find_var_approximation t var = + try Variable.Map.find var t.value_approximations + with Not_found -> Value_approximation.Value_unknown let set_path_to_root t path_to_root = if path_to_root = Debuginfo.Scoped_location.Loc_unknown @@ -375,6 +307,13 @@ module Acc = struct | Trackable_arguments of Env.value_approximation list | Untrackable + type closure_info = + { return_continuation : Continuation.t; + exn_continuation : Exn_continuation.t; + my_closure : Variable.t; + is_purely_tailrec : bool + } + type t = { declared_symbols : (Symbol.t * Static_const.t) list; lifted_sets_of_closures : @@ -382,14 +321,16 @@ module Acc = struct * Flambda.Set_of_closures.t) list; shareable_constants : Symbol.t Static_const.Map.t; + symbol_approximations : Env.value_approximation Symbol.Map.t; + approximation_for_external_symbol : Symbol.t -> Env.value_approximation; code : Code.t Code_id.Map.t; free_names : Name_occurrences.t; continuation_applications : continuation_application Continuation.Map.t; cost_metrics : Cost_metrics.t; seen_a_function : bool; - symbol_for_global : Ident.t -> Symbol.t; slot_offsets : Slot_offsets.t; - regions_closed_early : Ident.Set.t + regions_closed_early : Ident.Set.t; + closure_infos : closure_info list } let cost_metrics t = t.cost_metrics @@ -403,18 +344,72 @@ module Acc = struct let with_seen_a_function t seen_a_function = { t with seen_a_function } - let create ~symbol_for_global ~slot_offsets = + let approximation_loader loader = + let externals = ref Symbol.Map.empty in + fun symbol -> + match Symbol.Map.find symbol !externals with + | approx -> approx + | exception Not_found -> + let approx = Flambda_cmx.load_symbol_approx loader symbol in + (if Flambda_features.check_invariants () + then + match approx with + | Value_symbol sym -> + Misc.fatal_errorf + "Closure_conversion: approximation loader returned a Symbol \ + approximation (%a) for symbol %a" + Symbol.print sym Symbol.print symbol + | Value_unknown | Value_int _ | Closure_approximation _ + | Block_approximation _ -> + ()); + let rec filter_inlinable approx = + match (approx : Env.value_approximation) with + | Value_unknown | Value_symbol _ | Value_int _ -> approx + | Block_approximation (approxs, alloc_mode) -> + let approxs = Array.map filter_inlinable approxs in + Value_approximation.Block_approximation (approxs, alloc_mode) + | Closure_approximation { code_id; function_slot; code; _ } -> ( + let metadata = Code_or_metadata.code_metadata code in + if not (Code_or_metadata.code_present code) + then approx + else + match + Inlining.definition_inlining_decision + (Code_metadata.inline metadata) + (Code_metadata.cost_metrics metadata) + with + | Attribute_inline | Small_function _ -> approx + | Not_yet_decided | Never_inline_attribute | Stub | Recursive + | Function_body_too_large _ | Speculatively_inlinable _ + | Functor _ -> + Value_approximation.Closure_approximation + { code_id; + function_slot; + code = Code_or_metadata.create_metadata_only metadata; + symbol = None + }) + in + let approx = filter_inlinable approx in + externals := Symbol.Map.add symbol approx !externals; + approx + + let create ~slot_offsets ~cmx_loader = { declared_symbols = []; lifted_sets_of_closures = []; shareable_constants = Static_const.Map.empty; + symbol_approximations = Symbol.Map.empty; + approximation_for_external_symbol = + (if Flambda_features.classic_mode () + then approximation_loader cmx_loader + else fun _symbol -> Value_approximation.Value_unknown); code = Code_id.Map.empty; free_names = Name_occurrences.empty; continuation_applications = Continuation.Map.empty; cost_metrics = Cost_metrics.zero; seen_a_function = false; - symbol_for_global; slot_offsets; - regions_closed_early = Ident.Set.empty + regions_closed_early = Ident.Set.empty; + closure_infos = [] } let declared_symbols t = t.declared_symbols @@ -445,21 +440,66 @@ module Acc = struct in { t with shareable_constants } + let add_symbol_approximation t symbol approx = + if Value_approximation.is_unknown approx + then t + else + { t with + symbol_approximations = + Symbol.Map.add symbol approx t.symbol_approximations + } + + let find_symbol_approximation t symbol = + try Symbol.Map.find symbol t.symbol_approximations + with Not_found -> t.approximation_for_external_symbol symbol + let add_code ~code_id ~code t = { t with code = Code_id.Map.add code_id code t.code } let add_free_names free_names t = { t with free_names = Name_occurrences.union free_names t.free_names } - let add_name_to_free_names ~name t = + let add_free_names_and_check_my_closure_use free_names t = + let t = + match t.closure_infos with + | [] -> t + | closure_info :: closure_infos -> + if closure_info.is_purely_tailrec + && Name_occurrences.mem_var free_names closure_info.my_closure + then + { t with + closure_infos = + { closure_info with is_purely_tailrec = false } :: closure_infos + } + else t + in + add_free_names free_names t + + let add_name_to_free_names ~is_tail_call ~name t = + let closure_infos = + match is_tail_call, t.closure_infos with + | true, closure_infos -> closure_infos + | false, [] -> [] + | false, closure_info :: closure_infos -> + if closure_info.is_purely_tailrec + && Name.equal (Name.var closure_info.my_closure) name + then { closure_info with is_purely_tailrec = false } :: closure_infos + else t.closure_infos + in { t with + closure_infos; free_names = Name_occurrences.add_name t.free_names name Name_mode.normal } - let add_simple_to_free_names acc simple = + let add_simple_to_free_names_maybe_tail_call ~is_tail_call acc simple = Simple.pattern_match simple ~const:(fun _ -> acc) - ~name:(fun name ~coercion:_ -> add_name_to_free_names ~name acc) + ~name:(fun name ~coercion -> + let acc = add_name_to_free_names ~is_tail_call ~name acc in + add_free_names (Coercion.free_names coercion) acc) + + let add_simple_to_free_names acc simple = + add_simple_to_free_names_maybe_tail_call ~is_tail_call:false acc simple let remove_code_id_or_symbol_from_free_names code_id_or_symbol t = { t with @@ -530,14 +570,42 @@ module Acc = struct let cost_metrics = cost_metrics acc in cost_metrics, free_names, with_cost_metrics saved_cost_metrics acc, return - let symbol_for_global t = t.symbol_for_global - let add_set_of_closures_offsets ~is_phantom t set_of_closures = let slot_offsets = Slot_offsets.add_set_of_closures t.slot_offsets ~is_phantom set_of_closures in { t with slot_offsets } + + let top_closure_info t = + match t.closure_infos with + | [] -> None + | closure_info :: _ -> Some closure_info + + let push_closure_info t ~return_continuation ~exn_continuation ~my_closure + ~is_purely_tailrec = + { t with + closure_infos = + { return_continuation; exn_continuation; my_closure; is_purely_tailrec } + :: t.closure_infos + } + + let pop_closure_info t = + let closure_info, closure_infos = + match t.closure_infos with + | [] -> Misc.fatal_error "pop_closure_info called on empty stack" + | closure_info :: closure_infos -> closure_info, closure_infos + in + let closure_infos = + match closure_infos with + | [] -> [] + | closure_info2 :: closure_infos2 -> + if closure_info2.is_purely_tailrec + && Name_occurrences.mem_var t.free_names closure_info2.my_closure + then { closure_info2 with is_purely_tailrec = false } :: closure_infos2 + else closure_infos + in + closure_info, { t with closure_infos } end module Function_decls = struct @@ -555,7 +623,6 @@ module Function_decls = struct free_idents_of_body : Ident.Set.t; attr : Lambda.function_attribute; loc : Lambda.scoped_location; - stub : bool; recursive : Recursive.t; closure_alloc_mode : Lambda.alloc_mode; num_trailing_local_params : int; @@ -563,9 +630,10 @@ module Function_decls = struct } let create ~let_rec_ident ~function_slot ~kind ~params ~return - ~return_continuation ~exn_continuation ~my_region ~body ~attr ~loc - ~free_idents_of_body ~stub recursive ~closure_alloc_mode - ~num_trailing_local_params ~contains_no_escaping_local_allocs = + ~return_continuation ~exn_continuation ~my_region ~body + ~(attr : Lambda.function_attribute) ~loc ~free_idents_of_body recursive + ~closure_alloc_mode ~num_trailing_local_params + ~contains_no_escaping_local_allocs = let let_rec_ident = match let_rec_ident with | None -> Ident.create_local "unnamed_function" @@ -583,7 +651,6 @@ module Function_decls = struct free_idents_of_body; attr; loc; - stub; recursive; closure_alloc_mode; num_trailing_local_params; @@ -614,6 +681,10 @@ module Function_decls = struct let specialise t = t.attr.specialise + let poll_attribute t = t.attr.poll + + let loop t = t.attr.loop + let is_a_functor t = t.attr.is_a_functor let check_attribute t = t.attr.check @@ -707,7 +778,40 @@ module Expr_with_acc = struct (Code_size.apply apply |> Cost_metrics.from_size) acc in - let acc = Acc.add_free_names (Apply_expr.free_names apply) acc in + let is_tail_call = + match Acc.top_closure_info acc with + | None -> false + | Some { return_continuation; exn_continuation; _ } -> ( + (match Apply_expr.continuation apply with + | Never_returns -> true + | Return cont -> Continuation.equal cont return_continuation) + && Exn_continuation.equal + (Apply_expr.exn_continuation apply) + exn_continuation + (* If the return and exn continuation match, the call is in tail + position, but could still be an under- or over-application. By + checking that it is a direct call, we are sure it has the correct + arity. *) + && + match Apply.call_kind apply with + | Function { function_call = Direct _; _ } -> true + | Function + { function_call = Indirect_unknown_arity | Indirect_known_arity _; + _ + } -> + false + | Method _ -> false + | C_call _ -> false) + in + let acc = + Acc.add_simple_to_free_names_maybe_tail_call ~is_tail_call acc + (Apply.callee apply) + in + let acc = + Acc.add_free_names_and_check_my_closure_use + (Apply_expr.free_names_except_callee apply) + acc + in let acc = match Apply_expr.continuation apply with | Never_returns -> acc @@ -740,7 +844,11 @@ module Apply_cont_with_acc = struct let create acc ?trap_action ?args_approx cont ~args ~dbg = let apply_cont = Apply_cont.create ?trap_action cont ~args ~dbg in let acc = Acc.add_continuation_application ~cont args_approx acc in - let acc = Acc.add_free_names (Apply_cont.free_names apply_cont) acc in + let acc = + Acc.add_free_names_and_check_my_closure_use + (Apply_cont.free_names apply_cont) + acc + in acc, apply_cont let goto acc cont = @@ -795,7 +903,18 @@ module Let_with_acc = struct ~code_id:(fun acc cid -> Acc.remove_code_id_from_free_names cid acc) in let let_expr = Let.create let_bound named ~body ~free_names_of_body in - let acc = Acc.add_free_names (Named.free_names named) acc in + let is_project_value_slot = + match[@ocaml.warning "-4"] (named : Named.t) with + | Prim (Unary (Project_value_slot _, _), _) -> true + | _ -> false + in + let acc = + if is_project_value_slot + then Acc.add_free_names (Named.free_names named) acc + else + Acc.add_free_names_and_check_my_closure_use (Named.free_names named) + acc + in acc, Expr.create_let let_expr end @@ -867,7 +986,8 @@ module Let_cont_with_acc = struct let body_free_names, acc, body = Acc.eval_branch_free_names acc ~f:body in let acc = Acc.with_free_names - (Name_occurrences.union body_free_names handlers_free_names) + (Name_occurrences.union body_free_names + (Name_occurrences.increase_counts handlers_free_names)) acc in create_recursive acc handlers ~body ~cost_metrics_of_handlers diff --git a/middle_end/flambda2/from_lambda/closure_conversion_aux.mli b/middle_end/flambda2/from_lambda/closure_conversion_aux.mli index 93bbf3fea7e..cbd66cc45d5 100644 --- a/middle_end/flambda2/from_lambda/closure_conversion_aux.mli +++ b/middle_end/flambda2/from_lambda/closure_conversion_aux.mli @@ -37,7 +37,7 @@ module IR : sig type named = | Simple of simple | Get_tag of Ident.t (* Intermediary primitive for block switch *) - | Begin_region + | Begin_region of { try_region_parent : Ident.t option } | End_region of Ident.t (** [Begin_region] and [End_region] are needed because these primitives don't exist in Lambda *) @@ -100,61 +100,66 @@ module Env : sig type t - val create : - symbol_for_global:(Ident.t -> Symbol.t) -> - big_endian:bool -> - cmx_loader:Flambda_cmx.loader -> - t + val create : big_endian:bool -> t val clear_local_bindings : t -> t - val add_var : t -> Ident.t -> Variable.t -> t + val add_var : t -> Ident.t -> Variable.t -> Flambda_kind.With_subkind.t -> t - val add_vars : t -> Ident.t list -> Variable.t list -> t + val add_vars : + t -> Ident.t list -> (Variable.t * Flambda_kind.With_subkind.t) list -> t - val add_var_map : t -> Variable.t Ident.Map.t -> t + val add_var_map : + t -> (Variable.t * Flambda_kind.With_subkind.t) Ident.Map.t -> t - val add_var_like : t -> Ident.t -> IR.user_visible -> t * Variable.t + val add_var_like : + t -> + Ident.t -> + IR.user_visible -> + Flambda_kind.With_subkind.t -> + t * Variable.t val add_vars_like : - t -> (Ident.t * IR.user_visible) list -> t * Variable.t list + t -> + (Ident.t * IR.user_visible * Flambda_kind.With_subkind.t) list -> + t * Variable.t list val find_name : t -> Ident.t -> Name.t val find_name_exn : t -> Ident.t -> Name.t - val find_var : t -> Ident.t -> Variable.t + val find_var : t -> Ident.t -> Variable.t * Flambda_kind.With_subkind.t - val find_var_exn : t -> Ident.t -> Variable.t + val find_var_exn : t -> Ident.t -> Variable.t * Flambda_kind.With_subkind.t - val find_vars : t -> Ident.t list -> Variable.t list + val find_vars : + t -> Ident.t list -> (Variable.t * Flambda_kind.With_subkind.t) list val add_global : t -> int -> Symbol.t -> t val find_global : t -> int -> Symbol.t - val add_simple_to_substitute : t -> Ident.t -> Simple.t -> t + val add_simple_to_substitute : + t -> Ident.t -> Simple.t -> Flambda_kind.With_subkind.t -> t - val add_simple_to_substitute_map : t -> Simple.t Ident.Map.t -> t + val add_simple_to_substitute_map : + t -> (Simple.t * Flambda_kind.With_subkind.t) Ident.Map.t -> t - val find_simple_to_substitute_exn : t -> Ident.t -> Simple.t + val find_simple_to_substitute_exn : + t -> Ident.t -> Simple.t * Flambda_kind.With_subkind.t - val add_value_approximation : t -> Name.t -> value_approximation -> t + val add_var_approximation : t -> Variable.t -> value_approximation -> t val add_block_approximation : - t -> Name.t -> value_approximation array -> Alloc_mode.For_types.t -> t - - val add_approximation_alias : t -> Name.t -> Name.t -> t + t -> Variable.t -> value_approximation array -> Alloc_mode.For_types.t -> t - val find_value_approximation : t -> Simple.t -> value_approximation + val find_var_approximation : t -> Variable.t -> value_approximation val current_depth : t -> Variable.t option val with_depth : t -> Variable.t -> t - val current_unit_id : t -> Ident.t - - val symbol_for_global : t -> Ident.t -> Symbol.t + val current_unit : t -> Compilation_unit.t val big_endian : t -> bool @@ -179,10 +184,16 @@ end (** Used to pipe some data through closure conversion *) module Acc : sig + type closure_info = private + { return_continuation : Continuation.t; + exn_continuation : Exn_continuation.t; + my_closure : Variable.t; + is_purely_tailrec : bool + } + type t - val create : - symbol_for_global:(Ident.t -> Symbol.t) -> slot_offsets:Slot_offsets.t -> t + val create : slot_offsets:Slot_offsets.t -> cmx_loader:Flambda_cmx.loader -> t val declared_symbols : t -> (Symbol.t * Static_const.t) list @@ -246,12 +257,26 @@ module Acc : sig val measure_cost_metrics : t -> f:(t -> t * 'a) -> Cost_metrics.t * Name_occurrences.t * t * 'a - val symbol_for_global : t -> Ident.t -> Symbol.t - val slot_offsets : t -> Slot_offsets.t val add_set_of_closures_offsets : is_phantom:bool -> t -> Set_of_closures.t -> t + + val top_closure_info : t -> closure_info option + + val push_closure_info : + t -> + return_continuation:Continuation.t -> + exn_continuation:Exn_continuation.t -> + my_closure:Variable.t -> + is_purely_tailrec:bool -> + t + + val pop_closure_info : t -> closure_info * t + + val add_symbol_approximation : t -> Symbol.t -> Env.value_approximation -> t + + val find_symbol_approximation : t -> Symbol.t -> Env.value_approximation end (** Used to represent information about a set of function declarations during @@ -274,7 +299,6 @@ module Function_decls : sig attr:Lambda.function_attribute -> loc:Lambda.scoped_location -> free_idents_of_body:Ident.Set.t -> - stub:bool -> Recursive.t -> closure_alloc_mode:Lambda.alloc_mode -> num_trailing_local_params:int -> @@ -303,6 +327,10 @@ module Function_decls : sig val specialise : t -> Lambda.specialise_attribute + val poll_attribute : t -> Lambda.poll_attribute + + val loop : t -> Lambda.loop_attribute + val is_a_functor : t -> bool val check_attribute : t -> Lambda.check_attribute diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml index 54d4ec098ca..451d1e9aa04 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.ml @@ -30,13 +30,13 @@ module Env : sig type region_stack_element val create : - current_unit_id:Ident.t -> + current_unit:Compilation_unit.t -> return_continuation:Continuation.t -> exn_continuation:Continuation.t -> my_region:Ident.t -> t - val current_unit_id : t -> Ident.t + val current_unit : t -> Compilation_unit.t val is_mutable : t -> Ident.t -> bool @@ -78,6 +78,9 @@ module Env : sig val get_mutable_variable : t -> Ident.t -> Ident.t + val get_mutable_variable_with_kind : + t -> Ident.t -> Ident.t * Lambda.value_kind + (** About local allocation regions: In this pass, we have to transform [Lregion] expressions in Lambda to @@ -138,6 +141,8 @@ module Env : sig val current_region : t -> Ident.t + val my_region : t -> Ident.t + (** The innermost (newest) region is first in the list. *) val region_stack : t -> region_stack_element list @@ -168,7 +173,7 @@ end = struct | Try_with of Ident.t type t = - { current_unit_id : Ident.t; + { current_unit : Compilation_unit.t; current_values_of_mutables_in_scope : (Ident.t * Lambda.value_kind) Ident.Map.t; mutables_needed_by_continuations : Ident.Set.t Continuation.Map.t; @@ -182,13 +187,12 @@ end = struct region_closure_continuations : region_closure_continuation Ident.Map.t } - let create ~current_unit_id ~return_continuation ~exn_continuation ~my_region - = + let create ~current_unit ~return_continuation ~exn_continuation ~my_region = let mutables_needed_by_continuations = Continuation.Map.of_list [return_continuation, Ident.Set.empty; exn_continuation, Ident.Set.empty] in - { current_unit_id; + { current_unit; current_values_of_mutables_in_scope = Ident.Map.empty; mutables_needed_by_continuations; try_stack = []; @@ -202,7 +206,7 @@ end = struct region_closure_continuations = Ident.Map.empty } - let current_unit_id t = t.current_unit_id + let current_unit t = t.current_unit let is_mutable t id = Ident.Map.mem id t.current_values_of_mutables_in_scope @@ -344,11 +348,13 @@ end = struct let extra_args_for_continuation t cont = List.map fst (extra_args_for_continuation_with_kinds t cont) - let get_mutable_variable t id = + let get_mutable_variable_with_kind t id = match Ident.Map.find id t.current_values_of_mutables_in_scope with | exception Not_found -> Misc.fatal_errorf "Mutable variable %a not bound in env" Ident.print id - | id, _kind -> id + | id, kind -> id, kind + + let get_mutable_variable t id = fst (get_mutable_variable_with_kind t id) let entering_region t id ~continuation_closing_region ~continuation_after_closing_region = @@ -380,6 +386,8 @@ end = struct | [] -> t.my_region | (Regular region | Try_with region) :: _ -> region + let my_region t = t.my_region + let region_stack t = t.region_stack let region_stack_in_cont_scope t continuation = @@ -529,7 +537,8 @@ let compile_staticfail acc env ccenv ~(continuation : Continuation.t) ~args : fun acc ccenv -> CC.close_let acc ccenv (Ident.create_local "unit") - Not_user_visible (End_region region) ~body + Not_user_visible Flambda_kind.With_subkind.tagged_immediate + (End_region region) ~body in let no_end_region after_everything = after_everything in match @@ -600,29 +609,13 @@ let transform_primitive env (prim : L.primitive) args loc = ~ifnot:(L.Lvar const_false) ~kind:Pintval ) )) | (Psequand | Psequor), _ -> Misc.fatal_error "Psequand / Psequor must have exactly two arguments" - | (Pidentity | Pbytes_to_string | Pbytes_of_string), [arg] -> Transformed arg + | (Pbytes_to_string | Pbytes_of_string), [arg] -> Transformed arg | Pignore, [arg] -> let ident = Ident.create_local "ignore" in let result = L.Lconst (Const_base (Const_int 0)) in Transformed (L.Llet (Strict, Pgenval, ident, arg, result)) - | Pdirapply pos, [funct; arg] | Prevapply pos, [arg; funct] -> - let apply : L.lambda_apply = - { ap_func = funct; - ap_args = [arg]; - ap_region_close = pos; - ap_mode = Lambda.alloc_heap; - ap_loc = loc; - ap_tailcall = Default_tailcall; - (* CR-someday lwhite: it would be nice to be able to give inlined - attributes to functions applied with the application operators. *) - ap_inlined = Default_inlined; - ap_specialised = Default_specialise; - ap_probe = None - } - in - Transformed (L.Lapply apply) - | Pfield _, [L.Lprim (Pgetglobal id, [], _)] - when Ident.same id (Env.current_unit_id env) -> + | Pfield _, [L.Lprim (Pgetglobal cu, [], _)] + when Compilation_unit.equal cu (Env.current_unit env) -> Misc.fatal_error "[Pfield (Pgetglobal ...)] for the current compilation unit is forbidden \ upon entry to the middle end" @@ -783,12 +776,12 @@ let restore_continuation_context acc env ccenv cont ~close_early body = | Some region -> (* If we need to close regions early then do it now; otherwise redirect the return continuation to the one closing such regions, if any exist. See - comment in [cps_non_tail] on the [Lregion] case. *) + comment in [cps] on the [Lregion] case. *) if close_early then CC.close_let acc ccenv (Ident.create_local "unit") - Not_user_visible (End_region region) ~body:(fun acc ccenv -> - body acc ccenv cont) + Not_user_visible Flambda_kind.With_subkind.tagged_immediate + (End_region region) ~body:(fun acc ccenv -> body acc ccenv cont) else let ({ continuation_closing_region; continuation_after_closing_region } : Env.region_closure_continuation) = @@ -803,6 +796,23 @@ let restore_continuation_context acc env ccenv cont ~close_early body = Continuation.print cont; body acc ccenv continuation_closing_region +let restore_continuation_context_for_switch_arm env cont = + match Env.pop_regions_up_to_context env cont with + | None -> cont + | Some region -> + let ({ continuation_closing_region; continuation_after_closing_region } + : Env.region_closure_continuation) = + Env.region_closure_continuation env region + in + if not (Continuation.equal cont continuation_after_closing_region) + then + Misc.fatal_errorf + "The continuation %a following the region closure should be the \ + current continuation %a" + Continuation.print continuation_after_closing_region Continuation.print + cont; + continuation_closing_region + let apply_cont_with_extra_args acc env ccenv ~dbg cont traps args = let extra_args = List.map @@ -815,9 +825,14 @@ let apply_cont_with_extra_args acc env ccenv ~dbg cont traps args = let wrap_return_continuation acc env ccenv (apply : IR.apply) = let extra_args = Env.extra_args_for_continuation env apply.continuation in + let close_early, region = + match apply.region_close with + | Rc_normal | Rc_nontail -> false, apply.region + | Rc_close_at_apply -> true, Env.my_region env + in let body acc ccenv continuation = match extra_args with - | [] -> CC.close_apply acc ccenv { apply with continuation } + | [] -> CC.close_apply acc ccenv { apply with continuation; region } | _ :: _ -> let wrapper_cont = Continuation.create () in let return_value = Ident.create_local "return_val" in @@ -829,17 +844,13 @@ let wrap_return_continuation acc env ccenv (apply : IR.apply) = CC.close_apply_cont acc ccenv ~dbg continuation None args in let body acc ccenv = - CC.close_apply acc ccenv { apply with continuation = wrapper_cont } + CC.close_apply acc ccenv + { apply with continuation = wrapper_cont; region } in CC.close_let_cont acc ccenv ~name:wrapper_cont ~is_exn_handler:false ~params:[return_value, Not_user_visible, Pgenval] ~recursive:Nonrecursive ~body ~handler in - let close_early = - match apply.region_close with - | Rc_normal | Rc_nontail -> false - | Rc_close_at_apply -> true - in restore_continuation_context acc env ccenv apply.continuation ~close_early body @@ -873,19 +884,18 @@ let primitive_can_raise (prim : Lambda.primitive) = | Pbigarrayref (_, _, _, Pbigarray_unknown_layout) | Pbigarrayset (_, _, _, Pbigarray_unknown_layout) -> true - | Pidentity | Pbytes_to_string | Pbytes_of_string | Pignore | Prevapply _ - | Pdirapply _ | Pgetglobal _ | Psetglobal _ | Pmakeblock _ | Pmakefloatblock _ - | Pfield _ | Pfield_computed _ | Psetfield _ | Psetfield_computed _ - | Pfloatfield _ | Psetfloatfield _ | Pduprecord _ | Psequand | Psequor | Pnot - | Pnegint | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint - | Plsrint | Pasrint | Pintcomp _ | Pcompare_ints | Pcompare_floats - | Pcompare_bints _ | Poffsetint _ | Poffsetref _ | Pintoffloat | Pfloatofint _ - | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ | Pmulfloat _ - | Pdivfloat _ | Pfloatcomp _ | Pstringlength | Pstringrefu | Pbyteslength - | Pbytesrefu | Pbytessetu | Pmakearray _ | Pduparray _ | Parraylength _ - | Parrayrefu _ | Parraysetu _ | Pisint _ | Pisout | Pbintofint _ - | Pintofbint _ | Pcvtbint _ | Pnegbint _ | Paddbint _ | Psubbint _ - | Pmulbint _ + | Pbytes_to_string | Pbytes_of_string | Pignore | Pgetglobal _ | Psetglobal _ + | Pgetpredef _ | Pmakeblock _ | Pmakefloatblock _ | Pfield _ + | Pfield_computed _ | Psetfield _ | Psetfield_computed _ | Pfloatfield _ + | Psetfloatfield _ | Pduprecord _ | Psequand | Psequor | Pnot | Pnegint + | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint | Plsrint + | Pasrint | Pintcomp _ | Pcompare_ints | Pcompare_floats | Pcompare_bints _ + | Poffsetint _ | Poffsetref _ | Pintoffloat | Pfloatofint _ | Pnegfloat _ + | Pabsfloat _ | Paddfloat _ | Psubfloat _ | Pmulfloat _ | Pdivfloat _ + | Pfloatcomp _ | Pstringlength | Pstringrefu | Pbyteslength | Pbytesrefu + | Pbytessetu | Pmakearray _ | Pduparray _ | Parraylength _ | Parrayrefu _ + | Parraysetu _ | Pisint _ | Pisout | Pbintofint _ | Pintofbint _ | Pcvtbint _ + | Pnegbint _ | Paddbint _ | Psubbint _ | Pmulbint _ | Pdivbint { is_safe = Unsafe; _ } | Pmodbint { is_safe = Unsafe; _ } | Pandbint _ | Porbint _ | Pxorbint _ | Plslbint _ | Plsrbint _ | Pasrbint _ @@ -925,6 +935,82 @@ let primitive_can_raise (prim : Lambda.primitive) = | Pprobe_is_enabled _ | Pobj_dup | Pobj_magic -> false +let primitive_result_kind (prim : Lambda.primitive) : + Flambda_kind.With_subkind.t = + match prim with + | Pccall { prim_native_repr_res = _, Untagged_int; _ } -> + Flambda_kind.With_subkind.tagged_immediate + | Pccall { prim_native_repr_res = _, Unboxed_float; _ } + | Pfloatofint _ | Pnegfloat _ | Pabsfloat _ | Paddfloat _ | Psubfloat _ + | Pmulfloat _ | Pdivfloat _ | Pfloatfield _ + | Parrayrefs Pfloatarray + | Parrayrefu Pfloatarray + | Pbigarrayref (_, _, (Pbigarray_float32 | Pbigarray_float64), _) -> + Flambda_kind.With_subkind.boxed_float + | Pccall { prim_native_repr_res = _, Unboxed_integer Pnativeint; _ } + | Pbigarrayref (_, _, Pbigarray_native_int, _) -> + Flambda_kind.With_subkind.boxed_nativeint + | Pccall { prim_native_repr_res = _, Unboxed_integer Pint32; _ } + | Pstring_load_32 _ | Pbytes_load_32 _ | Pbigstring_load_32 _ + | Pbigarrayref (_, _, Pbigarray_int32, _) -> + Flambda_kind.With_subkind.boxed_int32 + | Pccall { prim_native_repr_res = _, Unboxed_integer Pint64; _ } + | Pstring_load_64 _ | Pbytes_load_64 _ | Pbigstring_load_64 _ + | Pbigarrayref (_, _, Pbigarray_int64, _) -> + Flambda_kind.With_subkind.boxed_int64 + | Pnegint | Paddint | Psubint | Pmulint | Pandint | Porint | Pxorint | Plslint + | Plsrint | Pasrint | Pmodint _ | Pdivint _ | Pignore | Psequand | Psequor + | Pnot | Pbytesrefs | Pstringrefs | Pbytessets | Pstring_load_16 _ + | Pbytes_load_16 _ | Pbigstring_load_16 _ | Pbytes_set_16 _ | Pbytes_set_32 _ + | Pbytes_set_64 _ | Pbigstring_set_16 _ | Pbigstring_set_32 _ + | Pbigstring_set_64 _ | Pintcomp _ | Pcompare_ints | Pcompare_floats + | Pcompare_bints _ | Pintoffloat | Pfloatcomp _ | Parraysets _ + | Pbigarrayset _ | Psetfield _ | Psetfield_computed _ | Psetfloatfield _ + | Pstringlength | Pstringrefu | Pbyteslength | Pbytesrefu | Pbytessetu + | Parraylength _ | Parraysetu _ | Pisint _ | Pbintcomp _ | Pintofbint _ + | Pisout + | Parrayrefs Pintarray + | Parrayrefu Pintarray + | Pprobe_is_enabled _ | Pctconst _ | Pbswap16 + | Pbigarrayref + ( _, + _, + ( Pbigarray_sint8 | Pbigarray_uint8 | Pbigarray_sint16 + | Pbigarray_uint16 | Pbigarray_caml_int ), + _ ) -> + Flambda_kind.With_subkind.tagged_immediate + | Pdivbint { size = bi; _ } + | Pmodbint { size = bi; _ } + | Pandbint (bi, _) + | Porbint (bi, _) + | Pxorbint (bi, _) + | Plslbint (bi, _) + | Plsrbint (bi, _) + | Pasrbint (bi, _) + | Pnegbint (bi, _) + | Paddbint (bi, _) + | Psubbint (bi, _) + | Pmulbint (bi, _) + | Pbintofint (bi, _) + | Pcvtbint (_, bi, _) + | Pbbswap (bi, _) -> ( + match bi with + | Pint32 -> Flambda_kind.With_subkind.boxed_int32 + | Pint64 -> Flambda_kind.With_subkind.boxed_int64 + | Pnativeint -> Flambda_kind.With_subkind.boxed_nativeint) + | Pccall { prim_native_repr_res = _, Same_as_ocaml_repr; _ } + | Praise _ + | Parrayrefs (Pgenarray | Paddrarray) + | Parrayrefu (Pgenarray | Paddrarray) + | Pbytes_to_string | Pbytes_of_string | Pgetglobal _ | Psetglobal _ + | Pgetpredef _ | Pmakeblock _ | Pmakefloatblock _ | Pfield _ + | Pfield_computed _ | Pduprecord _ | Poffsetint _ | Poffsetref _ + | Pmakearray _ | Pduparray _ | Pbigarraydim _ + | Pbigarrayref + (_, _, (Pbigarray_complex32 | Pbigarray_complex64 | Pbigarray_unknown), _) + | Pint_as_pointer | Popaque | Pobj_dup | Pobj_magic -> + Flambda_kind.With_subkind.any_value + type cps_continuation = | Tail of Continuation.t | Non_tail of (Acc.t -> Env.t -> CCenv.t -> IR.simple -> Expr_with_acc.t) @@ -947,12 +1033,12 @@ let maybe_insert_let_cont result_var_name kind k acc env ccenv body = ~handler:(fun acc env ccenv -> k acc env ccenv (IR.Var result_var)) ~body -let name_if_not_var acc ccenv name simple body = +let name_if_not_var acc ccenv name simple kind body = match simple with | IR.Var id -> body id acc ccenv | IR.Const _ -> let id = Ident.create_local name in - CC.close_let acc ccenv id Not_user_visible (IR.Simple simple) + CC.close_let acc ccenv id Not_user_visible kind (IR.Simple simple) ~body:(body id) let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) @@ -976,6 +1062,8 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) ap_specialised = _; ap_probe } -> + (* Note that we don't need kind information about [ap_args] since we already + have it on the corresponding [Simple]s in the environment. *) maybe_insert_let_cont "apply_result" Pgenval k acc env ccenv (fun acc env ccenv k -> cps_tail_apply acc env ccenv ap_func ap_args ap_region_close ap_mode @@ -984,9 +1072,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let id = Ident.create_local (name_for_function func) in let dbg = Debuginfo.from_location func.loc in let func = - cps_function env ~fid:id ~stub:false - ~recursive:(Non_recursive : Recursive.t) - func + cps_function env ~fid:id ~recursive:(Non_recursive : Recursive.t) func in let body acc ccenv = apply_cps_cont k ~dbg acc env ccenv id in CC.close_let_rec acc ccenv ~function_declarations:[func] ~body @@ -1000,7 +1086,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) ~handler:(fun acc env ccenv -> let env, new_id = Env.register_mutable_variable env id value_kind in let body acc ccenv = cps acc env ccenv body k k_exn in - CC.close_let acc ccenv new_id User_visible (Simple (Var temp_id)) ~body) + CC.close_let acc ccenv new_id User_visible + (Flambda_kind.With_subkind.from_lambda value_kind) + (Simple (Var temp_id)) ~body) | Llet ((Strict | Alias | StrictOpt), Pgenval, fun_id, Lfunction func, body) -> (* This case is here to get function names right. *) @@ -1016,14 +1104,16 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let_expr acc ccenv | Llet ( (Strict | Alias | StrictOpt), - ( Pgenval | Pfloatval | Pboxedintval _ | Pintval | Pvariant _ - | Parrayval _ ), + (( Pgenval | Pfloatval | Pboxedintval _ | Pintval | Pvariant _ + | Parrayval _ ) as value_kind), id, Lconst const, body ) -> (* This case avoids extraneous continuations. *) let body acc ccenv = cps acc env ccenv body k k_exn in - CC.close_let acc ccenv id User_visible (Simple (Const const)) ~body + CC.close_let acc ccenv id User_visible + (Flambda_kind.With_subkind.from_lambda value_kind) + (Simple (Const const)) ~body | Llet ( ((Strict | Alias | StrictOpt) as let_kind), (( Pgenval | Pfloatval | Pboxedintval _ | Pintval | Pvariant _ @@ -1048,6 +1138,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let body acc ccenv = cps acc env ccenv body k k_exn in let region = Env.current_region env in CC.close_let acc ccenv id User_visible + (Flambda_kind.With_subkind.from_lambda value_kind) (Prim { prim; args; loc; exn_continuation; region }) ~body) k_exn @@ -1072,9 +1163,15 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let body acc ccenv = let body acc ccenv = cps acc env ccenv body k k_exn in CC.close_let acc ccenv id Not_user_visible + Flambda_kind.With_subkind.tagged_immediate (Simple (Const L.const_unit)) ~body in - CC.close_let acc ccenv new_id User_visible (Simple new_value) ~body) + let value_kind = + snd (Env.get_mutable_variable_with_kind env being_assigned) + in + CC.close_let acc ccenv new_id User_visible + (Flambda_kind.With_subkind.from_lambda value_kind) + (Simple new_value) ~body) k_exn | Llet ( (Strict | Alias | StrictOpt), @@ -1093,7 +1190,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) value_kind. *) (* let k acc env ccenv value = * let body acc ccenv = cps acc env ccenv body k k_exn in - * CC.close_let acc ccenv id User_visible (Simple value) ~body + * CC.close_let acc ccenv id User_visible value_kind (Simple value) ~body * in * cps_non_tail_simple acc env ccenv defining_expr k k_exn *) | Lletrec (bindings, body) -> ( @@ -1124,6 +1221,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) (fun acc env ccenv args -> let body acc ccenv = apply_cps_cont ~dbg k acc env ccenv result_var in CC.close_let acc ccenv result_var Not_user_visible + (primitive_result_kind prim) (Prim { prim; args; loc; exn_continuation; region = current_region }) ~body) k_exn @@ -1177,6 +1275,7 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) cps_non_tail_simple acc env ccenv obj (fun acc env ccenv obj -> cps_non_tail_var "meth" acc env ccenv meth + Flambda_kind.With_subkind.any_value (fun acc env ccenv meth -> cps_non_tail_list acc env ccenv args (fun acc env ccenv args -> @@ -1213,12 +1312,18 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) generation pass ensures that there will be an enclosing region around the whole [Ltrywith] (possibly not immediately enclosing, but maybe further out). The only reason we need a [Begin_region] here is to be able to - unwind the local allocation stack if the exception handler is invoked. We - need an [End_region] too so that, on the non-exceptional path at the end - of the [try] block, the local allocation stack is correctly unwound in - the case where the region around the whole [Ltrywith] is unused. (See - [uses_local_try] in regions.ml in the testsuite.) *) - CC.close_let acc ccenv region Not_user_visible Begin_region + unwind the local allocation stack if the exception handler is invoked. + There is no corresponding [End_region] on the non-exceptional path + because there might be a local allocation in the "try" block that needs + to be returned. In effect, such allocations are treated as if they were + in the parent region, although they will be annotated with the region + identifier of the "try region". To handle this correctly we annotate the + [Begin_region] with its parent region. This use of the parent region will + ensure that the parent does not get deleted unless the try region is + unused. *) + CC.close_let acc ccenv region Not_user_visible + Flambda_kind.With_subkind.region + (Begin_region { try_region_parent = Some (Env.current_region env) }) ~body:(fun acc ccenv -> maybe_insert_let_cont "try_with_result" kind k acc env ccenv (fun acc env ccenv k -> @@ -1242,16 +1347,14 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) cps_tail acc env ccenv body poptrap_continuation handler_continuation)) ~handler:(fun acc env ccenv -> - CC.close_let acc ccenv (Ident.create_local "unit") - Not_user_visible (End_region region) - ~body:(fun acc ccenv -> - let env = Env.leaving_try_region env in - apply_cont_with_extra_args acc env ccenv ~dbg k - (Some (IR.Pop { exn_handler = handler_continuation })) - [IR.Var body_result]))) + let env = Env.leaving_try_region env in + apply_cont_with_extra_args acc env ccenv ~dbg k + (Some (IR.Pop { exn_handler = handler_continuation })) + [IR.Var body_result])) ~handler:(fun acc env ccenv -> CC.close_let acc ccenv (Ident.create_local "unit") - Not_user_visible (End_region region) ~body:(fun acc ccenv -> + Not_user_visible Flambda_kind.With_subkind.tagged_immediate + (End_region region) ~body:(fun acc ccenv -> let env = Env.leaving_try_region env in cps_tail acc env ccenv handler k k_exn)))) | Lifthenelse (cond, ifso, ifnot, kind) -> @@ -1287,7 +1390,12 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) let body acc ccenv = apply_cps_cont_simple k acc env ccenv (Const L.const_unit) in - CC.close_let acc ccenv new_id User_visible (Simple new_value) ~body) + let _, value_kind = + Env.get_mutable_variable_with_kind env being_assigned + in + CC.close_let acc ccenv new_id User_visible + (Flambda_kind.With_subkind.from_lambda value_kind) + (Simple new_value) ~body) k_exn | Levent (body, _event) -> cps acc env ccenv body k k_exn | Lifused _ -> @@ -1305,7 +1413,9 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) continuation for the code after the body. *) let region = Ident.create_local "region" in let dbg = Debuginfo.none in - CC.close_let acc ccenv region Not_user_visible Begin_region + CC.close_let acc ccenv region Not_user_visible + Flambda_kind.With_subkind.region + (Begin_region { try_region_parent = None }) ~body:(fun acc ccenv -> maybe_insert_let_cont "body_return" Pgenval k acc env ccenv (fun acc env ccenv k -> @@ -1341,7 +1451,8 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) cps_tail acc env ccenv body k k_exn) ~handler:(fun acc env ccenv -> CC.close_let acc ccenv (Ident.create_local "unit") - Not_user_visible (End_region region) ~body:(fun acc ccenv -> + Not_user_visible Flambda_kind.With_subkind.tagged_immediate + (End_region region) ~body:(fun acc ccenv -> (* Both body and handler will continue at [return_continuation] by default. [restore_region_context] will intercept the @@ -1352,10 +1463,10 @@ let rec cps acc env ccenv (lam : L.lambda) (k : cps_continuation) and cps_non_tail_simple acc env ccenv lam k k_exn = cps acc env ccenv lam (Non_tail k) k_exn -and cps_non_tail_var name acc env ccenv lam k k_exn = +and cps_non_tail_var name acc env ccenv lam kind k k_exn = cps_non_tail_simple acc env ccenv lam (fun acc env ccenv simple -> - name_if_not_var acc ccenv name simple (fun var acc ccenv -> + name_if_not_var acc ccenv name simple kind (fun var acc ccenv -> k acc env ccenv var)) k_exn @@ -1365,6 +1476,7 @@ and cps_tail_apply acc env ccenv ap_func ap_args ap_region_close ap_mode ap_loc cps_non_tail_list acc env ccenv ap_args (fun acc env ccenv args -> cps_non_tail_var "func" acc env ccenv ap_func + Flambda_kind.With_subkind.any_value (fun acc env ccenv func -> let exn_continuation : IR.exn_continuation = { exn_handler = k_exn; @@ -1474,35 +1586,15 @@ and cps_function_bindings env (bindings : (Ident.t * L.lambda) list) = then Recursive else Non_recursive in - List.fold_left - (fun bindings binding -> - match binding with - | [(fun_id, def)] -> - let fundef = - cps_function env ~fid:fun_id ~stub:false ~recursive:(recursive fun_id) - ~precomputed_free_idents:(Ident.Map.find fun_id free_idents) - def - in - bindings @ [fundef] - | [(fun_id, def); (inner_id, inner_def)] -> - let fundef = - cps_function env ~fid:fun_id ~stub:false ~recursive:(recursive fun_id) - ~precomputed_free_idents:(Ident.Map.find fun_id free_idents) - def - in - let inner_fundef = - cps_function env ~fid:inner_id ~stub:true - ~recursive:(recursive inner_id) - ~precomputed_free_idents:(Ident.Map.find inner_id free_idents) - inner_def - in - bindings @ [fundef; inner_fundef] - | _ -> assert false - (* checked above *)) - [] bindings_with_wrappers - -and cps_function env ~fid ~stub ~(recursive : Recursive.t) - ?precomputed_free_idents + let bindings_with_wrappers = List.flatten bindings_with_wrappers in + List.map + (fun (fun_id, def) -> + cps_function env ~fid:fun_id ~recursive:(recursive fun_id) + ~precomputed_free_idents:(Ident.Map.find fun_id free_idents) + def) + bindings_with_wrappers + +and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents ({ kind; params; return; body; attr; loc; mode; region } : L.lfunction) : Function_decl.t = let num_trailing_local_params = @@ -1517,7 +1609,7 @@ and cps_function env ~fid ~stub ~(recursive : Recursive.t) in let my_region = Ident.create_local "my_region" in let new_env = - Env.create ~current_unit_id:(Env.current_unit_id env) + Env.create ~current_unit:(Env.current_unit env) ~return_continuation:body_cont ~exn_continuation:body_exn_cont ~my_region in let exn_continuation : IR.exn_continuation = @@ -1534,7 +1626,7 @@ and cps_function env ~fid ~stub ~(recursive : Recursive.t) in Function_decl.create ~let_rec_ident:(Some fid) ~function_slot ~kind ~params ~return ~return_continuation:body_cont ~exn_continuation ~my_region ~body - ~attr ~loc ~free_idents_of_body ~stub recursive ~closure_alloc_mode:mode + ~attr ~loc ~free_idents_of_body recursive ~closure_alloc_mode:mode ~num_trailing_local_params ~contains_no_escaping_local_allocs:region and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg @@ -1574,6 +1666,7 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg (fun arg : IR.simple -> Var arg) (Env.extra_args_for_continuation env k) in + let k = restore_continuation_context_for_switch_arm env k in let consts_rev = (arm, k, None, IR.Var var :: extra_args) :: consts_rev in @@ -1584,6 +1677,7 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg (fun arg : IR.simple -> Var arg) (Env.extra_args_for_continuation env k) in + let k = restore_continuation_context_for_switch_arm env k in let consts_rev = (arm, k, None, IR.Const cst :: extra_args) :: consts_rev in @@ -1604,6 +1698,7 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg ([], wrappers) cases in cps_non_tail_var "scrutinee" acc env ccenv scrutinee + Flambda_kind.With_subkind.any_value (fun acc env ccenv scrutinee -> let consts_rev, wrappers = convert_arms_rev env switch.sw_consts [] in let blocks_rev, wrappers = @@ -1636,7 +1731,7 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg CC.close_switch acc ccenv ~condition_dbg scrutinee_tag block_switch in CC.close_let acc ccenv scrutinee_tag Not_user_visible - (Get_tag scrutinee) ~body + Flambda_kind.With_subkind.naked_immediate (Get_tag scrutinee) ~body in if switch.sw_numblocks = 0 then const_switch, wrappers @@ -1659,6 +1754,7 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg in let region = Env.current_region env in CC.close_let acc ccenv is_scrutinee_int Not_user_visible + Flambda_kind.With_subkind.naked_immediate (Prim { prim = Pisint { variant_only = true }; args = [Var scrutinee]; @@ -1685,22 +1781,18 @@ and cps_switch acc env ccenv (switch : L.lambda_switch) ~condition_dbg (* CR pchambart: define a record `target_config` to hold things like `big_endian` *) -let lambda_to_flambda ~mode ~symbol_for_global ~big_endian ~cmx_loader - ~module_ident ~module_block_size_in_words (lam : Lambda.lambda) = - let current_unit_id = - Compilation_unit.name (Compilation_unit.get_current_exn ()) - |> Compilation_unit.Name.persistent_ident - in +let lambda_to_flambda ~mode ~big_endian ~cmx_loader ~compilation_unit + ~module_block_size_in_words (lam : Lambda.lambda) = let return_continuation = Continuation.create ~sort:Define_root_symbol () in let exn_continuation = Continuation.create () in let toplevel_my_region = Ident.create_local "toplevel_my_region" in let env = - Env.create ~current_unit_id ~return_continuation ~exn_continuation - ~my_region:toplevel_my_region + Env.create ~current_unit:compilation_unit ~return_continuation + ~exn_continuation ~my_region:toplevel_my_region in let toplevel acc ccenv = cps_tail acc env ccenv lam return_continuation exn_continuation in - CC.close_program ~mode ~symbol_for_global ~big_endian ~cmx_loader - ~module_ident ~module_block_size_in_words ~program:toplevel + CC.close_program ~mode ~big_endian ~cmx_loader ~compilation_unit + ~module_block_size_in_words ~program:toplevel ~prog_return_cont:return_continuation ~exn_continuation ~toplevel_my_region diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda.mli b/middle_end/flambda2/from_lambda/lambda_to_flambda.mli index 9b00541befc..4e3924ce7b8 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda.mli +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda.mli @@ -18,10 +18,9 @@ val lambda_to_flambda : mode:'mode Flambda_features.mode -> - symbol_for_global:(Ident.t -> Symbol.t) -> big_endian:bool -> cmx_loader:Flambda_cmx.loader -> - module_ident:Ident.t -> + compilation_unit:Compilation_unit.t -> module_block_size_in_words:int -> Lambda.lambda -> 'mode Closure_conversion.close_program_result diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml index b780609c13d..d4931dc78fa 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml @@ -1197,13 +1197,11 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list) "Closure_conversion.convert_primitive: Wrong arity for ternary primitive \ %a (%a)" Printlambda.primitive prim H.print_list_of_simple_or_prim args - | ( ( Pidentity | Pignore | Prevapply _ | Pdirapply _ | Psequand | Psequor - | Pbytes_of_string | Pbytes_to_string ), - _ ) -> + | (Pignore | Psequand | Psequor | Pbytes_of_string | Pbytes_to_string), _ -> Misc.fatal_errorf "[%a] should have been removed by [Lambda_to_flambda.transform_primitive]" Printlambda.primitive prim - | Pgetglobal _, _ -> + | Pgetglobal _, _ | Pgetpredef _, _ -> Misc.fatal_errorf "[%a] should have been handled by [Closure_conversion.close_primitive]" Printlambda.primitive prim diff --git a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.ml b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.ml index 91d2748e90a..99a0174b323 100644 --- a/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.ml +++ b/middle_end/flambda2/from_lambda/lambda_to_flambda_primitives_helpers.ml @@ -95,6 +95,9 @@ let raise_exn_for_failure acc ~dbg exn_cont exn_bucket extra_let_binding = (Bound_pattern.singleton bound_var) defining_expr ~body:apply_cont +let symbol_for_prim id = + Flambda2_import.Symbol.for_predef_ident id |> Symbol.create_wrapped + let expression_for_failure acc exn_cont ~register_const_string primitive dbg (failure : failure) = let exn_cont = @@ -108,9 +111,7 @@ let expression_for_failure acc exn_cont ~register_const_string primitive dbg in match failure with | Division_by_zero -> - let division_by_zero = - (Acc.symbol_for_global acc) Predef.ident_division_by_zero - in + let division_by_zero = symbol_for_prim Predef.ident_division_by_zero in raise_exn_for_failure acc ~dbg exn_cont (Simple.symbol division_by_zero) None @@ -128,7 +129,7 @@ let expression_for_failure acc exn_cont ~register_const_string primitive dbg Misc.fatal_error "Cannot find Invalid_argument exception in Predef" | ident -> ident in - (Acc.symbol_for_global acc) invalid_argument + symbol_for_prim invalid_argument in let contents_of_exn_bucket = [Simple.symbol invalid_argument; Simple.symbol error_text] @@ -288,7 +289,8 @@ let rec bind_rec acc exn_cont ~register_const_string (prim : expr_primitive) bind_rec acc exn_cont ~register_const_string ifso dbg @@ fun acc ifso -> let acc, apply_cont = Apply_cont_with_acc.create acc join_point_cont - ~args:[Simple.var ifso_result] ~dbg + ~args:[Simple.var ifso_result] + ~dbg in let acc, body = Expr_with_acc.create_apply_cont acc apply_cont in Let_with_acc.create acc @@ -299,7 +301,8 @@ let rec bind_rec acc exn_cont ~register_const_string (prim : expr_primitive) bind_rec acc exn_cont ~register_const_string ifnot dbg @@ fun acc ifnot -> let acc, apply_cont = Apply_cont_with_acc.create acc join_point_cont - ~args:[Simple.var ifnot_result] ~dbg + ~args:[Simple.var ifnot_result] + ~dbg in let acc, body = Expr_with_acc.create_apply_cont acc apply_cont in Let_with_acc.create acc diff --git a/middle_end/flambda2/identifiers/continuation.ml b/middle_end/flambda2/identifiers/continuation.ml index 8fe0419c912..c041ca1ff05 100644 --- a/middle_end/flambda2/identifiers/continuation.ml +++ b/middle_end/flambda2/identifiers/continuation.ml @@ -55,7 +55,6 @@ end module Data = struct type t = { compilation_unit : Compilation_unit.t; - previous_compilation_units : Compilation_unit.t list; name : string; name_stamp : int; sort : Sort.t @@ -64,8 +63,7 @@ module Data = struct let flags = continuation_flags let [@ocamlformat "disable"] print ppf - { compilation_unit; name; name_stamp; sort; - previous_compilation_units = _; } = + { compilation_unit; name; name_stamp; sort; } = Format.fprintf ppf "@[(\ @[(compilation_unit@ %a)@]@ \ @[(name@ %s)@]@ \ @@ -77,17 +75,8 @@ module Data = struct name_stamp Sort.print sort - let hash - { compilation_unit; - previous_compilation_units; - name = _; - name_stamp; - sort = _ - } = - Hashtbl.hash - ( List.map Compilation_unit.hash - (compilation_unit :: previous_compilation_units), - name_stamp ) + let hash { compilation_unit; name = _; name_stamp; sort = _ } = + Hashtbl.hash (Compilation_unit.hash compilation_unit, name_stamp) let equal t1 t2 = if t1 == t2 @@ -95,7 +84,6 @@ module Data = struct else let { compilation_unit = compilation_unit1; name_stamp = name_stamp1; - previous_compilation_units = previous_compilation_units1; name = _; sort = _ } = @@ -103,7 +91,6 @@ module Data = struct in let { compilation_unit = compilation_unit2; name_stamp = name_stamp2; - previous_compilation_units = previous_compilation_units2; name = _; sort = _ } = @@ -111,8 +98,6 @@ module Data = struct in Int.equal name_stamp1 name_stamp2 && Compilation_unit.equal compilation_unit1 compilation_unit2 - && List.equal Compilation_unit.equal previous_compilation_units1 - previous_compilation_units2 end type t = Id.t @@ -131,24 +116,14 @@ let create ?sort ?name () : t = let sort = Option.value sort ~default:Sort.Normal_or_exn in let name = Option.value name ~default:"k" in let compilation_unit = Compilation_unit.get_current_exn () in - let previous_compilation_units = [] in let name_stamp = next_stamp () in - let data : Data.t = - { compilation_unit; previous_compilation_units; name; name_stamp; sort } - in + let data : Data.t = { compilation_unit; name; name_stamp; sort } in Table.add !grand_table_of_continuations data let find_data t = Table.find !grand_table_of_continuations t let rename t = - let { Data.name; - sort; - name_stamp = _; - compilation_unit = _; - previous_compilation_units = _ - } = - find_data t - in + let { Data.name; sort; name_stamp = _; compilation_unit = _ } = find_data t in create ~sort ~name () let name t = (find_data t).name @@ -187,14 +162,3 @@ module Map = Tree.Map let export t = find_data t let import data = Table.add !grand_table_of_continuations data - -let map_compilation_unit f (data : Data.t) : Data.t = - let new_compilation_unit = f data.compilation_unit in - if Compilation_unit.equal new_compilation_unit data.compilation_unit - then data - else - { data with - compilation_unit = new_compilation_unit; - previous_compilation_units = - data.compilation_unit :: data.previous_compilation_units - } diff --git a/middle_end/flambda2/identifiers/continuation.mli b/middle_end/flambda2/identifiers/continuation.mli index 53aad84f711..e4260391992 100644 --- a/middle_end/flambda2/identifiers/continuation.mli +++ b/middle_end/flambda2/identifiers/continuation.mli @@ -44,9 +44,6 @@ val export : t -> exported val import : exported -> t -val map_compilation_unit : - (Compilation_unit.t -> Compilation_unit.t) -> exported -> exported - val initialise : unit -> unit val reset : unit -> unit diff --git a/middle_end/flambda2/identifiers/int_ids.ml b/middle_end/flambda2/identifiers/int_ids.ml index 6f3c1109cd0..7b708fa4684 100644 --- a/middle_end/flambda2/identifiers/int_ids.ml +++ b/middle_end/flambda2/identifiers/int_ids.ml @@ -140,7 +140,6 @@ end module Variable_data = struct type t = { compilation_unit : Compilation_unit.t; - previous_compilation_units : Compilation_unit.t list; name : string; name_stamp : int; user_visible : bool @@ -148,8 +147,8 @@ module Variable_data = struct let flags = var_flags - let [@ocamlformat "disable"] print ppf { compilation_unit; previous_compilation_units = _; - name; name_stamp; user_visible; } = + let [@ocamlformat "disable"] print ppf { compilation_unit; name; name_stamp; + user_visible; } = Format.fprintf ppf "@[(\ @[(compilation_unit@ %a)@]@ \ @[(name@ %s)@]@ \ @@ -161,28 +160,14 @@ module Variable_data = struct name_stamp user_visible - let hash - { compilation_unit; - previous_compilation_units; - name = _; - name_stamp; - user_visible = _ - } = - let compilation_unit_hashes = - List.fold_left - (fun hash compilation_unit -> - hash2 hash (Compilation_unit.hash compilation_unit)) - (Compilation_unit.hash compilation_unit) - previous_compilation_units - in - hash2 compilation_unit_hashes (Hashtbl.hash name_stamp) + let hash { compilation_unit; name = _; name_stamp; user_visible = _ } = + hash2 (Compilation_unit.hash compilation_unit) (Hashtbl.hash name_stamp) let equal t1 t2 = if t1 == t2 then true else let { compilation_unit = compilation_unit1; - previous_compilation_units = previous_compilation_units1; name = _; name_stamp = name_stamp1; user_visible = _ @@ -190,25 +175,14 @@ module Variable_data = struct t1 in let { compilation_unit = compilation_unit2; - previous_compilation_units = previous_compilation_units2; name = _; name_stamp = name_stamp2; user_visible = _ } = t2 in - let rec previous_compilation_units_match l1 l2 = - match l1, l2 with - | [], [] -> true - | [], _ :: _ | _ :: _, [] -> false - | unit1 :: tl1, unit2 :: tl2 -> - Compilation_unit.equal unit1 unit2 - && previous_compilation_units_match tl1 tl2 - in Int.equal name_stamp1 name_stamp2 && Compilation_unit.equal compilation_unit1 compilation_unit2 - && previous_compilation_units_match previous_compilation_units1 - previous_compilation_units2 end module Symbol0 = Flambda2_import.Symbol @@ -340,10 +314,6 @@ module Const = struct let export t = find_data t let import (data : exported) = create data - - let map_compilation_unit _f data = - (* No compilation unit in the data *) - data end module Variable = struct @@ -377,7 +347,6 @@ module Variable = struct in let data : Variable_data.t = { compilation_unit = Compilation_unit.get_current_exn (); - previous_compilation_units = []; name; name_stamp; user_visible = Option.is_some user_visible @@ -419,17 +388,6 @@ module Variable = struct let export t = find_data t let import (data : exported) = Table.add !grand_table_of_variables data - - let map_compilation_unit f (data : exported) : exported = - let new_compilation_unit = f data.compilation_unit in - if Compilation_unit.equal new_compilation_unit data.compilation_unit - then data - else - { data with - compilation_unit = new_compilation_unit; - previous_compilation_units = - data.compilation_unit :: data.previous_compilation_units - } end module Symbol = struct @@ -450,9 +408,7 @@ module Symbol = struct let unsafe_create compilation_unit linkage_name = Symbol_data.unsafe_create compilation_unit linkage_name |> create_wrapped - let extern_syms = - Compilation_unit.create Compilation_unit.Prefix.empty - ("*extern*" |> Compilation_unit.Name.of_string) + let extern_syms = "*extern*" |> Compilation_unit.of_string let external_symbols_compilation_unit () = extern_syms @@ -507,9 +463,6 @@ module Symbol = struct let export t = find_data t let import (data : exported) = Table.add !grand_table_of_symbols data - - let map_compilation_unit f (data : exported) : exported = - Symbol0.with_compilation_unit data (f (Symbol0.compilation_unit data)) end module Name = struct @@ -711,11 +664,6 @@ module Simple = struct that the real import functions (in Renaming) are responsible for importing the underlying name/const. *) Table.add !grand_table_of_simples data - - let map_compilation_unit _f data = - (* The compilation unit is not associated with the simple directly, only - with the underlying name, which has its own entry. *) - data end module Code_id = struct @@ -796,9 +744,6 @@ module Code_id = struct let export t = find_data t let import (data : exported) = Table.add !grand_table_of_code_ids data - - let map_compilation_unit f (data : exported) : exported = - { data with compilation_unit = f data.compilation_unit } end module Code_id_or_symbol = struct diff --git a/middle_end/flambda2/identifiers/int_ids.mli b/middle_end/flambda2/identifiers/int_ids.mli index 0587835765c..5d8b3b374d2 100644 --- a/middle_end/flambda2/identifiers/int_ids.mli +++ b/middle_end/flambda2/identifiers/int_ids.mli @@ -77,9 +77,6 @@ module Const : sig val export : t -> exported val import : exported -> t - - val map_compilation_unit : - (Compilation_unit.t -> Compilation_unit.t) -> exported -> exported end module Variable : sig @@ -102,9 +99,6 @@ module Variable : sig val export : t -> exported val import : exported -> t - - val map_compilation_unit : - (Compilation_unit.t -> Compilation_unit.t) -> exported -> exported end module Symbol : sig @@ -133,9 +127,6 @@ module Symbol : sig val import : exported -> t - val map_compilation_unit : - (Compilation_unit.t -> Compilation_unit.t) -> exported -> exported - val external_symbols_compilation_unit : unit -> Compilation_unit.t end @@ -198,9 +189,6 @@ module Simple : sig val export : t -> exported val import : exported -> t - - val map_compilation_unit : - (Compilation_unit.t -> Compilation_unit.t) -> exported -> exported end module Code_id : sig @@ -235,9 +223,6 @@ module Code_id : sig val export : t -> exported val import : exported -> t - - val map_compilation_unit : - (Compilation_unit.t -> Compilation_unit.t) -> exported -> exported end module Code_id_or_symbol : sig diff --git a/ocaml/middle_end/flambda/export_info_for_pack.mli b/middle_end/flambda2/identifiers/named_rewrite_id.ml similarity index 57% rename from ocaml/middle_end/flambda/export_info_for_pack.mli rename to middle_end/flambda2/identifiers/named_rewrite_id.ml index c1dbfb7015f..a11b6c8d66d 100644 --- a/ocaml/middle_end/flambda/export_info_for_pack.mli +++ b/middle_end/flambda2/identifiers/named_rewrite_id.ml @@ -5,8 +5,8 @@ (* Pierre Chambart, OCamlPro *) (* Mark Shinwell and Leo White, Jane Street Europe *) (* *) -(* Copyright 2013--2016 OCamlPro SAS *) -(* Copyright 2014--2016 Jane Street Group LLC *) +(* Copyright 2013--2019 OCamlPro SAS *) +(* Copyright 2014--2019 Jane Street Group LLC *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) @@ -14,21 +14,11 @@ (* *) (**************************************************************************) -[@@@ocaml.warning "+a-4-9-30-40-41-42"] +include Numeric_types.Int -(** Transformations on export information that are only used for the - building of packs. *) +let next = ref 0 -(** Transform the information from [exported] to be - suitable to be reexported as the information for a pack named [pack] - containing units [pack_units]. - It mainly changes symbols of units [pack_units] to refer to - [pack] instead. *) -val import_for_pack - : pack_units:Compilation_unit.Set.t - -> pack:Compilation_unit.Prefix.t - -> Export_info.t - -> Export_info.t - -(** Drops the state after importing several units in the same pack. *) -val clear_import_state : unit -> unit +let create () = + let t = !next in + incr next; + t diff --git a/middle_end/flambda2/identifiers/named_rewrite_id.mli b/middle_end/flambda2/identifiers/named_rewrite_id.mli new file mode 100644 index 00000000000..eb7c8396a5a --- /dev/null +++ b/middle_end/flambda2/identifiers/named_rewrite_id.mli @@ -0,0 +1,21 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2019 OCamlPro SAS *) +(* Copyright 2014--2019 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type t + +include Container_types.S with type t := t + +val create : unit -> t diff --git a/middle_end/flambda2/kinds/flambda_kind.ml b/middle_end/flambda2/kinds/flambda_kind.ml index dba43afbeee..894f37c5959 100644 --- a/middle_end/flambda2/kinds/flambda_kind.ml +++ b/middle_end/flambda2/kinds/flambda_kind.ml @@ -408,6 +408,10 @@ module With_subkind = struct subkind print kind)); { kind; subkind } + let compatible t ~when_used_at = + equal t.kind when_used_at.kind + && Subkind.compatible t.subkind ~when_used_at:when_used_at.subkind + let kind t = t.kind let subkind t = t.subkind @@ -535,9 +539,6 @@ module With_subkind = struct let hash { kind; subkind } = Hashtbl.hash (hash kind, Subkind.hash subkind) end) - let compatible t ~when_used_at = - Subkind.compatible t.subkind ~when_used_at:when_used_at.subkind - let has_useful_subkind_info t = match t.subkind with | Anything -> false diff --git a/middle_end/flambda2/nominal/name_occurrences.ml b/middle_end/flambda2/nominal/name_occurrences.ml index 86a1c972afc..4f0a2031066 100644 --- a/middle_end/flambda2/nominal/name_occurrences.ml +++ b/middle_end/flambda2/nominal/name_occurrences.ml @@ -67,6 +67,8 @@ end) : sig val for_all : t -> f:(N.t -> bool) -> bool val filter : t -> f:(N.t -> bool) -> t + + val increase_counts : t -> t end = struct module For_one_name : sig type t @@ -89,6 +91,8 @@ end = struct val max_name_mode_opt : t -> Name_mode.t option val union : t -> t -> t + + val increase_count : t -> t end = struct (* CR mshinwell: Provide 32-bit implementation? Probably not worth it now I suppose. *) @@ -189,6 +193,15 @@ end = struct (num_occurrences_in_types t1 + num_occurrences_in_types t2) lor encode_phantom_occurrences (num_occurrences_phantom t1 + num_occurrences_phantom t2) + + let increase_count t = + let increase_if_not_zero n = if n = 0 then n else succ n in + encode_normal_occurrences + (increase_if_not_zero (num_occurrences_normal t)) + lor encode_in_types_occurrences + (increase_if_not_zero (num_occurrences_in_types t)) + lor encode_phantom_occurrences + (increase_if_not_zero (num_occurrences_phantom t)) end type t = For_one_name.t N.Map.t @@ -308,6 +321,8 @@ end = struct let for_all t ~f = N.Map.for_all (fun name _ -> f name) t let filter t ~f = N.Map.filter (fun name _ -> f name) t + + let increase_counts t = N.Map.map For_one_name.increase_count t end [@@inline always] @@ -1128,3 +1143,51 @@ let ids_for_export (For_code_ids.keys newer_version_of_code_ids) in Ids_for_export.create ~variables ~symbols ~code_ids ~continuations () + +let increase_counts + { names; + continuations; + continuations_with_traps; + continuations_in_trap_actions; + function_slots_in_projections; + value_slots_in_projections; + function_slots_in_declarations; + value_slots_in_declarations; + code_ids; + newer_version_of_code_ids + } = + let names = For_names.increase_counts names in + let continuations = For_continuations.increase_counts continuations in + let continuations_with_traps = + For_continuations.increase_counts continuations_with_traps + in + let continuations_in_trap_actions = + For_continuations.increase_counts continuations_in_trap_actions + in + let function_slots_in_projections = + For_function_slots.increase_counts function_slots_in_projections + in + let value_slots_in_projections = + For_value_slots.increase_counts value_slots_in_projections + in + let function_slots_in_declarations = + For_function_slots.increase_counts function_slots_in_declarations + in + let value_slots_in_declarations = + For_value_slots.increase_counts value_slots_in_declarations + in + let code_ids = For_code_ids.increase_counts code_ids in + let newer_version_of_code_ids = + For_code_ids.increase_counts newer_version_of_code_ids + in + { names; + continuations; + continuations_with_traps; + continuations_in_trap_actions; + function_slots_in_projections; + value_slots_in_projections; + function_slots_in_declarations; + value_slots_in_declarations; + code_ids; + newer_version_of_code_ids + } diff --git a/middle_end/flambda2/nominal/name_occurrences.mli b/middle_end/flambda2/nominal/name_occurrences.mli index dbb43046a87..9a445fdffbc 100644 --- a/middle_end/flambda2/nominal/name_occurrences.mli +++ b/middle_end/flambda2/nominal/name_occurrences.mli @@ -189,3 +189,5 @@ val fold_continuations_including_in_trap_actions : t -> init:'a -> f:('a -> Continuation.t -> 'a) -> 'a val fold_code_ids : t -> init:'a -> f:('a -> Code_id.t -> 'a) -> 'a + +val increase_counts : t -> t diff --git a/middle_end/flambda2/parser/fexpr_to_flambda.ml b/middle_end/flambda2/parser/fexpr_to_flambda.ml index 08b97b32377..c7c65778992 100644 --- a/middle_end/flambda2/parser/fexpr_to_flambda.ml +++ b/middle_end/flambda2/parser/fexpr_to_flambda.ml @@ -315,7 +315,8 @@ let unop env (unop : Fexpr.unop) : Flambda_primitive.unary_primitive = | Project_value_slot { project_from; value_slot } -> let value_slot = fresh_or_existing_value_slot env value_slot in let project_from = fresh_or_existing_function_slot env project_from in - Project_value_slot { project_from; value_slot } + Project_value_slot + { project_from; value_slot; kind = Flambda_kind.With_subkind.any_value } | Project_function_slot { move_from; move_to } -> let move_from = fresh_or_existing_function_slot env move_from in let move_to = fresh_or_existing_function_slot env move_to in @@ -415,9 +416,10 @@ let set_of_closures env fun_decls value_slots = |> Function_slot.Lmap.of_list |> Function_declarations.create in let value_slots = Option.value value_slots ~default:[] in - let value_slots : Simple.t Value_slot.Map.t = + let value_slots : (Simple.t * Flambda_kind.With_subkind.t) Value_slot.Map.t = let convert ({ var; value } : Fexpr.one_value_slot) = - fresh_or_existing_value_slot env var, simple env value + ( fresh_or_existing_value_slot env var, + (simple env value, Flambda_kind.With_subkind.any_value) ) in List.map convert value_slots |> Value_slot.Map.of_list in @@ -778,21 +780,23 @@ let rec expr env (e : Fexpr.expr) : Flambda.Expr.t = in let code = (* CR mshinwell: [inlining_decision] should maybe be set properly *) + (* CR ncourant: same for loopify *) Code.create code_id ~params_and_body ~free_names_of_params_and_body ~newer_version_of ~params_arity ~num_trailing_local_params:0 ~result_arity ~result_types:Unknown ~contains_no_escaping_local_allocs:false ~stub:false ~inline - ~check: - Default_check (* CR gyorsh: should [check] be set properly? *) + ~check:Default_check + (* CR gyorsh: should [check] be set properly? *) ~is_a_functor:false ~recursive ~cost_metrics (* CR poechsel: grab inlining arguments from fexpr. *) ~inlining_arguments:(Inlining_arguments.create ~round:0) - ~dbg:Debuginfo.none ~is_tupled ~is_my_closure_used - ~inlining_decision:Never_inline_attribute + ~poll_attribute:Default ~dbg:Debuginfo.none ~is_tupled + ~is_my_closure_used ~inlining_decision:Never_inline_attribute ~absolute_history: (Inlining_history.Absolute.empty (Compilation_unit.get_current_exn ())) ~relative_history:Inlining_history.Relative.empty + ~loopify:Never_loopify in Flambda.Static_const_or_code.create_code code in @@ -897,10 +901,10 @@ let bind_all_code_ids env (unit : Fexpr.flambda_unit) = in go env unit.body -let conv ~symbol_for_global ~module_ident (fexpr : Fexpr.flambda_unit) : - Flambda_unit.t = +let conv comp_unit (fexpr : Fexpr.flambda_unit) : Flambda_unit.t = let module_symbol = - symbol_for_global (Ident.create_persistent (Ident.name module_ident)) + Flambda2_import.Symbol.for_compilation_unit comp_unit + |> Symbol.create_wrapped in let env = init_env () in let { done_continuation = return_continuation; error_continuation; _ } = diff --git a/middle_end/flambda2/parser/fexpr_to_flambda.mli b/middle_end/flambda2/parser/fexpr_to_flambda.mli index 895c7d82e51..81c789f6046 100644 --- a/middle_end/flambda2/parser/fexpr_to_flambda.mli +++ b/middle_end/flambda2/parser/fexpr_to_flambda.mli @@ -1,5 +1 @@ -val conv : - symbol_for_global:(Ident.t -> Symbol.t) -> - module_ident:Ident.t -> - Fexpr.flambda_unit -> - Flambda_unit.t +val conv : Compilation_unit.t -> Fexpr.flambda_unit -> Flambda_unit.t diff --git a/middle_end/flambda2/parser/flambda_to_fexpr.ml b/middle_end/flambda2/parser/flambda_to_fexpr.ml index 7bdcf01fce0..643a37feaec 100644 --- a/middle_end/flambda2/parser/flambda_to_fexpr.ml +++ b/middle_end/flambda2/parser/flambda_to_fexpr.ml @@ -437,7 +437,7 @@ let unop env (op : Flambda_primitive.unary_primitive) : Fexpr.unop = | Opaque_identity _ -> Opaque_identity | Unbox_number bk -> Unbox_number bk | Untag_immediate -> Untag_immediate - | Project_value_slot { project_from; value_slot } -> + | Project_value_slot { project_from; value_slot; kind = _ } -> let project_from = Env.translate_function_slot env project_from in let value_slot = Env.translate_value_slot env value_slot in Project_value_slot { project_from; value_slot } @@ -448,7 +448,8 @@ let unop env (op : Flambda_primitive.unary_primitive) : Fexpr.unop = | String_length string_or_bytes -> String_length string_or_bytes | Int_as_pointer | Boolean_not | Duplicate_block _ | Duplicate_array _ | Bigarray_length _ | Int_arith _ | Float_arith _ | Reinterpret_int64_as_float - | Is_boxed_float | Is_flat_float_array | End_region | Obj_dup -> + | Is_boxed_float | Is_flat_float_array | Begin_try_region | End_region + | Obj_dup -> Misc.fatal_errorf "TODO: Unary primitive: %a" Flambda_primitive.Without_args.print (Flambda_primitive.Without_args.Unary op) @@ -520,7 +521,13 @@ let prim env (p : Flambda_primitive.t) : Fexpr.prim = let value_slots env map = List.map - (fun (var, value) -> + (fun (var, (value, kind)) -> + if not + (Flambda_kind.equal + (Flambda_kind.With_subkind.kind kind) + Flambda_kind.value) + then + Misc.fatal_errorf "Value slot %a not of kind Value" Simple.print value; let var = Env.translate_value_slot env var in let value = simple env value in { Fexpr.var; value }) diff --git a/middle_end/flambda2/parser/parse_flambda.ml b/middle_end/flambda2/parser/parse_flambda.ml index 4fb39d23653..6fdd0ddbc02 100644 --- a/middle_end/flambda2/parser/parse_flambda.ml +++ b/middle_end/flambda2/parser/parse_flambda.ml @@ -149,20 +149,12 @@ let make_compilation_unit ~extension ~filename ?(tag = "") () = Compilation_unit.create Compilation_unit.Prefix.empty (name |> Compilation_unit.Name.of_string) -let parse ~symbol_for_global filename = +let parse filename = parse_fexpr filename |> Result.map (fun fexpr -> let comp_unit = make_compilation_unit ~extension:".fl" ~filename () in let old_comp_unit = Compilation_unit.get_current () in - Compilation_unit.set_current comp_unit; - let module_ident = - Ident.create_persistent - (Compilation_unit.full_path_as_string comp_unit) - in - let flambda = - Fexpr_to_flambda.conv ~symbol_for_global ~module_ident fexpr - in - (match old_comp_unit with - | Some old_comp_unit -> Compilation_unit.set_current old_comp_unit - | None -> ()); + Compilation_unit.set_current (Some comp_unit); + let flambda = Fexpr_to_flambda.conv comp_unit fexpr in + Compilation_unit.set_current old_comp_unit; flambda) diff --git a/middle_end/flambda2/parser/parse_flambda.mli b/middle_end/flambda2/parser/parse_flambda.mli index 8c4d23c0ed2..071c55e3dcb 100644 --- a/middle_end/flambda2/parser/parse_flambda.mli +++ b/middle_end/flambda2/parser/parse_flambda.mli @@ -15,7 +15,4 @@ val make_compilation_unit : unit -> Compilation_unit.t -val parse : - symbol_for_global:(Ident.t -> Symbol.t) -> - string -> - (Flambda_unit.t, error) result +val parse : string -> (Flambda_unit.t, error) result diff --git a/middle_end/flambda2/parser/print_fexpr.ml b/middle_end/flambda2/parser/print_fexpr.ml index bd53ca16c5a..d85772cbc62 100644 --- a/middle_end/flambda2/parser/print_fexpr.ml +++ b/middle_end/flambda2/parser/print_fexpr.ml @@ -439,7 +439,7 @@ let unop ppf u = | String_length String -> str "%string_length" | Unbox_number bk -> box_or_unbox "unbox" bk | Untag_immediate -> str "%untag_imm" - | Tag_immediate -> str "%tag_imm" + | Tag_immediate -> str "%Tag_imm" let ternop ppf t a1 a2 a3 = match t with diff --git a/middle_end/flambda2/simplify/env/closure_info.ml b/middle_end/flambda2/simplify/env/closure_info.ml index 6b78b2f22f7..55ddea94abc 100644 --- a/middle_end/flambda2/simplify/env/closure_info.ml +++ b/middle_end/flambda2/simplify/env/closure_info.ml @@ -19,7 +19,8 @@ type t = | Closure of { code_id : Code_id.t; return_continuation : Continuation.t; - exn_continuation : Continuation.t + exn_continuation : Continuation.t; + my_closure : Variable.t } let [@ocamlformat "disable"] print ppf = function @@ -27,23 +28,25 @@ let [@ocamlformat "disable"] print ppf = function Format.fprintf ppf "not_in_a_closure" | In_a_set_of_closures_but_not_yet_in_a_specific_closure -> Format.fprintf ppf "in_a_set_of_closures" - | Closure { code_id; return_continuation; exn_continuation; } -> + | Closure { code_id; return_continuation; exn_continuation; my_closure } -> Format.fprintf ppf "@[(\ @[(code_id@ %a)@]@ \ @[(return_continuation@ %a)@]@ \ - @[(exn_continuation@ %a)@]\ + @[(exn_continuation@ %a)@]@ \ + @[(my_closure@ %a)@]\ )@]" Code_id.print code_id Continuation.print return_continuation Continuation.print exn_continuation + Variable.print my_closure let not_in_a_closure = Not_in_a_closure let in_a_set_of_closures = In_a_set_of_closures_but_not_yet_in_a_specific_closure -let in_a_closure code_id ~return_continuation ~exn_continuation = - Closure { code_id; return_continuation; exn_continuation } +let in_a_closure code_id ~return_continuation ~exn_continuation ~my_closure = + Closure { code_id; return_continuation; exn_continuation; my_closure } type in_or_out_of_closure = | In_a_closure diff --git a/middle_end/flambda2/simplify/env/closure_info.mli b/middle_end/flambda2/simplify/env/closure_info.mli index 882cd270e5f..5c2234f0bf6 100644 --- a/middle_end/flambda2/simplify/env/closure_info.mli +++ b/middle_end/flambda2/simplify/env/closure_info.mli @@ -19,7 +19,8 @@ type t = private | Closure of { code_id : Code_id.t; return_continuation : Continuation.t; - exn_continuation : Continuation.t + exn_continuation : Continuation.t; + my_closure : Variable.t } val print : Format.formatter -> t -> unit @@ -32,6 +33,7 @@ val in_a_closure : Code_id.t -> return_continuation:Continuation.t -> exn_continuation:Continuation.t -> + my_closure:Variable.t -> t type in_or_out_of_closure = diff --git a/middle_end/flambda2/simplify/env/continuation_uses.ml b/middle_end/flambda2/simplify/env/continuation_uses.ml index 3dfbf5d6a38..93f61561d65 100644 --- a/middle_end/flambda2/simplify/env/continuation_uses.ml +++ b/middle_end/flambda2/simplify/env/continuation_uses.ml @@ -96,6 +96,11 @@ let get_arg_types_by_use_id t = arg_maps arg_types) empty_arg_maps t.uses +let get_use_ids t = + List.fold_left + (fun uses use -> Apply_cont_rewrite_id.Set.add (U.id use) uses) + Apply_cont_rewrite_id.Set.empty t.uses + let get_typing_env_no_more_than_one_use t = match t.uses with | [] -> None @@ -103,3 +108,6 @@ let get_typing_env_no_more_than_one_use t = | _ :: _ -> Misc.fatal_errorf "Only zero or one continuation use(s) expected:@ %a" print t + +let mark_non_inlinable t = + { t with uses = List.map U.mark_non_inlinable t.uses } diff --git a/middle_end/flambda2/simplify/env/continuation_uses.mli b/middle_end/flambda2/simplify/env/continuation_uses.mli index 6e6d00902c1..2a9b11e8f43 100644 --- a/middle_end/flambda2/simplify/env/continuation_uses.mli +++ b/middle_end/flambda2/simplify/env/continuation_uses.mli @@ -44,6 +44,8 @@ type arg_types_by_use_id = arg_at_use Apply_cont_rewrite_id.Map.t list val get_arg_types_by_use_id : t -> arg_types_by_use_id +val get_use_ids : t -> Apply_cont_rewrite_id.Set.t + val number_of_uses : t -> int val arity : t -> Flambda_arity.t @@ -52,3 +54,5 @@ val get_typing_env_no_more_than_one_use : t -> Flambda2_types.Typing_env.t option val union : t -> t -> t + +val mark_non_inlinable : t -> t diff --git a/middle_end/flambda2/simplify/env/continuation_uses_env.ml b/middle_end/flambda2/simplify/env/continuation_uses_env.ml index 05aca9f1fc0..438b2076025 100644 --- a/middle_end/flambda2/simplify/env/continuation_uses_env.ml +++ b/middle_end/flambda2/simplify/env/continuation_uses_env.ml @@ -71,3 +71,9 @@ let remove t cont = { continuation_uses = Continuation.Map.remove cont t.continuation_uses } let delete_continuation_uses = remove + +let mark_non_inlinable { continuation_uses } = + let continuation_uses = + Continuation.Map.map Continuation_uses.mark_non_inlinable continuation_uses + in + { continuation_uses } diff --git a/middle_end/flambda2/simplify/env/continuation_uses_env.mli b/middle_end/flambda2/simplify/env/continuation_uses_env.mli index 31b335e9fbc..203f194d08e 100644 --- a/middle_end/flambda2/simplify/env/continuation_uses_env.mli +++ b/middle_end/flambda2/simplify/env/continuation_uses_env.mli @@ -27,3 +27,5 @@ val get_continuation_uses : t -> Continuation.t -> Continuation_uses.t option val remove : t -> Continuation.t -> t val union : t -> t -> t + +val mark_non_inlinable : t -> t diff --git a/middle_end/flambda2/simplify/env/data_flow.ml b/middle_end/flambda2/simplify/env/data_flow.ml deleted file mode 100644 index 81b995d9920..00000000000 --- a/middle_end/flambda2/simplify/env/data_flow.ml +++ /dev/null @@ -1,728 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Pierre Chambart and Guillaume Bury, OCamlPro *) -(* *) -(* Copyright 2021--2021 OCamlPro SAS *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -module EPA = Continuation_extra_params_and_args - -(* Helper module *) -(* ************* *) - -module Reachable_code_ids = struct - type t = - { live_code_ids : Code_id.Set.t; - ancestors_of_live_code_ids : Code_id.Set.t - } - - let [@ocamlformat "disable"] print ppf { live_code_ids; ancestors_of_live_code_ids; } = - Format.fprintf ppf "@[(\ - @[(live_code_ids@ %a)@]@ \ - @[(ancestors_of_live_code_ids@ %a)@]\ - )@]" - Code_id.Set.print live_code_ids - Code_id.Set.print ancestors_of_live_code_ids -end - -(* Typedefs *) -(* ******** *) - -(* CR chambart/gbury: we might want to also track function_slots in addition to - value_slots. *) - -(* CR-someday chambart/gbury: get rid of Name_occurences everywhere, this is not - small while we need only the names - - mshinwell: in practice I'm not sure this will make any difference *) -type elt = - { continuation : Continuation.t; - params : Variable.t list; - used_in_handler : Name_occurrences.t; - apply_result_conts : Continuation.Set.t; - bindings : Name_occurrences.t Name.Map.t; - code_ids : Name_occurrences.t Code_id.Map.t; - value_slots : Name_occurrences.t Name.Map.t Value_slot.Map.t; - apply_cont_args : - Name_occurrences.t Numeric_types.Int.Map.t Continuation.Map.t - } - -type t = - { stack : elt list; - map : elt Continuation.Map.t; - extra : Continuation_extra_params_and_args.t Continuation.Map.t - } - -type result = - { required_names : Name.Set.t; - reachable_code_ids : Reachable_code_ids.t - } - -(* Print *) -(* ***** *) - -let print_elt ppf - { continuation; - params; - used_in_handler; - apply_result_conts; - bindings; - code_ids; - value_slots; - apply_cont_args - } = - Format.fprintf ppf - "@[(@[(continuation %a)@]@ @[(params %a)@]@ @[(used_in_handler %a)@]@ @[(apply_result_conts %a)@]@ @[(bindings %a)@]@ @[(code_ids %a)@]@ @[(value_slots %a)@]@ \ - @[(apply_cont_args %a)@])@]" - Continuation.print continuation - (Format.pp_print_list ~pp_sep:Format.pp_print_space Variable.print) - params Name_occurrences.print used_in_handler Continuation.Set.print - apply_result_conts - (Name.Map.print Name_occurrences.print) - bindings - (Code_id.Map.print Name_occurrences.print) - code_ids - (Value_slot.Map.print (Name.Map.print Name_occurrences.print)) - value_slots - (Continuation.Map.print - (Numeric_types.Int.Map.print Name_occurrences.print)) - apply_cont_args - -let print_stack ppf stack = - Format.fprintf ppf "@[(%a)@]" - (Format.pp_print_list print_elt ~pp_sep:Format.pp_print_space) - stack - -let print_map ppf map = Continuation.Map.print print_elt ppf map - -let print_extra ppf extra = - Continuation.Map.print Continuation_extra_params_and_args.print ppf extra - -let [@ocamlformat "disable"] print ppf { stack; map; extra } = - Format.fprintf ppf - "@[(\ - @[(stack %a)@]@ \ - @[(map %a)@]@ \ - @[(extra %a)@]\ - )@]" - print_stack stack - print_map map - print_extra extra - -let _print_result ppf { required_names; reachable_code_ids } = - Format.fprintf ppf - "@[(@[(required_names@ %a)@]@ @[(reachable_code_ids@ \ - %a)@])@]" - Name.Set.print required_names Reachable_code_ids.print reachable_code_ids - -(* Creation *) -(* ******** *) - -let empty = - { stack = []; map = Continuation.Map.empty; extra = Continuation.Map.empty } - -(* Updates *) -(* ******* *) - -let add_extra_params_and_args cont extra t = - let extra = - Continuation.Map.update cont - (function - | Some _ -> Misc.fatal_errorf "Continuation extended a second time" - | None -> Some extra) - t.extra - in - { t with extra } - -let enter_continuation continuation params t = - let elt = - { continuation; - params; - bindings = Name.Map.empty; - code_ids = Code_id.Map.empty; - value_slots = Value_slot.Map.empty; - used_in_handler = Name_occurrences.empty; - apply_cont_args = Continuation.Map.empty; - apply_result_conts = Continuation.Set.empty - } - in - { t with stack = elt :: t.stack } - -let init_toplevel continuation params _t = - enter_continuation continuation params empty - -let exit_continuation cont t = - match t.stack with - | [] -> Misc.fatal_errorf "Empty stack of variable uses" - | ({ continuation; _ } as elt) :: stack -> - assert (Continuation.equal cont continuation); - let map = Continuation.Map.add cont elt t.map in - { t with stack; map } - -let update_top_of_stack ~t ~f = - match t.stack with - | [] -> Misc.fatal_errorf "Empty stack of variable uses" - | elt :: stack -> { t with stack = f elt :: stack } - -let record_var_binding var name_occurrences ~generate_phantom_lets t = - update_top_of_stack ~t ~f:(fun elt -> - let bindings = - Name.Map.update (Name.var var) - (function - | None -> Some name_occurrences - | Some _ -> - Misc.fatal_errorf - "The following variable has been bound twice: %a" Variable.print - var) - elt.bindings - in - let used_in_handler = - if Variable.user_visible var && generate_phantom_lets - then - Name_occurrences.add_variable elt.used_in_handler var - Name_mode.phantom - else elt.used_in_handler - in - { elt with bindings; used_in_handler }) - -let record_symbol_projection var name_occurrences t = - update_top_of_stack ~t ~f:(fun elt -> - let bindings = - Name.Map.update (Name.var var) - (function - | None -> Some name_occurrences - | Some prior_occurences as original -> - if Name_occurrences.equal prior_occurences name_occurrences - then original - else - Misc.fatal_errorf - "@[The following projection has been bound to different \ - symbols:%a@ previously bound to:@ %a@ and now to@ %a@]" - Variable.print var Name_occurrences.print prior_occurences - Name_occurrences.print name_occurrences) - elt.bindings - in - { elt with bindings }) - -let record_symbol_binding symbol name_occurrences t = - update_top_of_stack ~t ~f:(fun elt -> - let bindings = - Name.Map.update (Name.symbol symbol) - (function - | None -> Some name_occurrences - | Some _ -> - Misc.fatal_errorf "The following symbol has been bound twice: %a" - Symbol.print symbol) - elt.bindings - in - { elt with bindings }) - -let record_code_id_binding code_id name_occurrences t = - update_top_of_stack ~t ~f:(fun elt -> - let code_ids = - Code_id.Map.update code_id - (function - | None -> Some name_occurrences - | Some _ -> - Misc.fatal_errorf "The following code_id has been bound twice: %a" - Code_id.print code_id) - elt.code_ids - in - { elt with code_ids }) - -let record_value_slot src value_slot dst t = - update_top_of_stack ~t ~f:(fun elt -> - let value_slots = - Value_slot.Map.update value_slot - (function - | None -> Some (Name.Map.singleton src dst) - | Some map -> - Some - (Name.Map.update src - (function - | None -> Some dst - | Some dst' -> Some (Name_occurrences.union dst dst')) - map)) - elt.value_slots - in - { elt with value_slots }) - -let add_used_in_current_handler name_occurrences t = - update_top_of_stack ~t ~f:(fun elt -> - let used_in_handler = - Name_occurrences.union elt.used_in_handler name_occurrences - in - { elt with used_in_handler }) - -let add_apply_result_cont k t = - update_top_of_stack ~t ~f:(fun elt -> - let apply_result_conts = Continuation.Set.add k elt.apply_result_conts in - { elt with apply_result_conts }) - -let add_apply_cont_args cont arg_name_occurrences t = - update_top_of_stack ~t ~f:(fun elt -> - let apply_cont_args = - Continuation.Map.update cont - (fun map_opt -> - let map = - Option.value ~default:Numeric_types.Int.Map.empty map_opt - in - let map, _ = - List.fold_left - (fun (map, i) name_occurrences -> - let map = - Numeric_types.Int.Map.update i - (fun old_opt -> - let old = - Option.value ~default:Name_occurrences.empty old_opt - in - Some (Name_occurrences.union old name_occurrences)) - map - in - map, i + 1) - (map, 0) arg_name_occurrences - in - Some map) - elt.apply_cont_args - in - { elt with apply_cont_args }) - -(* Dependency graph *) -(* **************** *) - -module Dependency_graph = struct - type t = - { code_age_relation : Code_age_relation.t; - name_to_name : Name.Set.t Name.Map.t; - name_to_code_id : Code_id.Set.t Name.Map.t; - code_id_to_name : Name.Set.t Code_id.Map.t; - code_id_to_code_id : Code_id.Set.t Code_id.Map.t; - unconditionally_used : Name.Set.t; - code_id_unconditionally_used : Code_id.Set.t - } - - module Reachable = struct - module Edge (Src_map : Container_types.Map) (Dst_set : Container_types.Set) = - struct - type src = Src_map.key - - type dst = Dst_set.elt - - let push ~(src : src) (enqueued : Dst_set.t) (queue : dst Queue.t) - (graph : Dst_set.t Src_map.t) : Dst_set.t = - let neighbours = - match Src_map.find src graph with - | exception Not_found -> Dst_set.empty - | set -> set - in - let new_neighbours = Dst_set.diff neighbours enqueued in - Dst_set.iter (fun dst -> Queue.push dst queue) new_neighbours; - Dst_set.union enqueued new_neighbours - end - [@@inline] - (* TODO check that this applied here *) - - module Name_Name_Edge = Edge (Name.Map) (Name.Set) - module Name_Code_id_Edge = Edge (Name.Map) (Code_id.Set) - module Code_id_Name_Edge = Edge (Code_id.Map) (Name.Set) - module Code_id_Code_id_Edge = Edge (Code_id.Map) (Code_id.Set) - - (* breadth-first reachability analysis. *) - let rec reachable_names t code_id_queue code_id_enqueued older_enqueued - name_queue name_enqueued = - match Queue.take name_queue with - | exception Queue.Empty -> - if Queue.is_empty code_id_queue - then - { required_names = name_enqueued; - reachable_code_ids = - { live_code_ids = code_id_enqueued; - ancestors_of_live_code_ids = older_enqueued - } - } - else - reachable_code_ids t code_id_queue code_id_enqueued (Queue.create ()) - older_enqueued name_queue name_enqueued - | src -> - let name_enqueued = - Name_Name_Edge.push ~src name_enqueued name_queue t.name_to_name - in - let code_id_enqueued = - Name_Code_id_Edge.push ~src code_id_enqueued code_id_queue - t.name_to_code_id - in - reachable_names t code_id_queue code_id_enqueued older_enqueued - name_queue name_enqueued - - and reachable_code_ids t code_id_queue code_id_enqueued older_queue - older_enqueued name_queue name_enqueued = - match Queue.take code_id_queue with - | exception Queue.Empty -> - if Queue.is_empty older_queue - then - reachable_names t code_id_queue code_id_enqueued older_enqueued - name_queue name_enqueued - else - reachable_older_code_ids t code_id_queue code_id_enqueued older_queue - older_enqueued name_queue name_enqueued - | src -> - let name_enqueued = - Code_id_Name_Edge.push ~src name_enqueued name_queue t.code_id_to_name - in - let code_id_enqueued = - Code_id_Code_id_Edge.push ~src code_id_enqueued code_id_queue - t.code_id_to_code_id - in - let older_enqueued = - if Code_id.Set.mem src older_enqueued - then older_enqueued - else ( - Queue.push src older_queue; - Code_id.Set.add src older_enqueued) - in - reachable_code_ids t code_id_queue code_id_enqueued older_queue - older_enqueued name_queue name_enqueued - - and reachable_older_code_ids t code_id_queue code_id_enqueued older_queue - older_enqueued name_queue name_enqueued = - match Queue.take older_queue with - | exception Queue.Empty -> - reachable_code_ids t code_id_queue code_id_enqueued older_queue - older_enqueued name_queue name_enqueued - | src -> ( - match - Code_age_relation.get_older_version_of t.code_age_relation src - with - | None -> - reachable_older_code_ids t code_id_queue code_id_enqueued older_queue - older_enqueued name_queue name_enqueued - | Some dst -> - if Code_id.Set.mem dst older_enqueued - then ( - if Code_id.Set.mem dst code_id_enqueued - then - reachable_older_code_ids t code_id_queue code_id_enqueued - older_queue older_enqueued name_queue name_enqueued - else - let code_id_enqueued = Code_id.Set.add dst code_id_enqueued in - Queue.push dst code_id_queue; - reachable_older_code_ids t code_id_queue code_id_enqueued - older_queue older_enqueued name_queue name_enqueued) - else - let older_enqueued = Code_id.Set.add dst older_enqueued in - reachable_older_code_ids t code_id_queue code_id_enqueued - older_queue older_enqueued name_queue name_enqueued) - end - - let empty code_age_relation = - { code_age_relation; - name_to_name = Name.Map.empty; - name_to_code_id = Name.Map.empty; - code_id_to_name = Code_id.Map.empty; - code_id_to_code_id = Code_id.Map.empty; - unconditionally_used = Name.Set.empty; - code_id_unconditionally_used = Code_id.Set.empty - } - - let _print ppf - { name_to_name; - name_to_code_id; - code_id_to_name; - code_id_to_code_id; - code_age_relation; - unconditionally_used; - code_id_unconditionally_used - } = - Format.fprintf ppf - "@[(@[(code_age_relation@ %a)@]@ @[(name_to_name@ \ - %a)@]@ @[(name_to_code_id@ %a)@]@ @[(code_id_to_name@ \ - %a)@]@ @[(code_id_to_code_id@ %a)@]@ @[(unconditionally_used@ %a)@]@ @[(code_id_unconditionally_used@ \ - %a)@])@]" - Code_age_relation.print code_age_relation - (Name.Map.print Name.Set.print) - name_to_name - (Name.Map.print Code_id.Set.print) - name_to_code_id - (Code_id.Map.print Name.Set.print) - code_id_to_name - (Code_id.Map.print Code_id.Set.print) - code_id_to_code_id Name.Set.print unconditionally_used Code_id.Set.print - code_id_unconditionally_used - - (* *) - let fold_name_occurrences name_occurrences ~init ~names ~code_ids = - Name_occurrences.fold_names name_occurrences ~f:names - ~init:(code_ids init (Name_occurrences.code_ids name_occurrences)) - - (* Some auxiliary functions *) - let add_code_id_dep ~src ~(dst : Code_id.Set.t) ({ name_to_code_id; _ } as t) - = - let name_to_code_id = - Name.Map.update src - (function - | None -> if Code_id.Set.is_empty dst then None else Some dst - | Some old -> - Misc.fatal_errorf "Same name bound multiple times: %a -> %a, %a" - Name.print src Code_id.Set.print old Code_id.Set.print dst) - name_to_code_id - in - { t with name_to_code_id } - - let add_dependency ~src ~dst ({ name_to_name; _ } as t) = - let name_to_name = - Name.Map.update src - (function - | None -> Some (Name.Set.singleton dst) - | Some set -> Some (Name.Set.add dst set)) - name_to_name - in - { t with name_to_name } - - let add_name_used ({ unconditionally_used; _ } as t) v = - let unconditionally_used = Name.Set.add v unconditionally_used in - { t with unconditionally_used } - - let add_code_id_dependency ~src ~dst ({ code_id_to_name; _ } as t) = - let code_id_to_name = - Code_id.Map.update src - (function - | None -> Some (Name.Set.singleton dst) - | Some set -> Some (Name.Set.add dst set)) - code_id_to_name - in - { t with code_id_to_name } - - let add_code_id_to_code_id ~src ~dst ({ code_id_to_code_id; _ } as t) = - let code_id_to_code_id = - Code_id.Map.update src - (function - | None -> if Code_id.Set.is_empty dst then None else Some dst - | Some old -> - Misc.fatal_errorf "Same code_id bound multiple times: %a -> %a, %a" - Code_id.print src Code_id.Set.print old Code_id.Set.print dst) - code_id_to_code_id - in - { t with code_id_to_code_id } - - let add_var_used t v = add_name_used t (Name.var v) - - let add_name_occurrences name_occurrences - ({ unconditionally_used; code_id_unconditionally_used; _ } as t) = - let unconditionally_used = - Name_occurrences.fold_names name_occurrences - ~f:(fun set name -> Name.Set.add name set) - ~init:unconditionally_used - in - let code_id_unconditionally_used = - Code_id.Set.union - (Name_occurrences.code_ids name_occurrences) - code_id_unconditionally_used - in - { t with unconditionally_used; code_id_unconditionally_used } - - let add_continuation_info map ~return_continuation ~exn_continuation - ~used_value_slots _ - { apply_cont_args; - apply_result_conts; - used_in_handler; - bindings; - code_ids; - value_slots; - continuation = _; - params = _ - } t = - (* Add the vars used in the handler *) - let t = add_name_occurrences used_in_handler t in - (* Add the dependencies created by closures vars in envs *) - let is_value_slot_used = - match (used_value_slots : _ Or_unknown.t) with - | Unknown -> fun _ -> true - | Known used_value_slots -> - Name_occurrences.value_slot_is_used_or_imported used_value_slots - in - let t = - Value_slot.Map.fold - (fun value_slot map t -> - if not (is_value_slot_used value_slot) - then t - else - Name.Map.fold - (fun closure_name values_in_env t -> - Name_occurrences.fold_names - ~f:(fun t value_in_env -> - add_dependency ~src:closure_name ~dst:value_in_env t) - values_in_env ~init:t) - map t) - value_slots t - in - (* Add the vars of continuation used as function call return as used *) - let t = - Continuation.Set.fold - (fun k t -> - match Continuation.Map.find k map with - | elt -> List.fold_left add_var_used t elt.params - | exception Not_found -> - if Continuation.equal return_continuation k - || Continuation.equal exn_continuation k - then t - else - Misc.fatal_errorf "Continuation not found during Data_flow: %a@." - Continuation.print k) - apply_result_conts t - in - (* Build the graph of dependencies between names *) - let t = - Name.Map.fold - (fun src name_occurrences graph -> - fold_name_occurrences name_occurrences ~init:graph - ~names:(fun t dst -> add_dependency ~src ~dst t) - ~code_ids:(fun t dst -> add_code_id_dep ~src ~dst t)) - bindings t - in - let t = - Code_id.Map.fold - (fun src name_occurrences graph -> - fold_name_occurrences name_occurrences ~init:graph - ~names:(fun t dst -> add_code_id_dependency ~src ~dst t) - ~code_ids:(fun t dst -> add_code_id_to_code_id ~src ~dst t)) - code_ids t - in - (* Build the graph of dependencies between continuation parameters and - arguments. *) - Continuation.Map.fold - (fun k args t -> - if Continuation.equal return_continuation k - || Continuation.equal exn_continuation k - then - Numeric_types.Int.Map.fold - (fun _ name_occurrences t -> - add_name_occurrences name_occurrences t) - args t - else - let params = - match Continuation.Map.find k map with - | elt -> Array.of_list elt.params - | exception Not_found -> - Misc.fatal_errorf "Continuation not found during Data_flow: %a@." - Continuation.print k - in - Numeric_types.Int.Map.fold - (fun i name_occurrence t -> - (* Note on the direction of the edge: - - We later do a reachability analysis to compute the transitive - closure of the used variables. - - Therefore an edge from src to dst means: if src is used, then - dst is also used. - - Applied here, this means : if the param of a continuation is - used, then any argument provided for that param is also used. - The other way wouldn't make much sense. *) - let src = Name.var params.(i) in - Name_occurrences.fold_names name_occurrence ~init:t - ~f:(fun t dst -> add_dependency ~src ~dst t)) - args t) - apply_cont_args t - - let create ~return_continuation ~exn_continuation ~code_age_relation - ~used_value_slots map extra = - (* Build the dependencies using the regular params and args of - continuations, and the let-bindings in continuations handlers. *) - let t = - Continuation.Map.fold - (add_continuation_info map ~return_continuation ~exn_continuation - ~used_value_slots) - map (empty code_age_relation) - in - (* Take into account the extra params and args. *) - let t = - Continuation.Map.fold - (fun _ (extra_params_and_args : Continuation_extra_params_and_args.t) t -> - Apply_cont_rewrite_id.Map.fold - (fun _ extra_args t -> - List.fold_left2 - (fun t extra_param extra_arg -> - let src = Name.var (Bound_parameter.var extra_param) in - match - (extra_arg : Continuation_extra_params_and_args.Extra_arg.t) - with - | Already_in_scope simple -> - Name_occurrences.fold_names (Simple.free_names simple) - ~init:t ~f:(fun t dst -> add_dependency ~src ~dst t) - | New_let_binding (src', prim) -> - let src' = Name.var src' in - Name_occurrences.fold_names - (Flambda_primitive.free_names prim) - ~f:(fun t dst -> add_dependency ~src:src' ~dst t) - ~init:(add_dependency ~src ~dst:src' t) - | New_let_binding_with_named_args (_src', _prim_gen) -> - (* In this case, the free_vars present in the result of - _prim_gen are fresh (and a subset of the simples given to - _prim_gen) and generated when going up while creating a - wrapper continuation for the return of a function - application. - - In that case, the fresh parameters created for the - wrapper cannot introduce dependencies to other variables - or parameters of continuations. - - Therefore, in this case, the data_flow analysis is - incomplete, and we instead rely on the free_names - analysis to eliminate the extra_let binding if it is - unneeded. *) - t) - t - (Bound_parameters.to_list - (EPA.extra_params extra_params_and_args)) - extra_args) - (EPA.extra_args extra_params_and_args) - t) - extra t - in - t - - let required_names - ({ code_age_relation = _; - name_to_name = _; - name_to_code_id = _; - code_id_to_name = _; - code_id_to_code_id = _; - unconditionally_used; - code_id_unconditionally_used - } as t) = - let name_queue = Queue.create () in - Name.Set.iter (fun v -> Queue.push v name_queue) unconditionally_used; - let code_id_queue = Queue.create () in - Code_id.Set.iter - (fun v -> Queue.push v code_id_queue) - code_id_unconditionally_used; - Reachable.reachable_names t code_id_queue code_id_unconditionally_used - Code_id.Set.empty name_queue unconditionally_used -end - -(* Analysis *) -(* ******** *) - -let analyze ~return_continuation ~exn_continuation ~code_age_relation - ~used_value_slots { stack; map; extra } = - Profile.record_call ~accumulate:true "data_flow" (fun () -> - assert (stack = []); - let deps = - Dependency_graph.create map extra ~return_continuation ~exn_continuation - ~code_age_relation ~used_value_slots - in - (* Format.eprintf "/// graph@\n%a@\n@." Dependency_graph._print deps; *) - let result = Dependency_graph.required_names deps in - (* Format.eprintf "/// result@\n%a@\n@." _print_result result; *) - result) diff --git a/middle_end/flambda2/simplify/env/downwards_acc.ml b/middle_end/flambda2/simplify/env/downwards_acc.ml index 5a3df39c2ba..85aef34dfc3 100644 --- a/middle_end/flambda2/simplify/env/downwards_acc.ml +++ b/middle_end/flambda2/simplify/env/downwards_acc.ml @@ -25,7 +25,7 @@ type t = shareable_constants : Symbol.t Static_const.Map.t; used_value_slots : Name_occurrences.t; lifted_constants : LCS.t; - data_flow : Data_flow.t; + flow_acc : Flow.Acc.t; demoted_exn_handlers : Continuation.Set.t; code_ids_to_remember : Code_id.Set.t; slot_offsets : Slot_offsets.t Code_id.Map.t @@ -33,7 +33,7 @@ type t = let [@ocamlformat "disable"] print ppf { denv; continuation_uses_env; shareable_constants; used_value_slots; - lifted_constants; data_flow; demoted_exn_handlers; code_ids_to_remember; + lifted_constants; flow_acc; demoted_exn_handlers; code_ids_to_remember; slot_offsets } = Format.fprintf ppf "@[(\ @[(denv@ %a)@]@ \ @@ -41,7 +41,7 @@ let [@ocamlformat "disable"] print ppf @[(shareable_constants@ %a)@]@ \ @[(used_value_slots@ %a)@]@ \ @[(lifted_constant_state@ %a)@]@ \ - @[(data_flow@ %a)@]@ \ + @[(flow_acc@ %a)@]@ \ @[(demoted_exn_handlers@ %a)@]@ \ @[(code_ids_to_remember@ %a)@]@ \ @[(slot_offsets@ %a)@]\ @@ -51,7 +51,7 @@ let [@ocamlformat "disable"] print ppf (Static_const.Map.print Symbol.print) shareable_constants Name_occurrences.print used_value_slots LCS.print lifted_constants - Data_flow.print data_flow + Flow.Acc.print flow_acc Continuation.Set.print demoted_exn_handlers Code_id.Set.print code_ids_to_remember (Code_id.Map.print Slot_offsets.print) slot_offsets @@ -63,16 +63,16 @@ let create denv continuation_uses_env = shareable_constants = Static_const.Map.empty; used_value_slots = Name_occurrences.empty; lifted_constants = LCS.empty; - data_flow = Data_flow.empty; + flow_acc = Flow.Acc.empty (); demoted_exn_handlers = Continuation.Set.empty; code_ids_to_remember = Code_id.Set.empty } let denv t = t.denv -let data_flow t = t.data_flow +let flow_acc t = t.flow_acc -let[@inline always] map_data_flow t ~f = { t with data_flow = f t.data_flow } +let[@inline always] map_flow_acc t ~f = { t with flow_acc = f t.flow_acc } let[@inline always] map_denv t ~f = { t with denv = f t.denv } diff --git a/middle_end/flambda2/simplify/env/downwards_acc.mli b/middle_end/flambda2/simplify/env/downwards_acc.mli index 57eb0f789fb..0143560084f 100644 --- a/middle_end/flambda2/simplify/env/downwards_acc.mli +++ b/middle_end/flambda2/simplify/env/downwards_acc.mli @@ -32,10 +32,10 @@ val map_denv : t -> f:(Downwards_env.t -> Downwards_env.t) -> t val with_denv : t -> Downwards_env.t -> t (** Extract the dataflow analysis accumulator *) -val data_flow : t -> Data_flow.t +val flow_acc : t -> Flow.Acc.t (** Map the dataflow analysis accumulator of the given dacc. *) -val map_data_flow : t -> f:(Data_flow.t -> Data_flow.t) -> t +val map_flow_acc : t -> f:(Flow.Acc.t -> Flow.Acc.t) -> t include Continuation_uses_env_intf.S with type t := t diff --git a/middle_end/flambda2/simplify/env/downwards_env.ml b/middle_end/flambda2/simplify/env/downwards_env.ml index ef16ff1dea7..77b0670bec8 100644 --- a/middle_end/flambda2/simplify/env/downwards_env.ml +++ b/middle_end/flambda2/simplify/env/downwards_env.ml @@ -44,7 +44,8 @@ type t = closure_info : Closure_info.t; get_imported_code : unit -> Exported_code.t; all_code : Code.t Code_id.Map.t; - inlining_history_tracker : Inlining_history.Tracker.t + inlining_history_tracker : Inlining_history.Tracker.t; + loopify_state : Loopify_state.t } let print_debuginfo ppf dbg = @@ -60,6 +61,7 @@ let [@ocamlformat "disable"] print ppf { round; typing_env; do_not_rebuild_terms; closure_info; unit_toplevel_return_continuation; all_code; get_imported_code = _; inlining_history_tracker = _; + loopify_state } = Format.fprintf ppf "@[(\ @[(round@ %d)@]@ \ @@ -75,7 +77,8 @@ let [@ocamlformat "disable"] print ppf { round; typing_env; @[(cse@ @[%a@])@]@ \ @[(do_not_rebuild_terms@ %b)@]@ \ @[(closure_info@ %a)@]@ \ - @[(all_code@ %a)@]\ + @[(all_code@ %a)@]@ \ + @[(loopify_state@ %a)@]\ )@]" round TE.print typing_env @@ -91,6 +94,7 @@ let [@ocamlformat "disable"] print ppf { round; typing_env; do_not_rebuild_terms Closure_info.print closure_info (Code_id.Map.print Code.print) all_code + Loopify_state.print loopify_state let create ~round ~(resolver : resolver) ~(get_imported_names : get_imported_names) @@ -119,7 +123,8 @@ let create ~round ~(resolver : resolver) all_code = Code_id.Map.empty; get_imported_code; inlining_history_tracker = - Inlining_history.Tracker.empty (Compilation_unit.get_current_exn ()) + Inlining_history.Tracker.empty (Compilation_unit.get_current_exn ()); + loopify_state = Loopify_state.do_not_loopify } let all_code t = t.all_code @@ -178,7 +183,8 @@ let enter_set_of_closures closure_info = _; get_imported_code; all_code; - inlining_history_tracker + inlining_history_tracker; + loopify_state = _ } = { round; typing_env = TE.closure_env typing_env; @@ -195,7 +201,8 @@ let enter_set_of_closures closure_info = Closure_info.in_a_set_of_closures; get_imported_code; all_code; - inlining_history_tracker + inlining_history_tracker; + loopify_state = Loopify_state.do_not_loopify } let define_variable t var kind = @@ -420,18 +427,15 @@ let mem_code t id = let find_code_exn t id = match Code_id.Map.find id t.all_code with | code -> Code_or_metadata.create code - | exception Not_found -> ( - (* This [find_exn] call doesn't load any .cmx files, but in the majority of - cases will succeed. *) - match Exported_code.find_exn (t.get_imported_code ()) id with - | code_or_metadata -> code_or_metadata - | exception Not_found -> ( - (* In this case either the code ID isn't bound due to a compiler error or - we haven't yet loaded the relevant .cmx file. Make sure the .cmx is - loaded and try again. *) - match TE.resolver t.typing_env (Code_id.get_compilation_unit id) with - | None -> raise Not_found - | Some _typing_env -> Exported_code.find_exn (t.get_imported_code ()) id)) + | exception Not_found -> + (* We might have already loaded the metadata, from another unit that + references it. However we force loading of the corresponding .cmx to make + sure that we will have access to the actual code (assuming the .cmx isn't + missing). *) + let (_ : TE.Serializable.t option) = + TE.resolver t.typing_env (Code_id.get_compilation_unit id) + in + Exported_code.find_exn (t.get_imported_code ()) id let define_code t ~code_id ~code = if not @@ -478,10 +482,11 @@ let set_rebuild_terms t = { t with do_not_rebuild_terms = false } let are_rebuilding_terms t = Are_rebuilding_terms.of_bool (not t.do_not_rebuild_terms) -let enter_closure code_id ~return_continuation ~exn_continuation t = +let enter_closure code_id ~return_continuation ~exn_continuation ~my_closure t = { t with closure_info = Closure_info.in_a_closure code_id ~return_continuation ~exn_continuation + ~my_closure } let closure_info t = t.closure_info @@ -535,3 +540,7 @@ let generate_phantom_lets t = (* It would be a waste of time generating phantom lets when not rebuilding terms, since they have no effect on cost metrics. *) && Are_rebuilding_terms.are_rebuilding (are_rebuilding_terms t) + +let loopify_state t = t.loopify_state + +let set_loopify_state loopify_state t = { t with loopify_state } diff --git a/middle_end/flambda2/simplify/env/downwards_env.mli b/middle_end/flambda2/simplify/env/downwards_env.mli index e4107e2a2f0..578a8ecfc66 100644 --- a/middle_end/flambda2/simplify/env/downwards_env.mli +++ b/middle_end/flambda2/simplify/env/downwards_env.mli @@ -182,6 +182,7 @@ val enter_closure : Code_id.t -> return_continuation:Continuation.t -> exn_continuation:Continuation.t -> + my_closure:Variable.t -> t -> t @@ -201,3 +202,7 @@ val inlining_history_tracker : t -> Inlining_history.Tracker.t val set_inlining_history_tracker : Inlining_history.Tracker.t -> t -> t val relative_history : t -> Inlining_history.Relative.t + +val loopify_state : t -> Loopify_state.t + +val set_loopify_state : Loopify_state.t -> t -> t diff --git a/middle_end/flambda2/simplify/env/one_continuation_use.ml b/middle_end/flambda2/simplify/env/one_continuation_use.ml index 9b6b117216b..7a1062ab9b4 100644 --- a/middle_end/flambda2/simplify/env/one_continuation_use.ml +++ b/middle_end/flambda2/simplify/env/one_continuation_use.ml @@ -40,3 +40,8 @@ let use_kind t = t.kind let arg_types t = t.arg_types let env_at_use t = t.env + +let mark_non_inlinable t = + match t.kind with + | Inlinable -> { t with kind = Non_inlinable { escaping = false } } + | Non_inlinable _ -> t diff --git a/middle_end/flambda2/simplify/env/one_continuation_use.mli b/middle_end/flambda2/simplify/env/one_continuation_use.mli index 2c0e5d7b69f..65768550dae 100644 --- a/middle_end/flambda2/simplify/env/one_continuation_use.mli +++ b/middle_end/flambda2/simplify/env/one_continuation_use.mli @@ -35,3 +35,5 @@ val use_kind : t -> Continuation_use_kind.t val arg_types : t -> T.t list val env_at_use : t -> DE.t + +val mark_non_inlinable : t -> t diff --git a/middle_end/flambda2/simplify/env/upwards_acc.ml b/middle_end/flambda2/simplify/env/upwards_acc.ml index 235ac8c5efc..7228e5328d9 100644 --- a/middle_end/flambda2/simplify/env/upwards_acc.ml +++ b/middle_end/flambda2/simplify/env/upwards_acc.ml @@ -33,18 +33,19 @@ type t = cost_metrics : Cost_metrics.t; are_rebuilding_terms : ART.t; generate_phantom_lets : bool; - required_names : Name.Set.t; - reachable_code_ids : Data_flow.Reachable_code_ids.t Or_unknown.t; demoted_exn_handlers : Continuation.Set.t; - slot_offsets : Slot_offsets.t Or_unknown.t + slot_offsets : Slot_offsets.t Or_unknown.t; + flow_result : Flow_types.Flow_result.t; + resimplify : bool } let [@ocamlformat "disable"] print ppf { uenv; creation_dacc = _; code_age_relation; lifted_constants; name_occurrences; used_value_slots; all_code = _; shareable_constants; cost_metrics; are_rebuilding_terms; - generate_phantom_lets; required_names; reachable_code_ids; - demoted_exn_handlers; slot_offsets; } = + generate_phantom_lets; + demoted_exn_handlers; slot_offsets; flow_result; resimplify; + } = Format.fprintf ppf "@[(\ @[(uenv@ %a)@]@ \ @[(code_age_relation@ %a)@]@ \ @@ -55,10 +56,10 @@ let [@ocamlformat "disable"] print ppf @[(cost_metrics@ %a)@]@ \ @[(are_rebuilding_terms@ %a)@]@ \ @[(generate_phantom_lets@ %b)@]@ \ - @[(required_name@ %a)@]@ \ - @[(reachable_code_ids@ %a)@]@ \ @[(demoted_exn_handlers@ %a)@]@ \ - @[(slot_offsets@ %a@)@]\ + @[(slot_offsets@ %a@)@]@ \ + @[(flow_result@ %a)@]\ + %a\ )@]" UE.print uenv Code_age_relation.print code_age_relation @@ -69,12 +70,15 @@ let [@ocamlformat "disable"] print ppf Cost_metrics.print cost_metrics ART.print are_rebuilding_terms generate_phantom_lets - Name.Set.print required_names - (Or_unknown.print Data_flow.Reachable_code_ids.print) reachable_code_ids Continuation.Set.print demoted_exn_handlers (Or_unknown.print Slot_offsets.print) slot_offsets + Flow_types.Flow_result.print flow_result + (if resimplify then + (fun ppf () -> Format.fprintf ppf "@ @[(should_resimplify)@]") + else + (fun _ppf () -> ())) () -let create ~required_names ~reachable_code_ids ~compute_slot_offsets uenv dacc = +let create ~flow_result ~compute_slot_offsets uenv dacc = let are_rebuilding_terms = DE.are_rebuilding_terms (DA.denv dacc) in let generate_phantom_lets = DE.generate_phantom_lets (DA.denv dacc) in let slot_offsets : _ Or_unknown.t = @@ -100,10 +104,10 @@ let create ~required_names ~reachable_code_ids ~compute_slot_offsets uenv dacc = cost_metrics = Cost_metrics.zero; are_rebuilding_terms; generate_phantom_lets; - required_names; - reachable_code_ids; demoted_exn_handlers = DA.demoted_exn_handlers dacc; - slot_offsets + slot_offsets; + flow_result; + resimplify = false } let creation_dacc t = t.creation_dacc @@ -117,10 +121,6 @@ let lifted_constants t = t.lifted_constants let get_and_clear_lifted_constants t = { t with lifted_constants = LCS.empty }, t.lifted_constants -let required_names t = t.required_names - -let reachable_code_ids t = t.reachable_code_ids - let cost_metrics t = t.cost_metrics let are_rebuilding_terms t = t.are_rebuilding_terms @@ -198,3 +198,15 @@ let is_demoted_exn_handler t cont = let slot_offsets t = t.slot_offsets let with_slot_offsets t slot_offsets = { t with slot_offsets } + +let required_names t = t.flow_result.data_flow_result.required_names + +let reachable_code_ids t = t.flow_result.data_flow_result.reachable_code_ids + +let continuation_param_aliases t = t.flow_result.aliases_result + +let mutable_unboxing_result t = t.flow_result.mutable_unboxing_result + +let set_resimplify t = { t with resimplify = true } + +let resimplify t = t.resimplify diff --git a/middle_end/flambda2/simplify/env/upwards_acc.mli b/middle_end/flambda2/simplify/env/upwards_acc.mli index 2ffa78be0c9..af7be10bead 100644 --- a/middle_end/flambda2/simplify/env/upwards_acc.mli +++ b/middle_end/flambda2/simplify/env/upwards_acc.mli @@ -20,8 +20,7 @@ type t val print : Format.formatter -> t -> unit val create : - required_names:Name.Set.t -> - reachable_code_ids:Data_flow.Reachable_code_ids.t Or_unknown.t -> + flow_result:Flow_types.Flow_result.t -> compute_slot_offsets:bool -> Upwards_env.t -> Downwards_acc.t -> @@ -36,10 +35,6 @@ val cost_metrics : t -> Cost_metrics.t val code_age_relation : t -> Code_age_relation.t -val required_names : t -> Name.Set.t - -val reachable_code_ids : t -> Data_flow.Reachable_code_ids.t Or_unknown.t - (** Return the lifted constants that still need to be placed (i.e. have [Let]-expressions made for them) on the upwards traversal. *) val lifted_constants : t -> Lifted_constant_state.t @@ -102,3 +97,17 @@ val is_demoted_exn_handler : t -> Continuation.t -> bool val slot_offsets : t -> Slot_offsets.t Or_unknown.t val with_slot_offsets : t -> Slot_offsets.t Or_unknown.t -> t + +(* Functions to extract specific fields of [flow_result]. *) + +val required_names : t -> Name.Set.t + +val reachable_code_ids : t -> Flow_types.Reachable_code_ids.t Or_unknown.t + +val continuation_param_aliases : t -> Flow_types.Alias_result.t + +val mutable_unboxing_result : t -> Flow_types.Mutable_unboxing_result.t + +val set_resimplify : t -> t + +val resimplify : t -> bool diff --git a/middle_end/flambda2/simplify/env/upwards_env.ml b/middle_end/flambda2/simplify/env/upwards_env.ml index 19a21d10c60..0de0f878425 100644 --- a/middle_end/flambda2/simplify/env/upwards_env.ml +++ b/middle_end/flambda2/simplify/env/upwards_env.ml @@ -148,12 +148,17 @@ let add_apply_cont_rewrite t cont rewrite = in { t with apply_cont_rewrites } +let replace_apply_cont_rewrite t cont rewrite = + if not (Continuation.Map.mem cont t.apply_cont_rewrites) + then + Misc.fatal_errorf "Must redefine [Apply_cont_rewrite] for %a" + Continuation.print cont; + let apply_cont_rewrites = + Continuation.Map.add cont rewrite t.apply_cont_rewrites + in + { t with apply_cont_rewrites } + let find_apply_cont_rewrite t cont = match Continuation.Map.find cont t.apply_cont_rewrites with | exception Not_found -> None | rewrite -> Some rewrite - -let delete_apply_cont_rewrite t cont = - { t with - apply_cont_rewrites = Continuation.Map.remove cont t.apply_cont_rewrites - } diff --git a/middle_end/flambda2/simplify/env/upwards_env.mli b/middle_end/flambda2/simplify/env/upwards_env.mli index 5d93cf3624c..b69c4156c7e 100644 --- a/middle_end/flambda2/simplify/env/upwards_env.mli +++ b/middle_end/flambda2/simplify/env/upwards_env.mli @@ -64,6 +64,7 @@ val resolve_exn_continuation_aliases : val add_apply_cont_rewrite : t -> Continuation.t -> Apply_cont_rewrite.t -> t -val find_apply_cont_rewrite : t -> Continuation.t -> Apply_cont_rewrite.t option +val replace_apply_cont_rewrite : + t -> Continuation.t -> Apply_cont_rewrite.t -> t -val delete_apply_cont_rewrite : t -> Continuation.t -> t +val find_apply_cont_rewrite : t -> Continuation.t -> Apply_cont_rewrite.t option diff --git a/middle_end/flambda2/simplify/expr_builder.ml b/middle_end/flambda2/simplify/expr_builder.ml index 17c1328b868..dec3ac434ca 100644 --- a/middle_end/flambda2/simplify/expr_builder.ml +++ b/middle_end/flambda2/simplify/expr_builder.ml @@ -231,6 +231,14 @@ let create_let uacc (bound_vars : Bound_pattern.t) (defining_expr : Named.t) uacc, let_creation_result ) +let create_let_binding uacc bound_vars defining_expr + ~free_names_of_defining_expr ~body ~cost_metrics_of_defining_expr = + let re, uacc, _ = + create_let uacc bound_vars defining_expr ~free_names_of_defining_expr ~body + ~cost_metrics_of_defining_expr + in + re, uacc + let create_coerced_singleton_let uacc var defining_expr ~coercion_from_defining_expr_to_var ~free_names_of_defining_expr ~body ~cost_metrics_of_defining_expr = @@ -360,8 +368,7 @@ let create_raw_let_symbol uacc bound_static static_consts ~body = UA.with_name_occurrences uacc ~name_occurrences:free_names_of_let |> UA.add_cost_metrics (Cost_metrics.increase_due_to_let_expr - ~is_phantom: - false + ~is_phantom:false (* Static consts always have zero cost metrics at present. *) ~cost_metrics_of_defining_expr:Cost_metrics.zero) in @@ -521,8 +528,9 @@ let create_let_symbols uacc lifted_constant ~body = } in Binary (Block_load (block_access_kind, Immutable), symbol, index) - | Project_value_slot { project_from; value_slot } -> - Unary (Project_value_slot { project_from; value_slot }, symbol) + | Project_value_slot { project_from; value_slot; kind } -> + Unary + (Project_value_slot { project_from; value_slot; kind }, symbol) in ( Named.create_prim prim Debuginfo.none, coercion_from_proj_to_var, diff --git a/middle_end/flambda2/simplify/expr_builder.mli b/middle_end/flambda2/simplify/expr_builder.mli index 0ab151916be..2157fe31705 100644 --- a/middle_end/flambda2/simplify/expr_builder.mli +++ b/middle_end/flambda2/simplify/expr_builder.mli @@ -25,6 +25,15 @@ open! Flambda.Import +val create_let_binding : + Upwards_acc.t -> + Bound_pattern.t -> + Named.t -> + free_names_of_defining_expr:Name_occurrences.t -> + body:Rebuilt_expr.t -> + cost_metrics_of_defining_expr:Cost_metrics.t -> + Rebuilt_expr.t * Upwards_acc.t + (** Create [Let] binding(s) around a given body. (The type of this function prevents it from being used to create "let symbol" bindings; use the other functions in this module instead.) Bindings will be elided if they are diff --git a/middle_end/flambda2/simplify/flow/control_flow_graph.ml b/middle_end/flambda2/simplify/flow/control_flow_graph.ml new file mode 100644 index 00000000000..28c49ff0da2 --- /dev/null +++ b/middle_end/flambda2/simplify/flow/control_flow_graph.ml @@ -0,0 +1,425 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart and Guillaume Bury, OCamlPro *) +(* *) +(* Copyright 2021--2021 OCamlPro SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module T = Flow_types +module G = Strongly_connected_components.Make (Continuation) + +type t = + { dummy_toplevel_cont : Continuation.t; + callers : G.directed_graph; + parents : Continuation.t Continuation.Map.t; + children : Continuation.Set.t Continuation.Map.t + } + +let create ~dummy_toplevel_cont { T.Acc.map; _ } = + let parents = + Continuation.Map.filter_map + (fun _ (elt : T.Continuation_info.t) -> elt.parent_continuation) + map + in + let children = + Continuation.Map.fold + (fun k parent acc -> + Continuation.Map.update parent + (function + | None -> Some (Continuation.Set.singleton k) + | Some set -> Some (Continuation.Set.add k set)) + acc) + parents Continuation.Map.empty + in + let callers = + Continuation.Map.fold + (fun caller (elt : T.Continuation_info.t) acc -> + let acc = + Continuation.Map.merge + (fun _callee acc args -> + match acc, args with + | None, None -> assert false + | Some set, None -> Some set + | None, Some _ -> Some (Continuation.Set.singleton caller) + | Some set, Some _ -> Some (Continuation.Set.add caller set)) + acc elt.apply_cont_args + in + acc) + map + (Continuation.Map.singleton dummy_toplevel_cont Continuation.Set.empty) + in + { dummy_toplevel_cont; callers; parents; children } + +(* This does not need to be tail-rec as other parts of flambda2 are already not + tail-rec in the number of nested continuations. *) +let map_fold_on_children { children; dummy_toplevel_cont; _ } f acc = + let rec aux k acc = + let acc, to_add = f k acc in + let map = Continuation.Map.singleton k to_add in + match Continuation.Map.find k children with + | exception Not_found -> map + | s -> + Continuation.Set.fold + (fun child map -> Continuation.Map.disjoint_union map (aux child acc)) + s map + in + aux dummy_toplevel_cont acc + +let compute_available_variables ~(source_info : T.Acc.t) t = + map_fold_on_children t + (fun k acc -> + let elt = Continuation.Map.find k source_info.map in + let extra_vars = + match Continuation.Map.find k source_info.extra with + | exception Not_found -> Variable.Set.empty + | epa -> + let extra_params = + Continuation_extra_params_and_args.extra_params epa + in + Bound_parameters.var_set extra_params + in + let acc = + Variable.Set.union + (Variable.Set.union acc (Bound_parameters.var_set elt.params)) + extra_vars + in + acc, acc) + Variable.Set.empty + +let compute_added_extra_args added_extra_args t = + map_fold_on_children t + (fun k available -> + ( Variable.Set.union (Continuation.Map.find k added_extra_args) available, + available )) + Variable.Set.empty + +let fixpoint t ~init ~f = + let components = G.connected_components_sorted_from_roots_to_leaf t.callers in + let res = + Array.fold_left + (fun res component -> + match component with + | G.No_loop callee -> ( + match Continuation.Map.find callee res with + | exception Not_found -> res + | callee_set -> + Continuation.Set.fold + (fun caller res -> + let caller_set = Continuation.Map.find caller res in + let caller_new_set = + f ~caller ~caller_set ~callee ~callee_set + in + Continuation.Map.add caller caller_new_set res) + (Continuation.Map.find callee t.callers) + res) + | G.Has_loop conts -> + let q = Queue.create () in + List.iter (fun k -> Queue.add k q) conts; + let q_s = ref (Continuation.Set.of_list conts) in + let cur = ref res in + while not (Queue.is_empty q) do + let callee = Queue.pop q in + q_s := Continuation.Set.remove callee !q_s; + let callee_set = Continuation.Map.find callee !cur in + let callers = + match Continuation.Map.find callee t.callers with + | exception Not_found -> + Misc.fatal_errorf "Callers not found for: %a" Continuation.print + callee + | callers -> callers + in + Continuation.Set.iter + (fun caller -> + let caller_set = Continuation.Map.find caller !cur in + let caller_new_set = + f ~caller ~caller_set ~callee ~callee_set + in + if not (Variable.Set.equal caller_set caller_new_set) + then ( + cur := Continuation.Map.add caller caller_new_set !cur; + if not (Continuation.Set.mem caller !q_s) + then ( + Queue.add caller q; + q_s := Continuation.Set.add caller !q_s))) + callers + done; + !cur) + init components + in + res + +let extra_args_for_aliases_overapproximation ~required_names + ~(source_info : T.Acc.t) ~unboxed_blocks doms t = + let available_variables = compute_available_variables ~source_info t in + let remove_vars_in_scope_of k var_set = + let elt : T.Continuation_info.t = Continuation.Map.find k source_info.map in + let res = + Variable.Set.diff var_set (Continuation.Map.find k available_variables) + in + Variable.Set.diff res elt.defined + in + (* We remove aliases to unboxed blocks, so that they won't try to be passed as + extra args. These would normally be deleted, except in recursive + continuations, where they would still be added and cause the code to + fail. *) + let init = + Continuation.Map.mapi + (fun k elt -> + let s = + List.fold_left + (fun acc param -> + match Variable.Map.find param doms with + | exception Not_found -> + if Name.Set.mem (Name.var param) required_names + then + Misc.fatal_errorf "Dom not found for: %a@." Variable.print + param + else acc + | dom -> + if Variable.equal param dom + || Variable.Set.mem dom unboxed_blocks + then acc + else Variable.Set.add dom acc) + Variable.Set.empty + (Bound_parameters.vars elt.T.Continuation_info.params) + in + let s = remove_vars_in_scope_of k s in + s) + source_info.map + in + let added_extra_args = + fixpoint t ~init + ~f:(fun + ~caller + ~caller_set:caller_aliases_needed + ~callee:_ + ~callee_set:callee_aliases_needed + -> + Variable.Set.union caller_aliases_needed + (remove_vars_in_scope_of caller callee_aliases_needed)) + in + added_extra_args + +let minimize_extra_args_for_one_continuation ~(source_info : T.Acc.t) + ~unboxed_blocks ~available_added_extra_args doms k aliases_needed = + let available = Continuation.Map.find k available_added_extra_args in + let extra_args_for_aliases = Variable.Set.diff aliases_needed available in + let elt = Continuation.Map.find k source_info.map in + let exception_handler_first_param : Variable.t option = + if elt.is_exn_handler + then + match Bound_parameters.to_list elt.params with + | [] -> + Misc.fatal_errorf + "exception handler continuation %a must have at least one parameter" + Continuation.print k + | first :: _ -> Some (Bound_parameter.var first) + else None + in + (* For exception continuations the first parameter cannot be removed, so + instead of rewriting the parameter to its dominator, we instead rewrite + every alias to the exception parameter *) + let extra_args_for_aliases, exception_handler_first_param_aliased = + match exception_handler_first_param with + | None -> extra_args_for_aliases, None + | Some exception_param -> ( + match Variable.Map.find exception_param doms with + | exception Not_found -> extra_args_for_aliases, None + | alias -> + if Variable.equal exception_param alias + then extra_args_for_aliases, None + else + ( Variable.Set.remove alias extra_args_for_aliases, + Some (alias, exception_param) )) + in + let removed_aliased_params_and_extra_params, lets_to_introduce = + List.fold_left + (fun (removed, lets_to_introduce) param -> + let default alias = + let removed = Variable.Set.add param removed in + let lets_to_introduce = + if Variable.Set.mem alias unboxed_blocks + then lets_to_introduce + else Variable.Map.add param alias lets_to_introduce + in + removed, lets_to_introduce + in + match Variable.Map.find param doms with + | exception Not_found -> removed, lets_to_introduce + | alias -> ( + if Variable.equal param alias + then removed, lets_to_introduce + else + match exception_handler_first_param_aliased with + | None -> default alias + | Some (aliased_to, exception_param) -> + let is_first_exception_param = + Variable.equal exception_param param + in + if is_first_exception_param + then removed, lets_to_introduce + else if Variable.equal alias aliased_to + then default exception_param + else default alias)) + (Variable.Set.empty, Variable.Map.empty) + (Bound_parameters.vars elt.params) + in + let recursive_continuation_wrapper : + T.Continuation_param_aliases.recursive_continuation_wrapper = + if elt.recursive && not (Variable.Set.is_empty extra_args_for_aliases) + then Wrapper_needed + else No_wrapper + in + let res : T.Continuation_param_aliases.t = + { extra_args_for_aliases; + removed_aliased_params_and_extra_params; + lets_to_introduce; + recursive_continuation_wrapper + } + in + res + +let minimize_extra_args_for_aliases ~source_info ~unboxed_blocks doms + added_extra_args t = + let available_added_extra_args = + compute_added_extra_args added_extra_args t + in + Continuation.Map.mapi + (minimize_extra_args_for_one_continuation ~source_info ~unboxed_blocks + ~available_added_extra_args doms) + added_extra_args + +let compute_continuation_extra_args_for_aliases ~speculative ~required_names + ~source_info ~unboxed_blocks doms t : + T.Continuation_param_aliases.t Continuation.Map.t = + let added_extra_args = + extra_args_for_aliases_overapproximation ~required_names ~source_info + ~unboxed_blocks doms t + in + let extra_args_for_toplevel_cont = + Continuation.Map.find t.dummy_toplevel_cont added_extra_args + in + (* When doing speculative inlining, the flow analysis only has access to the + inlined body of the function being (speculatively) inlined. Thus, it is + possible for a canonical alias to be defined outside the inliend body (a + typical occurrence would be a String length compute before the call of the + inlined funciton, but shared with the uses inside the funciton by the cse). + + Note that while this is true for aliases, we do not need a similar + mechanism for mutable unboxing, since when doing mutable unboxing, we + require that we have seen the creation of the block. *) + if (not speculative) + && not (Variable.Set.is_empty extra_args_for_toplevel_cont) + then + Misc.fatal_errorf + "ERROR:@\n\ + Toplevel continuation cannot have needed extra argument for aliases: \ + %a@." + Variable.Set.print extra_args_for_toplevel_cont; + let extra_args_for_aliases = + minimize_extra_args_for_aliases ~source_info ~unboxed_blocks doms + added_extra_args t + in + extra_args_for_aliases + +module Dot = struct + let node_id ~ctx ppf (cont : Continuation.t) = + Format.fprintf ppf "node_%d_%d" ctx (cont :> int) + + let node ?(extra_args = Variable.Set.empty) ?(info = "") ~df ~pp_node ~ctx () + ppf cont = + let params, shape = + match Continuation.Map.find cont df.T.Acc.map with + | exception Not_found -> "[ none ]", "" + | elt -> + let params = + Format.asprintf "[%a]" + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf ", ") + Variable.print) + (Bound_parameters.vars elt.params) + in + let shape = if elt.recursive then "shape=record" else "" in + params, shape + in + Format.fprintf ppf "%a [label=\"%a %s %s%s\" %s %s];@\n" (node_id ~ctx) cont + Continuation.print cont params + (String.map + (function '{' -> '[' | '}' -> ']' | c -> c) + (Format.asprintf "%a" Variable.Set.print extra_args)) + (String.map + (function '{' -> '[' | '}' -> ']' | c -> c) + (Format.asprintf "%a" pp_node cont)) + shape info + + let nodes ~df ~ctx ~return_continuation ~exn_continuation + ~continuation_parameters ~pp_node ppf cont_map = + Continuation.Set.iter + (fun cont -> + let extra_args = + Option.map + (fun continuation_parameters -> + continuation_parameters + .T.Continuation_param_aliases.extra_args_for_aliases) + (Continuation.Map.find_opt cont continuation_parameters) + in + let info = + if Continuation.equal return_continuation cont + then "color=blue" + else if Continuation.equal exn_continuation cont + then "color=red" + else "" + in + node ?extra_args ~df ~ctx ~info ~pp_node () ppf cont) + cont_map + + let edge ~ctx ~color ppf src dst = + Format.fprintf ppf "%a -> %a [color=\"%s\"];@\n" (node_id ~ctx) dst + (node_id ~ctx) src color + + let edges ~ctx ~color ppf edge_map = + Continuation.Map.iter + (fun src dst_set -> + Continuation.Set.iter (fun dst -> edge ~ctx ~color ppf src dst) dst_set) + edge_map + + let edges' ~ctx ~color ppf edge_map = + Continuation.Map.iter (fun src dst -> edge ~ctx ~color ppf src dst) edge_map + + let print ~ctx ~df ~print_name ppf ~return_continuation ~exn_continuation + ?(pp_node = fun _ppf _cont -> ()) ~continuation_parameters (t : t) = + let dummy_toplevel_cont = t.dummy_toplevel_cont in + let all_conts = + Continuation.Map.fold + (fun cont callers acc -> + Continuation.Set.add cont (Continuation.Set.union callers acc)) + t.callers + (Continuation.Set.of_list + [dummy_toplevel_cont; return_continuation; exn_continuation]) + in + let all_conts = + Continuation.Map.fold + (fun cont _parent acc -> Continuation.Set.add cont acc) + t.parents all_conts + in + Flambda_colours.without_colours ~f:(fun () -> + Format.fprintf ppf + "subgraph cluster_%d { label=\"%s\";@\n%a%a@\n%a@\n%a@\n}@." ctx + print_name + (node ~df ~ctx ~pp_node ()) + dummy_toplevel_cont + (nodes ~df ~return_continuation ~exn_continuation ~ctx + ~continuation_parameters ~pp_node) + all_conts + (edges' ~ctx ~color:"green") + t.parents + (edges ~ctx ~color:"black") + t.callers) +end diff --git a/middle_end/flambda2/simplify/flow/control_flow_graph.mli b/middle_end/flambda2/simplify/flow/control_flow_graph.mli new file mode 100644 index 00000000000..32d7dc35ac4 --- /dev/null +++ b/middle_end/flambda2/simplify/flow/control_flow_graph.mli @@ -0,0 +1,61 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart and Guillaume Bury, OCamlPro *) +(* *) +(* Copyright 2021--2021 OCamlPro SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** An internal type for the data_flow graph *) +type t = + { dummy_toplevel_cont : Continuation.t; + callers : Continuation.Set.t Continuation.Map.t; + parents : Continuation.t Continuation.Map.t; + children : Continuation.Set.t Continuation.Map.t + } + +(** Create the data flow graph *) +val create : dummy_toplevel_cont:Continuation.t -> Flow_types.Acc.t -> t + +val fixpoint : + t -> + init:Variable.Set.t Continuation.Map.t -> + f: + (caller:Continuation.t -> + caller_set:Variable.Set.t -> + callee:Continuation.t -> + callee_set:Variable.Set.t -> + Variable.Set.t) -> + Variable.Set.t Continuation.Map.t + +(** Run the required names analysis *) +val compute_continuation_extra_args_for_aliases : + speculative:bool -> + required_names:Name.Set.t -> + source_info:Flow_types.Acc.t -> + unboxed_blocks:Variable.Set.t -> + Variable.t Variable.Map.t -> + t -> + Flow_types.Continuation_param_aliases.t Continuation.Map.t + +module Dot : sig + (** Printing function *) + val print : + ctx:int -> + df:Flow_types.Acc.t -> + print_name:string -> + Format.formatter -> + return_continuation:Continuation.t -> + exn_continuation:Continuation.t -> + ?pp_node:(Format.formatter -> Continuation.t -> unit) -> + continuation_parameters: + Flow_types.Continuation_param_aliases.t Continuation.Map.t -> + t -> + unit +end diff --git a/middle_end/flambda2/simplify/flow/data_flow_graph.ml b/middle_end/flambda2/simplify/flow/data_flow_graph.ml new file mode 100644 index 00000000000..8d9caac51ad --- /dev/null +++ b/middle_end/flambda2/simplify/flow/data_flow_graph.ml @@ -0,0 +1,449 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart and Guillaume Bury, OCamlPro *) +(* *) +(* Copyright 2021--2021 OCamlPro SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module T = Flow_types + +type t = + { code_age_relation : Code_age_relation.t; + name_to_name : Name.Set.t Name.Map.t; + name_to_code_id : Code_id.Set.t Name.Map.t; + code_id_to_name : Name.Set.t Code_id.Map.t; + code_id_to_code_id : Code_id.Set.t Code_id.Map.t; + unconditionally_used : Name.Set.t; + code_id_unconditionally_used : Code_id.Set.t; + is_toplevel : bool + } + +module Reachable = struct + module Edge (Src_map : Container_types.Map) (Dst_set : Container_types.Set) = + struct + type src = Src_map.key + + type dst = Dst_set.elt + + let push ~(src : src) (enqueued : Dst_set.t) (queue : dst Queue.t) + (graph : Dst_set.t Src_map.t) : Dst_set.t = + let neighbours = + match Src_map.find src graph with + | exception Not_found -> Dst_set.empty + | set -> set + in + let new_neighbours = Dst_set.diff neighbours enqueued in + Dst_set.iter (fun dst -> Queue.push dst queue) new_neighbours; + Dst_set.union enqueued new_neighbours + end + [@@inline] + (* TODO check that this applied here *) + + module Name_Name_Edge = Edge (Name.Map) (Name.Set) + module Name_Code_id_Edge = Edge (Name.Map) (Code_id.Set) + module Code_id_Name_Edge = Edge (Code_id.Map) (Name.Set) + module Code_id_Code_id_Edge = Edge (Code_id.Map) (Code_id.Set) + + (* breadth-first reachability analysis. *) + let rec reachable_names t code_id_queue code_id_enqueued older_enqueued + name_queue name_enqueued = + match Queue.take name_queue with + | exception Queue.Empty -> + if t.is_toplevel + then + if Queue.is_empty code_id_queue + then + T.Data_flow_result. + { required_names = name_enqueued; + reachable_code_ids = + Known + T.Reachable_code_ids. + { live_code_ids = code_id_enqueued; + ancestors_of_live_code_ids = older_enqueued + } + } + else + reachable_code_ids t code_id_queue code_id_enqueued (Queue.create ()) + older_enqueued name_queue name_enqueued + else + T.Data_flow_result. + { required_names = name_enqueued; reachable_code_ids = Unknown } + | src -> + let name_enqueued = + Name_Name_Edge.push ~src name_enqueued name_queue t.name_to_name + in + let code_id_enqueued = + Name_Code_id_Edge.push ~src code_id_enqueued code_id_queue + t.name_to_code_id + in + reachable_names t code_id_queue code_id_enqueued older_enqueued name_queue + name_enqueued + + and reachable_code_ids t code_id_queue code_id_enqueued older_queue + older_enqueued name_queue name_enqueued = + match Queue.take code_id_queue with + | exception Queue.Empty -> + if Queue.is_empty older_queue + then + reachable_names t code_id_queue code_id_enqueued older_enqueued + name_queue name_enqueued + else + reachable_older_code_ids t code_id_queue code_id_enqueued older_queue + older_enqueued name_queue name_enqueued + | src -> + let name_enqueued = + Code_id_Name_Edge.push ~src name_enqueued name_queue t.code_id_to_name + in + let code_id_enqueued = + Code_id_Code_id_Edge.push ~src code_id_enqueued code_id_queue + t.code_id_to_code_id + in + let older_enqueued = + if Code_id.Set.mem src older_enqueued + then older_enqueued + else ( + Queue.push src older_queue; + Code_id.Set.add src older_enqueued) + in + reachable_code_ids t code_id_queue code_id_enqueued older_queue + older_enqueued name_queue name_enqueued + + and reachable_older_code_ids t code_id_queue code_id_enqueued older_queue + older_enqueued name_queue name_enqueued = + match Queue.take older_queue with + | exception Queue.Empty -> + reachable_code_ids t code_id_queue code_id_enqueued older_queue + older_enqueued name_queue name_enqueued + | src -> ( + match Code_age_relation.get_older_version_of t.code_age_relation src with + | None -> + reachable_older_code_ids t code_id_queue code_id_enqueued older_queue + older_enqueued name_queue name_enqueued + | Some dst -> + if Code_id.Set.mem dst older_enqueued + then ( + if Code_id.Set.mem dst code_id_enqueued + then + reachable_older_code_ids t code_id_queue code_id_enqueued + older_queue older_enqueued name_queue name_enqueued + else + let code_id_enqueued = Code_id.Set.add dst code_id_enqueued in + Queue.push dst code_id_queue; + reachable_older_code_ids t code_id_queue code_id_enqueued + older_queue older_enqueued name_queue name_enqueued) + else + let older_enqueued = Code_id.Set.add dst older_enqueued in + reachable_older_code_ids t code_id_queue code_id_enqueued older_queue + older_enqueued name_queue name_enqueued) +end + +let empty code_age_relation is_toplevel = + { code_age_relation; + is_toplevel; + name_to_name = Name.Map.empty; + name_to_code_id = Name.Map.empty; + code_id_to_name = Code_id.Map.empty; + code_id_to_code_id = Code_id.Map.empty; + unconditionally_used = Name.Set.empty; + code_id_unconditionally_used = Code_id.Set.empty + } + +let print ppf + { is_toplevel; + name_to_name; + name_to_code_id; + code_id_to_name; + code_id_to_code_id; + code_age_relation; + unconditionally_used; + code_id_unconditionally_used + } = + Format.fprintf ppf + "@[(@[(is_toplevel %b)@]@ @[(code_age_relation@ \ + %a)@]@ @[(name_to_name@ %a)@]@ @[(name_to_code_id@ %a)@]@ \ + @[(code_id_to_name@ %a)@]@ @[(code_id_to_code_id@ %a)@]@ \ + @[(unconditionally_used@ %a)@]@ @[(code_id_unconditionally_used@ %a)@])@]" + is_toplevel Code_age_relation.print code_age_relation + (Name.Map.print Name.Set.print) + name_to_name + (Name.Map.print Code_id.Set.print) + name_to_code_id + (Code_id.Map.print Name.Set.print) + code_id_to_name + (Code_id.Map.print Code_id.Set.print) + code_id_to_code_id Name.Set.print unconditionally_used Code_id.Set.print + code_id_unconditionally_used + +(* *) +let fold_name_occurrences name_occurrences ~init ~names ~code_ids = + Name_occurrences.fold_names name_occurrences ~f:names + ~init:(code_ids init (Name_occurrences.code_ids name_occurrences)) + +(* Some auxiliary functions *) +let add_code_id_dep ~src ~(dst : Code_id.Set.t) ({ name_to_code_id; _ } as t) = + let name_to_code_id = + Name.Map.update src + (function + | None -> if Code_id.Set.is_empty dst then None else Some dst + | Some old -> + Misc.fatal_errorf "Same name bound multiple times: %a -> %a, %a" + Name.print src Code_id.Set.print old Code_id.Set.print dst) + name_to_code_id + in + { t with name_to_code_id } + +let add_dependency ~src ~dst ({ name_to_name; _ } as t) = + let name_to_name = + Name.Map.update src + (function + | None -> Some (Name.Set.singleton dst) + | Some set -> Some (Name.Set.add dst set)) + name_to_name + in + { t with name_to_name } + +let add_code_id_dependency ~src ~dst ({ code_id_to_name; _ } as t) = + let code_id_to_name = + Code_id.Map.update src + (function + | None -> Some (Name.Set.singleton dst) + | Some set -> Some (Name.Set.add dst set)) + code_id_to_name + in + { t with code_id_to_name } + +let add_code_id_to_code_id ~src ~dst ({ code_id_to_code_id; _ } as t) = + let code_id_to_code_id = + Code_id.Map.update src + (function + | None -> if Code_id.Set.is_empty dst then None else Some dst + | Some old -> + Misc.fatal_errorf "Same code_id bound multiple times: %a -> %a, %a" + Code_id.print src Code_id.Set.print old Code_id.Set.print dst) + code_id_to_code_id + in + { t with code_id_to_code_id } + +let add_name_occurrences name_occurrences + ({ unconditionally_used; code_id_unconditionally_used; _ } as t) = + let unconditionally_used = + Name_occurrences.fold_names name_occurrences + ~f:(fun set name -> Name.Set.add name set) + ~init:unconditionally_used + in + let code_id_unconditionally_used = + Code_id.Set.union + (Name_occurrences.code_ids name_occurrences) + code_id_unconditionally_used + in + { t with unconditionally_used; code_id_unconditionally_used } + +let add_continuation_info map ~return_continuation ~exn_continuation + ~used_value_slots _ + T.Continuation_info. + { apply_cont_args; + (* CR pchambart: properly follow dependencies in exception extra args. + They are currently marked as always used, so it is correct, but not + optimal *) + used_in_handler; + bindings; + direct_aliases; + mutable_let_prims_rev; + defined = _; + code_ids; + value_slots; + continuation = _; + recursive = _; + is_exn_handler = _; + parent_continuation = _; + params = _ + } t = + (* Add the vars used in the handler *) + let t = add_name_occurrences used_in_handler t in + (* Add the dependencies created by closures vars in envs *) + let is_value_slot_used = + match (used_value_slots : _ Or_unknown.t) with + | Unknown -> fun _ -> true + | Known used_value_slots -> + Name_occurrences.value_slot_is_used_or_imported used_value_slots + in + let t = + Value_slot.Map.fold + (fun value_slot map t -> + if not (is_value_slot_used value_slot) + then t + else + Name.Map.fold + (fun closure_name values_in_env t -> + Name_occurrences.fold_names + ~f:(fun t value_in_env -> + add_dependency ~src:closure_name ~dst:value_in_env t) + values_in_env ~init:t) + map t) + value_slots t + in + (* Build the graph of dependencies between names *) + let t = + Name.Map.fold + (fun src name_occurrences graph -> + fold_name_occurrences name_occurrences ~init:graph + ~names:(fun t dst -> add_dependency ~src ~dst t) + ~code_ids:(fun t dst -> add_code_id_dep ~src ~dst t)) + bindings t + in + let t = + Variable.Map.fold + (fun src simple graph -> + let src = Name.var src in + let name_occurrences = Simple.free_names simple in + fold_name_occurrences name_occurrences ~init:graph + ~names:(fun t dst -> add_dependency ~src ~dst t) + ~code_ids:(fun t dst -> add_code_id_dep ~src ~dst t)) + direct_aliases t + in + let t = + List.fold_left + (fun t + T.Mutable_let_prim. + { bound_var; prim; original_prim; named_rewrite_id = _ } -> + let src = Name.var bound_var in + (* This is an over-aproximation of the the dependencies after mutable + unboxing, but: if no unboxing happen this is the correct + dependencies, if some unboxing happens, then we will run a second + round of optimisation on the current function (if this is the code of + a function) that will actually remove those spurious dependencies *) + match prim with + | Is_int _ | Get_tag _ | Make_block _ | Block_load _ -> + Name_occurrences.fold_names + ~f:(fun t dst -> add_dependency ~src ~dst t) + (Flambda_primitive.free_names original_prim) + ~init:t + | Block_set _ -> + add_name_occurrences (Flambda_primitive.free_names original_prim) t) + t mutable_let_prims_rev + in + let t = + Code_id.Map.fold + (fun src name_occurrences graph -> + fold_name_occurrences name_occurrences ~init:graph + ~names:(fun t dst -> add_code_id_dependency ~src ~dst t) + ~code_ids:(fun t dst -> add_code_id_to_code_id ~src ~dst t)) + code_ids t + in + (* Build the graph of dependencies between continuation parameters and + arguments. *) + Continuation.Map.fold + (fun k rewrite_ids t -> + if Continuation.equal return_continuation k + || Continuation.equal exn_continuation k + then + Apply_cont_rewrite_id.Map.fold + (fun _rewrite_id args t -> + Numeric_types.Int.Map.fold + (fun _ (cont_arg : T.Cont_arg.t) t -> + match cont_arg with + | Simple simple -> + add_name_occurrences (Simple.free_names simple) t + | New_let_binding (var, prim_free_names) -> + add_name_occurrences + (Name_occurrences.union prim_free_names + (Name_occurrences.singleton_variable var Name_mode.normal)) + t + | Function_result -> t) + args t) + rewrite_ids t + else + let params = + match Continuation.Map.find k map with + | elt -> + Array.of_list (Bound_parameters.vars elt.T.Continuation_info.params) + | exception Not_found -> + Misc.fatal_errorf "Continuation not found during Data_flow: %a@." + Continuation.print k + in + Apply_cont_rewrite_id.Map.fold + (fun rewrite_id args t -> + let correct_number_of_arguments = + match Numeric_types.Int.Map.max_binding args with + | exception Not_found -> Array.length params = 0 + | max_arg, _ -> max_arg = Array.length params - 1 + in + if not correct_number_of_arguments + then + Misc.fatal_errorf + "Mismatched number of argument and params for %a at rewrite_id \ + %a" + Continuation.print k Apply_cont_rewrite_id.print rewrite_id; + Numeric_types.Int.Map.fold + (fun i (cont_arg : T.Cont_arg.t) t -> + (* Note on the direction of the edge: + + We later do a reachability analysis to compute the transitive + closure of the used variables. + + Therefore an edge from src to dst means: if src is used, then + dst is also used. + + Applied here, this means : if the param of a continuation is + used, then any argument provided for that param is also used. + The other way wouldn't make much sense. *) + let src = Name.var params.(i) in + match cont_arg with + | Simple simple -> + Name_occurrences.fold_names (Simple.free_names simple) ~init:t + ~f:(fun t dst -> add_dependency ~src ~dst t) + | New_let_binding (var, prim_free_names) -> + let t = add_dependency ~src ~dst:(Name.var var) t in + Name_occurrences.fold_names prim_free_names ~init:t + ~f:(fun t dst -> add_dependency ~src:(Name.var var) ~dst t) + | Function_result -> t) + args t) + rewrite_ids t) + apply_cont_args t + +let create ~return_continuation ~exn_continuation ~code_age_relation + ~used_value_slots map = + (* Build the dependencies using the regular params and args of continuations, + and the let-bindings in continuations handlers. *) + let is_toplevel = + match (used_value_slots : _ Or_unknown.t) with + | Known _ -> true + | Unknown -> false + in + let t = + Continuation.Map.fold + (add_continuation_info map ~return_continuation ~exn_continuation + ~used_value_slots) + map + (empty code_age_relation is_toplevel) + in + t + +let required_names + ({ code_age_relation = _; + name_to_name = _; + name_to_code_id = _; + code_id_to_name = _; + code_id_to_code_id = _; + unconditionally_used; + code_id_unconditionally_used; + is_toplevel + } as t) = + let name_queue = Queue.create () in + Name.Set.iter (fun v -> Queue.push v name_queue) unconditionally_used; + let code_id_queue = Queue.create () in + if is_toplevel + then + Code_id.Set.iter + (fun v -> Queue.push v code_id_queue) + code_id_unconditionally_used; + Reachable.reachable_names t code_id_queue code_id_unconditionally_used + Code_id.Set.empty name_queue unconditionally_used diff --git a/ocaml/asmcomp/debug/compute_ranges.mli b/middle_end/flambda2/simplify/flow/data_flow_graph.mli similarity index 55% rename from ocaml/asmcomp/debug/compute_ranges.mli rename to middle_end/flambda2/simplify/flow/data_flow_graph.mli index 695529f3534..e198740801a 100644 --- a/ocaml/asmcomp/debug/compute_ranges.mli +++ b/middle_end/flambda2/simplify/flow/data_flow_graph.mli @@ -2,9 +2,9 @@ (* *) (* OCaml *) (* *) -(* Mark Shinwell, Jane Street Europe *) +(* Pierre Chambart and Guillaume Bury, OCamlPro *) (* *) -(* Copyright 2014--2018 Jane Street Group LLC *) +(* Copyright 2021--2021 OCamlPro SAS *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) @@ -12,17 +12,20 @@ (* *) (**************************************************************************) -(** Coalescing of per-instruction information into possibly-discontiguous - regions of code delimited by labels. This is used for collating - register availability and lexical block scoping information into a - concise form. *) +(** An internal type for the data_flow graph *) +type t -[@@@ocaml.warning "+a-4-30-40-41-42"] +(** Printing function *) +val print : Format.formatter -> t -> unit -module Make (S : Compute_ranges_intf.S_functor) - : Compute_ranges_intf.S - with module Index := S.Index - with module Key := S.Key - with module Subrange_state := S.Subrange_state - with module Subrange_info := S.Subrange_info - with module Range_info := S.Range_info +(** Create the data flow graph *) +val create : + return_continuation:Continuation.t -> + exn_continuation:Continuation.t -> + code_age_relation:Code_age_relation.t -> + used_value_slots:Name_occurrences.t Or_unknown.t -> + Flow_types.Continuation_info.t Continuation.Map.t -> + t + +(** Run the required names analysis *) +val required_names : t -> Flow_types.Data_flow_result.t diff --git a/middle_end/flambda2/simplify/flow/dominator_graph.ml b/middle_end/flambda2/simplify/flow/dominator_graph.ml new file mode 100644 index 00000000000..7b13edccb22 --- /dev/null +++ b/middle_end/flambda2/simplify/flow/dominator_graph.ml @@ -0,0 +1,315 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart and Guillaume Bury, OCamlPro *) +(* *) +(* Copyright 2021--2021 OCamlPro SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module T = Flow_types +module G = Strongly_connected_components.Make (Variable) + +type t = + { required_names : Name.Set.t; + params_kind : Flambda_kind.With_subkind.t Variable.Map.t; + graph : G.directed_graph; + dominator_roots : Variable.Set.t + (* variables that are dominated only by themselves, usually because a + constant or a symbol can flow to that variable, and thus that + variable cannot be dominated by another variable. *) + } + +type alias_map = Variable.t Variable.Map.t + +let empty ~required_names = + let graph = Variable.Map.empty in + let dominator_roots = Variable.Set.empty in + let params_kind = Variable.Map.empty in + { required_names; params_kind; graph; dominator_roots } + +let add_node t var = + if not (Name.Set.mem (Name.var var) t.required_names) + then t + else + let graph = + Variable.Map.update var + (function None -> Some Variable.Set.empty | Some _ as res -> res) + t.graph + in + { t with graph } + +let add_root var t = + if not (Name.Set.mem (Name.var var) t.required_names) + then t + else { t with dominator_roots = Variable.Set.add var t.dominator_roots } + +let add_edge ~src ~dst t = + if not (Name.Set.mem (Name.var src) t.required_names) + then t + else + Simple.pattern_match' dst + ~const:(fun _ -> add_root src t) + ~symbol:(fun _ ~coercion:_ -> add_root src t) + ~var:(fun dst ~coercion:_ -> + let graph = + Variable.Map.update src + (function + | None -> Some (Variable.Set.singleton dst) + | Some s -> Some (Variable.Set.add dst s)) + t.graph + in + { t with graph }) + +let add_continuation_info map _k (elt : T.Continuation_info.t) t + ~return_continuation ~exn_continuation = + let t = + List.fold_left + (fun t bp -> + let var = Bound_parameter.var bp in + let t = add_node t var in + let params_kind = + Variable.Map.add var (Bound_parameter.kind bp) t.params_kind + in + { t with params_kind }) + t + (Bound_parameters.to_list elt.params) + in + let t = + Variable.Map.fold + (fun src dst t -> add_edge ~src ~dst t) + elt.direct_aliases t + in + Continuation.Map.fold + (fun k rewrite_ids t -> + if Continuation.equal return_continuation k + || Continuation.equal exn_continuation k + then t + else + let params = + match Continuation.Map.find k map with + | elt -> + Array.of_list (Bound_parameters.vars elt.T.Continuation_info.params) + | exception Not_found -> + Misc.fatal_errorf "Continuation not found during Data_flow: %a@." + Continuation.print k + in + Apply_cont_rewrite_id.Map.fold + (fun _rewrite_id args t -> + Numeric_types.Int.Map.fold + (fun i (dst : T.Cont_arg.t) t -> + (* Note on the direction of the edge: + + We later do a dominator analysis on this graph. To do so, we + consider that an edge from ~src to ~dst means: ~dst is used + as argument (of an apply_cont), that maps to ~src (as param + of a continuation). *) + let src = params.(i) in + match dst with + | Simple dst -> add_edge ~src ~dst t + | Function_result -> add_root src t + | New_let_binding (var, _) -> + let t = add_root var t in + add_edge ~src ~dst:(Simple.var var) t) + args t) + rewrite_ids t) + elt.apply_cont_args t + +let create ~required_names ~return_continuation ~exn_continuation map = + let t = empty ~required_names in + let t = + Continuation.Map.fold + (add_continuation_info ~return_continuation ~exn_continuation map) + map t + in + let all_variables = + Variable.Map.fold + (fun v dsts acc -> Variable.Set.add v (Variable.Set.union dsts acc)) + t.graph t.dominator_roots + in + (* ensure that all variable are mapped: this is a requirement for the SCC + computation *) + let t = + Variable.Set.fold + (fun var t -> + let graph = + Variable.Map.update var + (function Some _ as res -> res | None -> Some Variable.Set.empty) + t.graph + in + { t with graph }) + all_variables t + in + t + +let find_dom var doms = + (* there are tow cases where the variable is not in the "doms" maps: + + - is not mapped in the graph, which means that it is a let-bound variable, + in which case it can only be dominated by itself. + + - we are in the first iteration of a loop fixpoint, in which case we also + want to initialize the dominator to the variable itself. *) + try Variable.Map.find var doms with Not_found -> var + +let update_doms_for_one_var { dominator_roots; graph; _ } doms var = + let dom = + if Variable.Set.mem var dominator_roots + then var + else + match Variable.Map.find var graph with + | exception Not_found -> var + | predecessors -> + let s = + Variable.Set.map + (fun predecessor -> find_dom predecessor doms) + predecessors + in + if Variable.Set.cardinal s = 1 then Variable.Set.choose s else var + in + Variable.Map.add var dom doms + +let initialize_doms_for_fixpoint { graph; _ } doms vars = + (* Note: since all vars are in a cycle, all_predecessors will include all + vars *) + let all_predecessors = + List.fold_left + (fun acc var -> + let predecessors = + try Variable.Map.find var graph with Not_found -> assert false + in + Variable.Set.union predecessors acc) + Variable.Set.empty vars + in + let init_doms = + Variable.Set.map (fun var -> find_dom var doms) all_predecessors + in + let outside_cycle = + Variable.Map.of_set + (fun var -> Variable.Set.singleton (find_dom var doms)) + (Variable.Set.diff all_predecessors (Variable.Set.of_list vars)) + in + List.fold_left + (fun doms var -> Variable.Map.add var init_doms doms) + outside_cycle vars + +let rec dom_fixpoint ({ graph; dominator_roots; _ } as t) acc vars = + let acc' = + List.fold_left + (fun acc var -> + if Variable.Set.mem var dominator_roots + then Variable.Map.add var (Variable.Set.singleton var) acc + else + let init_doms = Variable.Map.find var acc in + let predecessors = + try Variable.Map.find var graph with Not_found -> assert false + in + let new_doms = + Variable.Set.fold + (fun predecessor new_doms -> + Variable.Set.inter new_doms (Variable.Map.find predecessor acc)) + predecessors init_doms + in + let new_doms = Variable.Set.add var new_doms in + Variable.Map.add var new_doms acc) + acc vars + in + if Variable.Map.equal Variable.Set.equal acc acc' + then acc + else dom_fixpoint t acc' vars + +let extract_doms doms fixpoint_result vars = + let var_set = Variable.Set.of_list vars in + List.fold_left + (fun doms var -> + let fixpoint_doms = Variable.Map.find var fixpoint_result in + let var_doms = Variable.Set.diff fixpoint_doms var_set in + let cardinal = Variable.Set.cardinal var_doms in + assert (cardinal <= 1); + let dom = if cardinal = 1 then Variable.Set.choose var_doms else var in + Variable.Map.add var dom doms) + doms vars + +let dominator_analysis ({ graph; _ } as t) : alias_map = + let components = G.connected_components_sorted_from_roots_to_leaf graph in + let dominators = + Array.fold_right + (fun component doms -> + match component with + | G.No_loop var -> update_doms_for_one_var t doms var + | G.Has_loop vars -> + let loop_doms = initialize_doms_for_fixpoint t doms vars in + let loop_result = dom_fixpoint t loop_doms vars in + let doms = extract_doms doms loop_result vars in + doms) + components Variable.Map.empty + in + dominators + +let aliases_kind { params_kind; required_names; _ } aliases = + Variable.Map.fold + (fun param kind acc -> + if not (Name.Set.mem (Name.var param) required_names) + then acc + else + let alias = Variable.Map.find param aliases in + (* CR: Not sure this is absolutely necessary, but it's simpler. The + alternative would be to do a join of all kinds with subkinds for all + the members of the alias class. *) + let kind = Flambda_kind.With_subkind.kind kind in + (match Variable.Map.find alias acc with + | exception Not_found -> () + | alias_kind -> + if not (Flambda_kind.equal kind alias_kind) + then Misc.fatal_errorf "Incoherent kinds for aliases !"); + Variable.Map.add alias kind acc) + params_kind Variable.Map.empty + +module Dot = struct + let node_id ~ctx ppf (variable : Variable.t) = + Format.fprintf ppf "node_%d_%d" ctx (variable :> int) + + let node ~ctx ~root ppf var = + if root + then + Format.fprintf ppf "%a [shape=record label=\"%a\"];@\n" (node_id ~ctx) var + Variable.print var + else + Format.fprintf ppf "%a [label=\"%a\"];@\n" (node_id ~ctx) var + Variable.print var + + let nodes ~ctx ~roots ppf var_map = + Variable.Map.iter + (fun var _ -> + let root = Variable.Set.mem var roots in + node ~ctx ~root ppf var) + var_map + + let edge ~ctx ~color ppf src dst = + Format.fprintf ppf "%a -> %a [color=\"%s\"];@\n" (node_id ~ctx) src + (node_id ~ctx) dst color + + let edges ~ctx ~color ppf edge_map = + Variable.Map.iter + (fun src dst_set -> + Variable.Set.iter (fun dst -> edge ~ctx ~color ppf src dst) dst_set) + edge_map + + let edges' ~ctx ~color ppf edge_map = + Variable.Map.iter (fun src dst -> edge ~ctx ~color ppf src dst) edge_map + + let print ~ctx ~print_name ~doms ppf t = + Flambda_colours.without_colours ~f:(fun () -> + Format.fprintf ppf + "subgraph cluster_%d { label=\"%s\"@\n%a@\n%a@\n%a@\n}@." ctx + print_name + (nodes ~ctx ~roots:t.dominator_roots) + t.graph + (edges ~ctx ~color:"black") + t.graph (edges' ~ctx ~color:"red") doms) +end diff --git a/middle_end/flambda2/simplify/flow/dominator_graph.mli b/middle_end/flambda2/simplify/flow/dominator_graph.mli new file mode 100644 index 00000000000..667075588bd --- /dev/null +++ b/middle_end/flambda2/simplify/flow/dominator_graph.mli @@ -0,0 +1,51 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart and Guillaume Bury, OCamlPro *) +(* *) +(* Copyright 2021--2021 OCamlPro SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module G : Strongly_connected_components.S with module Id := Variable + +(** An internal type for the data_flow graph *) +type t = + { required_names : Name.Set.t; + params_kind : Flambda_kind.With_subkind.t Variable.Map.t; + graph : G.directed_graph; + dominator_roots : Variable.Set.t + (* variables that are dominated only by themselves, usually because a + constant or a symbol can flow to that variable, and thus that + variable cannot be dominated by another variable. *) + } + +type alias_map = Variable.t Variable.Map.t + +(** Create the data flow graph *) +val create : + required_names:Name.Set.t -> + return_continuation:Continuation.t -> + exn_continuation:Continuation.t -> + Flow_types.Continuation_info.t Continuation.Map.t -> + t + +val dominator_analysis : t -> alias_map + +val aliases_kind : t -> alias_map -> Flambda_kind.t Variable.Map.t + +module Dot : sig + (** Printing function *) + val print : + ctx:int -> + print_name:string -> + doms:Variable.t Variable.Map.t -> + Format.formatter -> + t -> + unit +end diff --git a/ocaml/toplevel/opttopstart.ml b/middle_end/flambda2/simplify/flow/flow.ml similarity index 78% rename from ocaml/toplevel/opttopstart.ml rename to middle_end/flambda2/simplify/flow/flow.ml index effdfa5daeb..56d65386a97 100644 --- a/ocaml/toplevel/opttopstart.ml +++ b/middle_end/flambda2/simplify/flow/flow.ml @@ -2,10 +2,9 @@ (* *) (* OCaml *) (* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Pierre Chambart and Guillaume Bury, OCamlPro *) (* *) -(* Copyright 2002 Institut National de Recherche en Informatique et *) -(* en Automatique. *) +(* Copyright 2021--2021 OCamlPro SAS *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) @@ -13,4 +12,5 @@ (* *) (**************************************************************************) -let _ = Stdlib.exit (Opttopmain.main()) +module Acc = Flow_acc +module Analysis = Flow_analysis diff --git a/middle_end/flambda2/simplify/flow/flow.mli b/middle_end/flambda2/simplify/flow/flow.mli new file mode 100644 index 00000000000..41f6586f30c --- /dev/null +++ b/middle_end/flambda2/simplify/flow/flow.mli @@ -0,0 +1,113 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart and Guillaume Bury, OCamlPro *) +(* *) +(* Copyright 2021--2021 OCamlPro SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Acc : sig + (** The type of accumulator for flow analysis *) + type t + + (** printing *) + val print : Format.formatter -> t -> unit + + (* {2 Creation and updates} *) + + (** Empty uses *) + val empty : unit -> t + + (** Initialize the analysis so that the stack consists of a single toplevel + continuation. *) + val init_toplevel : + dummy_toplevel_cont:Continuation.t -> Bound_parameters.t -> t -> t + + (** Add a new continuation on the stack. Used when entering a continuation + handler. *) + val enter_continuation : + Continuation.t -> + recursive:bool -> + is_exn_handler:bool -> + Bound_parameters.t -> + t -> + t + + (** Pop the current top of the stack. Used when exiting the current + continuation handler. *) + val exit_continuation : Continuation.t -> t -> t + + (** That variable is defined in the current handler *) + val record_defined_var : Variable.t -> t -> t + + (** Add a variable binding from the current handler. *) + val record_var_binding : + Variable.t -> Name_occurrences.t -> generate_phantom_lets:bool -> t -> t + + (** Record a let-binding *) + val record_let_binding : + rewrite_id:Named_rewrite_id.t -> + generate_phantom_lets:bool -> + let_bound:Bound_pattern.t -> + simplified_defining_expr:Simplified_named.t -> + t -> + t + + (** Add a variable binding to the symbol. Projections might get recorded + multiple times. *) + val record_symbol_projection : Variable.t -> Name_occurrences.t -> t -> t + + (** Add a symbol binding from the current handler. *) + val record_symbol_binding : Symbol.t -> Name_occurrences.t -> t -> t + + (** Add a code id binding from the current handler. *) + val record_code_id_binding : Code_id.t -> Name_occurrences.t -> t -> t + + (** Add a value slot from the current handler. *) + val record_value_slot : Name.t -> Value_slot.t -> Name_occurrences.t -> t -> t + + (** Add name occurrences used in the body of the current continuation's + handler, *excluding* uses in apply_cont expressions, which are tracked + separately. *) + val add_used_in_current_handler : Name_occurrences.t -> t -> t + + (** Add the given continuation as being used as the return continuation for a + function call. *) + val add_apply_conts : + result_cont:(Apply_cont_rewrite_id.t * Continuation.t) option -> + exn_cont:Apply_cont_rewrite_id.t * Exn_continuation.t -> + t -> + t + + (** Add, for the current continuation handler, uses for an apply cont of the + given continuation with given arguments occurrences. *) + val add_apply_cont_args : + rewrite_id:Apply_cont_rewrite_id.t -> + Continuation.t -> + Simple.t list -> + t -> + t + + (** Add extra params and args to a continuation. *) + val add_extra_params_and_args : + Continuation.t -> Continuation_extra_params_and_args.t -> t -> t +end + +module Analysis : sig + (** Perform flow analysis *) + val analyze : + ?speculative:bool -> + ?print_name:string -> + return_continuation:Continuation.t -> + exn_continuation:Continuation.t -> + code_age_relation:Code_age_relation.t -> + used_value_slots:Name_occurrences.t Or_unknown.t -> + Acc.t -> + Flow_types.Flow_result.t +end diff --git a/middle_end/flambda2/simplify/flow/flow_acc.ml b/middle_end/flambda2/simplify/flow/flow_acc.ml new file mode 100644 index 00000000000..cf352742ccf --- /dev/null +++ b/middle_end/flambda2/simplify/flow/flow_acc.ml @@ -0,0 +1,500 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart and Guillaume Bury, OCamlPro *) +(* *) +(* Copyright 2021--2021 OCamlPro SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module T = Flow_types +module EPA = Continuation_extra_params_and_args + +type t = T.Acc.t + +type cont_info = T.Continuation_info.t + +let print = T.Acc.print + +(* Creation *) +(* ******** *) + +let wrong_dummy_toplevel_cont_name = "wrong toplevel cont" + +let empty () = + let wrong_dummy_toplevel_cont = + Continuation.create ~name:wrong_dummy_toplevel_cont_name () + in + let res : t = + { stack = []; + map = Continuation.Map.empty; + extra = Continuation.Map.empty; + dummy_toplevel_cont = wrong_dummy_toplevel_cont + } + in + res + +(* Updates *) +(* ******* *) + +let add_extra_params_and_args cont extra (t : t) = + let extra = + Continuation.Map.update cont + (function + | Some _ -> Misc.fatal_errorf "Continuation extended a second time" + | None -> Some extra) + t.extra + in + { t with extra } + +let enter_continuation continuation ~recursive ~is_exn_handler params (t : t) = + let parent_continuation = + match t.stack with [] -> None | parent :: _ -> Some parent.continuation + in + let used_in_handler = + if not is_exn_handler + then Name_occurrences.empty + else + (* The first param of an exn_handler is unconditionally used *) + let first_param = + Bound_parameter.var (List.hd (Bound_parameters.to_list params)) + in + Name_occurrences.singleton_variable first_param Name_mode.normal + in + let cont_info : cont_info = + { continuation; + recursive; + is_exn_handler; + params; + parent_continuation; + bindings = Name.Map.empty; + direct_aliases = Variable.Map.empty; + mutable_let_prims_rev = []; + defined = Variable.Set.empty; + code_ids = Code_id.Map.empty; + value_slots = Value_slot.Map.empty; + used_in_handler; + apply_cont_args = Continuation.Map.empty + } + in + { t with stack = cont_info :: t.stack } + +let init_toplevel ~dummy_toplevel_cont params _t = + enter_continuation dummy_toplevel_cont ~recursive:false ~is_exn_handler:false + params + { (empty ()) with dummy_toplevel_cont } + +let exit_continuation cont (t : t) = + match t.stack with + | [] -> Misc.fatal_errorf "Empty stack of variable uses" + | ({ continuation; _ } as elt) :: stack -> + assert (Continuation.equal cont continuation); + let map = Continuation.Map.add cont elt t.map in + { t with stack; map } + +let update_top_of_stack ~(t : t) ~f = + match t.stack with + | [] -> Misc.fatal_errorf "Empty stack of variable uses" + | elt :: stack -> { t with stack = f elt :: stack } + +let record_defined_var var t = + update_top_of_stack ~t ~f:(fun elt -> + let defined = Variable.Set.add var elt.defined in + { elt with defined }) + +let record_var_binding var name_occurrences ~generate_phantom_lets t = + update_top_of_stack ~t ~f:(fun elt -> + let bindings = + Name.Map.update (Name.var var) + (function + | None -> Some name_occurrences + | Some _ -> + Misc.fatal_errorf + "The following variable has been bound twice: %a" Variable.print + var) + elt.bindings + in + let used_in_handler = + if Variable.user_visible var && generate_phantom_lets + then + Name_occurrences.add_variable elt.used_in_handler var + Name_mode.phantom + else elt.used_in_handler + in + let defined = Variable.Set.add var elt.defined in + { elt with bindings; used_in_handler; defined }) + +let record_var_alias var definition t = + update_top_of_stack ~t ~f:(fun elt -> + let direct_aliases = + Variable.Map.update var + (function + | None -> Some definition + | Some _ -> + Misc.fatal_errorf + "The following variable has been bound twice: %a" Variable.print + var) + elt.direct_aliases + in + let defined = Variable.Set.add var elt.defined in + { elt with direct_aliases; defined }) + +let record_ref_named named_rewrite_id ~bound_to ~original_prim ~prim (t : t) = + update_top_of_stack ~t ~f:(fun cont_info -> + let mutable_let_prim : T.Mutable_let_prim.t = + { bound_var = bound_to; named_rewrite_id; original_prim; prim } + in + let mutable_let_prims_rev = + mutable_let_prim :: cont_info.mutable_let_prims_rev + in + { cont_info with mutable_let_prims_rev }) + +let record_symbol_projection var name_occurrences t = + update_top_of_stack ~t ~f:(fun elt -> + let bindings = + Name.Map.update (Name.var var) + (function + | None -> Some name_occurrences + | Some prior_occurences as original -> + if Name_occurrences.equal prior_occurences name_occurrences + then original + else + Misc.fatal_errorf + "@[The following projection has been bound to different \ + symbols:%a@ previously bound to:@ %a@ and now to@ %a@]" + Variable.print var Name_occurrences.print prior_occurences + Name_occurrences.print name_occurrences) + elt.bindings + in + { elt with bindings }) + +let record_symbol_binding symbol name_occurrences t = + update_top_of_stack ~t ~f:(fun elt -> + let bindings = + Name.Map.update (Name.symbol symbol) + (function + | None -> Some name_occurrences + | Some _ -> + Misc.fatal_errorf "The following symbol has been bound twice: %a" + Symbol.print symbol) + elt.bindings + in + { elt with bindings }) + +let record_code_id_binding code_id name_occurrences t = + update_top_of_stack ~t ~f:(fun elt -> + let code_ids = + Code_id.Map.update code_id + (function + | None -> Some name_occurrences + | Some _ -> + Misc.fatal_errorf "The following code_id has been bound twice: %a" + Code_id.print code_id) + elt.code_ids + in + { elt with code_ids }) + +let record_value_slot src value_slot dst t = + update_top_of_stack ~t ~f:(fun elt -> + let value_slots = + Value_slot.Map.update value_slot + (function + | None -> Some (Name.Map.singleton src dst) + | Some map -> + Some + (Name.Map.update src + (function + | None -> Some dst + | Some dst' -> Some (Name_occurrences.union dst dst')) + map)) + elt.value_slots + in + { elt with value_slots }) + +let add_used_in_current_handler name_occurrences t = + update_top_of_stack ~t ~f:(fun elt -> + let used_in_handler = + Name_occurrences.union elt.used_in_handler name_occurrences + in + { elt with used_in_handler }) + +let add_apply_conts ~result_cont ~exn_cont t = + update_top_of_stack ~t ~f:(fun elt -> + let add_func_result cont rewrite_id ~extra_args apply_cont_args = + Continuation.Map.update cont + (fun (rewrite_map_opt : + T.Cont_arg.t Numeric_types.Int.Map.t + Apply_cont_rewrite_id.Map.t + option) -> + let rewrite_map = + Option.value ~default:Apply_cont_rewrite_id.Map.empty + rewrite_map_opt + in + let rewrite_map = + Apply_cont_rewrite_id.Map.update rewrite_id + (function + | Some _ -> + Misc.fatal_errorf "Introducing a rewrite id twice %a" + Apply_cont_rewrite_id.print rewrite_id + | None -> + let map = + Numeric_types.Int.Map.singleton 0 + T.Cont_arg.Function_result + in + let _, map = + List.fold_left + (fun (i, map) (extra_arg, _kind) -> + let map = + Numeric_types.Int.Map.add i + (T.Cont_arg.Simple extra_arg) map + in + i + 1, map) + (1, map) extra_args + in + Some map) + rewrite_map + in + Some rewrite_map) + apply_cont_args + in + let apply_cont_args = + let rewrite_id, exn_cont = exn_cont in + add_func_result + (Exn_continuation.exn_handler exn_cont) + rewrite_id + ~extra_args:(Exn_continuation.extra_args exn_cont) + elt.apply_cont_args + in + let apply_cont_args = + match result_cont with + | None -> apply_cont_args + | Some (rewrite_id, result_cont) -> + add_func_result result_cont rewrite_id ~extra_args:[] apply_cont_args + in + { elt with apply_cont_args }) + +let add_apply_cont_args ~rewrite_id cont arg_name_simples t = + update_top_of_stack ~t ~f:(fun elt -> + let apply_cont_args = + Continuation.Map.update cont + (fun (rewrite_map_opt : + T.Cont_arg.t Numeric_types.Int.Map.t + Apply_cont_rewrite_id.Map.t + option) -> + let rewrite_map = + Option.value ~default:Apply_cont_rewrite_id.Map.empty + rewrite_map_opt + in + let rewrite_map = + Apply_cont_rewrite_id.Map.update rewrite_id + (function + | Some _ -> + Misc.fatal_errorf "Introducing a rewrite id twice %a" + Apply_cont_rewrite_id.print rewrite_id + | None -> + let map, _ = + List.fold_left + (fun (map, i) arg_simple -> + let map = + Numeric_types.Int.Map.add i + (T.Cont_arg.Simple arg_simple) map + in + map, i + 1) + (Numeric_types.Int.Map.empty, 0) + arg_name_simples + in + Some map) + rewrite_map + in + Some rewrite_map) + elt.apply_cont_args + in + { elt with apply_cont_args }) + +let get_block_and_constant_field ~block ~field = + Simple.pattern_match field + ~name:(fun _ ~coercion:_ -> None) + ~const:(fun const -> + Simple.pattern_match' block + ~const:(fun _ -> None) + ~symbol:(fun _ ~coercion:_ -> None) + ~var:(fun var ~coercion:_ -> + let field = + match[@ocaml.warning "-4"] Reg_width_const.descr const with + | Tagged_immediate i -> Targetint_31_63.to_int i + | _ -> assert false + in + Some (var, field))) + +let record_let_binding ~rewrite_id ~generate_phantom_lets ~let_bound + ~simplified_defining_expr t = + match (simplified_defining_expr : Simplified_named.t) with + | { free_names; named; cost_metrics = _ } -> ( + let record_var_bindings t free_names = + Bound_pattern.fold_all_bound_vars let_bound ~init:t ~f:(fun t v -> + record_var_binding (Bound_var.var v) free_names ~generate_phantom_lets + t) + in + match[@ocaml.warning "-4"] named with + | Simple simple -> + let bound_var = Bound_pattern.must_be_singleton let_bound in + let var = Bound_var.var bound_var in + record_var_alias var simple t + | Set_of_closures _ | Rec_info _ -> record_var_bindings t free_names + | Prim (original_prim, _) -> ( + let bound_var = Bound_pattern.must_be_singleton let_bound in + let var = Bound_var.var bound_var in + match[@ocaml.warning "-4"] original_prim with + | Unary (End_region, _region) -> + (* Uses of region variables in [End_region] don't count as uses. *) + t + | Unary (Is_int _, simple) -> ( + match Simple.must_be_var simple with + | Some (v, _) -> + record_var_bindings + (record_ref_named rewrite_id ~bound_to:var ~original_prim + ~prim:(Is_int v) t) + Name_occurrences.empty + | None -> record_var_bindings t free_names) + | Unary (Get_tag, simple) -> ( + match Simple.must_be_var simple with + | Some (v, _) -> + record_var_bindings + (record_ref_named rewrite_id ~bound_to:var ~original_prim + ~prim:(Get_tag v) t) + Name_occurrences.empty + | None -> record_var_bindings t free_names) + | Binary (Block_load (bak, mut), block, field) -> ( + match get_block_and_constant_field ~block ~field with + | Some (block, field) -> + record_var_bindings + (record_ref_named rewrite_id ~bound_to:var ~original_prim + ~prim:(Block_load { bak; mut; block; field }) + t) + Name_occurrences.empty + | None -> record_var_bindings t free_names) + | Ternary (Block_set (bak, _), block, field, value) -> ( + match get_block_and_constant_field ~block ~field with + | Some (block, field) -> + record_ref_named rewrite_id ~bound_to:var ~original_prim + ~prim:(Block_set { bak; block; field; value }) + t + | None -> add_used_in_current_handler free_names t) + | Variadic (Make_block (kind, mut, alloc_mode), fields) -> + record_var_bindings + (record_ref_named rewrite_id ~bound_to:var ~original_prim + ~prim:(Make_block { kind; mut; alloc_mode; fields }) + t) + Name_occurrences.empty + | _ -> + if Flambda_primitive.at_most_generative_effects original_prim + then (* the primitive can be removed *) + record_var_bindings t free_names + else + let t = record_defined_var var t in + add_used_in_current_handler free_names t)) + +(* Normalisation *) +(* ************* *) + +let add_extra_args_to_call ~extra_args rewrite_id original_args = + match Apply_cont_rewrite_id.Map.find rewrite_id extra_args with + | exception Not_found -> original_args + | extra_args -> + let args_acc = + if Numeric_types.Int.Map.is_empty original_args + then 0, Numeric_types.Int.Map.empty + else + let max_arg, _ = Numeric_types.Int.Map.max_binding original_args in + max_arg + 1, original_args + in + let extra_args = + List.map + (function + | EPA.Extra_arg.Already_in_scope s -> T.Cont_arg.Simple s + | EPA.Extra_arg.New_let_binding (v, prim) -> + T.Cont_arg.New_let_binding (v, Flambda_primitive.free_names prim) + | EPA.Extra_arg.New_let_binding_with_named_args (v, _) -> + T.Cont_arg.New_let_binding (v, Name_occurrences.empty)) + extra_args + in + let _, args = + List.fold_left + (fun (i, args) extra_arg -> + i + 1, Numeric_types.Int.Map.add i extra_arg args) + args_acc extra_args + in + args + +let extend_args_with_extra_args (t : T.Acc.t) = + let map = + Continuation.Map.map + (fun (elt : T.Continuation_info.t) -> + let apply_cont_args = + Continuation.Map.mapi + (fun cont rewrite_ids -> + match Continuation.Map.find cont t.extra with + | exception Not_found -> rewrite_ids + | epa -> + let extra_args = EPA.extra_args epa in + Apply_cont_rewrite_id.Map.mapi + (add_extra_args_to_call ~extra_args) + rewrite_ids) + elt.apply_cont_args + in + { elt with apply_cont_args }) + t.map + in + let map = + Continuation.Map.map + (fun (elt : T.Continuation_info.t) -> + let defined = + Continuation.Map.fold + (fun callee_cont rewrite_ids defined -> + match Continuation.Map.find callee_cont t.extra with + | exception Not_found -> defined + | epa -> + Apply_cont_rewrite_id.Map.fold + (fun rewrite_id _args defined -> + match + Apply_cont_rewrite_id.Map.find rewrite_id + (EPA.extra_args epa) + with + | exception Not_found -> defined + | extra_args -> + let defined = + List.fold_left + (fun defined -> function + | EPA.Extra_arg.Already_in_scope _ -> defined + | EPA.Extra_arg.New_let_binding (v, _) + | EPA.Extra_arg.New_let_binding_with_named_args + (v, _) -> + Variable.Set.add v defined) + defined extra_args + in + defined) + rewrite_ids defined) + elt.apply_cont_args elt.defined + in + { elt with defined }) + map + in + let map = + Continuation.Map.fold + (fun cont epa map -> + let elt : T.Continuation_info.t = Continuation.Map.find cont map in + let elt = + let params = + Bound_parameters.append elt.params (EPA.extra_params epa) + in + { elt with params } + in + Continuation.Map.add cont elt map) + t.extra map + in + { t with map; extra = Continuation.Map.empty } diff --git a/middle_end/flambda2/simplify/env/data_flow.mli b/middle_end/flambda2/simplify/flow/flow_acc.mli similarity index 69% rename from middle_end/flambda2/simplify/env/data_flow.mli rename to middle_end/flambda2/simplify/flow/flow_acc.mli index dca1833d388..4fb14e8c4b7 100644 --- a/middle_end/flambda2/simplify/env/data_flow.mli +++ b/middle_end/flambda2/simplify/flow/flow_acc.mli @@ -22,37 +22,59 @@ - moving allocations out of the hot path of recursive continuations (e.g. the allocation of a float that was unboxed by the simplifier). *) -(** The type tracking the uses of variables (passed through the downwards - accumulator). +(** Type alias for convenience. *) +type t = Flow_types.Acc.t - This contains a stack to track in which continuation's handler the downwards - acc currently is. *) -type t - -(** Print to a formatter. *) +(** Printing *) val print : Format.formatter -> t -> unit +(** "Consume" the extra args of an accumulator in order to add them to the + regular args and parameters in the continuation info of each continuation. *) +val extend_args_with_extra_args : t -> t + +(** A name for the incorrec tdummy toplevel cont used to initialize the acc. *) +val wrong_dummy_toplevel_cont_name : string + (* {2 Creation and updates} *) (** Empty uses *) -val empty : t +val empty : unit -> t (** Initialize the analysis so that the stack consists of a single toplevel continuation. *) -val init_toplevel : Continuation.t -> Variable.t list -> t -> t +val init_toplevel : + dummy_toplevel_cont:Continuation.t -> Bound_parameters.t -> t -> t (** Add a new continuation on the stack. Used when entering a continuation handler. *) -val enter_continuation : Continuation.t -> Variable.t list -> t -> t +val enter_continuation : + Continuation.t -> + recursive:bool -> + is_exn_handler:bool -> + Bound_parameters.t -> + t -> + t (** Pop the current top of the stack. Used when exiting the current continuation handler. *) val exit_continuation : Continuation.t -> t -> t +(** That variable is defined in the current handler *) +val record_defined_var : Variable.t -> t -> t + (** Add a variable binding from the current handler. *) val record_var_binding : Variable.t -> Name_occurrences.t -> generate_phantom_lets:bool -> t -> t +(** Record a let-binding *) +val record_let_binding : + rewrite_id:Named_rewrite_id.t -> + generate_phantom_lets:bool -> + let_bound:Bound_pattern.t -> + simplified_defining_expr:Simplified_named.t -> + t -> + t + (** Add a variable binding to the symbol. Projections might get recorded multiple times. *) val record_symbol_projection : Variable.t -> Name_occurrences.t -> t -> t @@ -72,42 +94,21 @@ val add_used_in_current_handler : Name_occurrences.t -> t -> t (** Add the given continuation as being used as the return continuation for a function call. *) -val add_apply_result_cont : Continuation.t -> t -> t +val add_apply_conts : + result_cont:(Apply_cont_rewrite_id.t * Continuation.t) option -> + exn_cont:Apply_cont_rewrite_id.t * Exn_continuation.t -> + t -> + t (** Add, for the current continuation handler, uses for an apply cont of the given continuation with given arguments occurrences. *) -val add_apply_cont_args : Continuation.t -> Name_occurrences.t list -> t -> t +val add_apply_cont_args : + rewrite_id:Apply_cont_rewrite_id.t -> + Continuation.t -> + Simple.t list -> + t -> + t (** Add extra params and args to a continuation. *) val add_extra_params_and_args : Continuation.t -> Continuation_extra_params_and_args.t -> t -> t - -(* {2 Analysis} *) - -module Reachable_code_ids : sig - type t = - { live_code_ids : Code_id.Set.t; (** The set of code ids live/reachable. *) - ancestors_of_live_code_ids : Code_id.Set.t - (** The set of code ids that are ancestors of at least one live code - id. *) - } - - val print : Format.formatter -> t -> unit -end - -(** The result of an analysis of the uses of variables in continuations. *) -type result = private - { required_names : Name.Set.t; - (** The set of all variables that are in fact used to compute the - returned value of the function being analyzed. *) - reachable_code_ids : Reachable_code_ids.t - } - -(** Analyze the uses. *) -val analyze : - return_continuation:Continuation.t -> - exn_continuation:Continuation.t -> - code_age_relation:Code_age_relation.t -> - used_value_slots:Name_occurrences.t Or_unknown.t -> - t -> - result diff --git a/middle_end/flambda2/simplify/flow/flow_analysis.ml b/middle_end/flambda2/simplify/flow/flow_analysis.ml new file mode 100644 index 00000000000..2b235bd4ed4 --- /dev/null +++ b/middle_end/flambda2/simplify/flow/flow_analysis.ml @@ -0,0 +1,139 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart and Guillaume Bury, OCamlPro *) +(* *) +(* Copyright 2021--2021 OCamlPro SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module T = Flow_types + +(* debugging code *) + +let dominator_graph_ppf = + lazy + (let filename = "dom.dot" in + let ch = open_out filename in + let ppf = Format.formatter_of_out_channel ch in + Format.fprintf ppf "digraph g {@\n"; + at_exit (fun () -> + Format.fprintf ppf "@\n}@."; + close_out ch); + ppf) + +let control_flow_graph_ppf = + lazy + (let filename = "flow.dot" in + let ch = open_out filename in + let ppf = Format.formatter_of_out_channel ch in + Format.fprintf ppf "digraph g {@\n"; + at_exit (fun () -> + Format.fprintf ppf "@\n}@."; + close_out ch); + ppf) + +let dot_count = ref ~-1 + +let print_graph ~print ~print_name ~lazy_ppf ~graph = + match print_name with + | None -> () + | Some print_name -> + incr dot_count; + let ppf = Lazy.force lazy_ppf in + print ~ctx:!dot_count ~print_name ppf graph + +(* analysis *) + +let analyze ?(speculative = false) ?print_name ~return_continuation + ~exn_continuation ~code_age_relation ~used_value_slots t : T.Flow_result.t = + Profile.record_call ~accumulate:true "data_flow" (fun () -> + if Flambda_features.dump_flow () + then Format.eprintf "PRESOURCE:@\n%a@\n@." T.Acc.print t; + (* Accumulator normalization *) + let ({ T.Acc.stack; map; extra = _; dummy_toplevel_cont } as t) = + Flow_acc.extend_args_with_extra_args t + in + assert (stack = []); + assert ( + not + (Continuation.name dummy_toplevel_cont + = Flow_acc.wrong_dummy_toplevel_cont_name)); + if Flambda_features.dump_flow () + then Format.eprintf "SOURCE:@\n%a@\n@." T.Acc.print t; + (* dependency graph *) + let deps = + Data_flow_graph.create map ~return_continuation ~exn_continuation + ~code_age_relation ~used_value_slots + in + if Flambda_features.dump_flow () + then Format.eprintf "/// graph@\n%a@\n@." Data_flow_graph.print deps; + (* Dead variable analysis *) + let dead_variable_result = Data_flow_graph.required_names deps in + (* Aliases analysis *) + let dom_graph = + Dominator_graph.create map ~return_continuation ~exn_continuation + ~required_names:dead_variable_result.required_names + in + let aliases = Dominator_graph.dominator_analysis dom_graph in + let aliases_kind = Dominator_graph.aliases_kind dom_graph aliases in + if Flambda_features.dump_flow () + then + print_graph ~print_name ~lazy_ppf:dominator_graph_ppf ~graph:dom_graph + ~print:(Dominator_graph.Dot.print ~doms:aliases); + (* control flow graph *) + let control = Control_flow_graph.create ~dummy_toplevel_cont t in + let reference_analysis = + Mutable_unboxing.create ~dom:aliases ~dom_graph ~source_info:t + ~control_flow_graph:control + ~required_names:dead_variable_result.required_names + ~return_continuation ~exn_continuation + in + let pp_node = Mutable_unboxing.pp_node reference_analysis in + let reference_result, unboxed_blocks = + Mutable_unboxing.make_result reference_analysis + in + let continuation_parameters = + Control_flow_graph.compute_continuation_extra_args_for_aliases + ~speculative ~source_info:t aliases control + ~required_names:dead_variable_result.required_names ~unboxed_blocks + in + if Flambda_features.dump_flow () + then + print_graph ~print_name ~lazy_ppf:control_flow_graph_ppf ~graph:control + ~print: + (Control_flow_graph.Dot.print ~df:t ~return_continuation + ~exn_continuation ~continuation_parameters ~pp_node); + let required_names_after_ref_reference_analysis = + (* CR pchambart/gbury: this is an overapproximation of actually used new + parameters. We might want to filter this using another round of + dead_analysis *) + Continuation.Map.fold + (fun _cont epa required_names -> + let params = + Bound_parameters.var_set + (Continuation_extra_params_and_args.extra_params epa) + in + Name.Set.union required_names (Name.set_of_var_set params)) + reference_result.T.Mutable_unboxing_result.additionnal_epa + dead_variable_result.required_names + in + let result = + T.Flow_result. + { data_flow_result = + { dead_variable_result with + required_names = required_names_after_ref_reference_analysis + }; + aliases_result = { aliases_kind; continuation_parameters }; + mutable_unboxing_result = reference_result + } + in + if Flambda_features.dump_flow () + then Format.eprintf "/// result@\n%a@\n@." T.Flow_result.print result; + (* return *) + result) diff --git a/middle_end/flambda2/simplify/flow/flow_analysis.mli b/middle_end/flambda2/simplify/flow/flow_analysis.mli new file mode 100644 index 00000000000..d754d534185 --- /dev/null +++ b/middle_end/flambda2/simplify/flow/flow_analysis.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart and Guillaume Bury, OCamlPro *) +(* *) +(* Copyright 2021--2021 OCamlPro SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Dataflow analysis. + + This module aims mainly at tracking uses of variables (other things may be + added later on), with the aim of: + + - removing unused parameters of *recursive* continuations; + + - moving allocations out of the hot path of recursive continuations (e.g. + the allocation of a float that was unboxed by the simplifier). *) + +(** Analyze the uses. *) +val analyze : + ?speculative:bool -> + ?print_name:string -> + return_continuation:Continuation.t -> + exn_continuation:Continuation.t -> + code_age_relation:Code_age_relation.t -> + used_value_slots:Name_occurrences.t Or_unknown.t -> + Flow_types.Acc.t -> + Flow_types.Flow_result.t diff --git a/middle_end/flambda2/simplify/flow/flow_types.ml b/middle_end/flambda2/simplify/flow/flow_types.ml new file mode 100644 index 00000000000..f1dfbfb5524 --- /dev/null +++ b/middle_end/flambda2/simplify/flow/flow_types.ml @@ -0,0 +1,357 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart and Guillaume Bury, OCamlPro *) +(* *) +(* Copyright 2021--2021 OCamlPro SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* CR chambart/gbury: we might want to also track function_slots in addition to + value_slots. *) + +(* CR-someday chambart/gbury: get rid of Name_occurences everywhere, this is not + small while we need only the names + + mshinwell: in practice I'm not sure this will make any difference *) + +(* Continuation arguments at call sites of continuations *) +(* ***************************************************** *) + +module Cont_arg = struct + type t = + | Function_result + | Simple of Simple.t + | New_let_binding of Variable.t * Name_occurrences.t + + let print ppf = function + | Function_result -> Format.fprintf ppf "Function_result" + | Simple s -> Simple.print ppf s + | New_let_binding (v, _) -> + Format.fprintf ppf "New_let_binding %a" Variable.print v +end + +(* Primitives that we must track for mutable unboxing *) +(* ************************************************** *) + +module Mutable_prim = struct + type t = + | Is_int of Variable.t + | Get_tag of Variable.t + | Block_load of + { bak : Flambda_primitive.Block_access_kind.t; + mut : Mutability.t; + block : Variable.t; + field : int + } + | Block_set of + { bak : Flambda_primitive.Block_access_kind.t; + block : Variable.t; + field : int; + value : Simple.t + } + | Make_block of + { kind : Flambda_primitive.Block_kind.t; + mut : Mutability.t; + alloc_mode : Alloc_mode.For_allocations.t; + fields : Simple.t list + } + + let print ppf = function + | Is_int v -> Format.fprintf ppf "Is_int (%a)" Variable.print v + | Get_tag v -> Format.fprintf ppf "Get_tag (%a)" Variable.print v + | Block_load { block; field; _ } -> + Format.fprintf ppf "Block_load (%a, %i)" Variable.print block field + | Block_set { block; field; value; _ } -> + Format.fprintf ppf "Block_set (%a, %i, %a)" Variable.print block field + Simple.print value + | Make_block { fields; _ } -> + Format.fprintf ppf "Make_block [%a]" Simple.List.print fields +end + +(* Bindings to primitive that we track for the mutable unboxing *) +(* ************************************************************ *) + +module Mutable_let_prim = struct + type t = + { bound_var : Variable.t; + prim : Mutable_prim.t; + original_prim : Flambda_primitive.t; + named_rewrite_id : Named_rewrite_id.t + } + + let print ppf { bound_var; prim; original_prim = _; named_rewrite_id = _ } = + Format.fprintf ppf "%a = %a" Variable.print bound_var Mutable_prim.print + prim + + module List = struct + type nonrec t = t list + + let print_rev ppf l = + Format.fprintf ppf "[%a]" + (Format.pp_print_list print ~pp_sep:Format.pp_print_space) + (List.rev l) + end +end + +(* Accumulated flow information for a single continuation handler *) +(* ************************************************************** *) + +module Continuation_info = struct + (* Some notes: + + - {direct_aliases} is used to have a more precise escaping analysis for + mutable unboxing, since from_lambda occasionally generates aliases of the + form [let r' = r], which without a precise alias tracking, would be + considered as escaping. + + - the {bindings} field records dependencies between names, usually created + by primitive applications; in the case of effectful primitives (that can't + be removed), we do not record dependencies, but instead recrod all args of + the effectful prim as unconditionally used (in {used_in_handler}). + Similarly, for primitives tracked in {mutable_let_prims_rev}, we do not + record the dependencies in this field, since we already have the more + precise information. *) + type t = + { continuation : Continuation.t; + recursive : bool; + is_exn_handler : bool; + params : Bound_parameters.t; + parent_continuation : Continuation.t option; + used_in_handler : Name_occurrences.t; + bindings : Name_occurrences.t Name.Map.t; + direct_aliases : Simple.t Variable.Map.t; + mutable_let_prims_rev : Mutable_let_prim.List.t; + defined : Variable.Set.t; + code_ids : Name_occurrences.t Code_id.Map.t; + value_slots : Name_occurrences.t Name.Map.t Value_slot.Map.t; + apply_cont_args : + Cont_arg.t Numeric_types.Int.Map.t Apply_cont_rewrite_id.Map.t + Continuation.Map.t + } + + let [@ocamlformat "disable"] print ppf + { continuation; + recursive; + is_exn_handler; + params; + parent_continuation; + used_in_handler; + bindings; + direct_aliases; + mutable_let_prims_rev; + defined; + code_ids; + value_slots; + apply_cont_args + } = + Format.fprintf ppf "@[(\ + @[(continuation %a)@]@ \ + %s\ + %s\ + @[(params %a)@]@ \ + @[(parent_continuation %a)@]@ \ + @[(used_in_handler %a)@]@ \ + @[(bindings %a)@]@ \ + @[(direct_aliases %a)@]@ \ + @[(ref_prims %a)@]@ \ + @[(defined %a)@]@ \ + @[(code_ids %a)@]@ \ + @[(value_slots %a)@]@ \ + @[(apply_cont_args %a)@]\ + )@]" + Continuation.print continuation + (if recursive then "(recursive) " else "") + (if is_exn_handler then "(exn_handler) " else "") + Bound_parameters.print params + (Format.pp_print_option ~none:(fun ppf () -> Format.fprintf ppf "root") + Continuation.print) parent_continuation + Name_occurrences.print used_in_handler + (Name.Map.print Name_occurrences.print) bindings + (Variable.Map.print Simple.print) direct_aliases + Mutable_let_prim.List.print_rev mutable_let_prims_rev + Variable.Set.print + defined + (Code_id.Map.print Name_occurrences.print) + code_ids + (Value_slot.Map.print (Name.Map.print Name_occurrences.print)) + value_slots + (Continuation.Map.print (Apply_cont_rewrite_id.Map.print + (Numeric_types.Int.Map.print Cont_arg.print))) + apply_cont_args +end + +(* Flow accumulator *) +(* **************** *) + +module Acc = struct + type t = + { stack : Continuation_info.t list; + map : Continuation_info.t Continuation.Map.t; + extra : Continuation_extra_params_and_args.t Continuation.Map.t; + dummy_toplevel_cont : Continuation.t + } + + let print_stack ppf stack = + Format.fprintf ppf "@[(%a)@]" + (Format.pp_print_list Continuation_info.print + ~pp_sep:Format.pp_print_space) + stack + + let print_map ppf map = Continuation.Map.print Continuation_info.print ppf map + + let print_extra ppf extra = + Continuation.Map.print Continuation_extra_params_and_args.print ppf extra + + let [@ocamlformat "disable"] print ppf { stack; map; extra; dummy_toplevel_cont = _ } = + Format.fprintf ppf + "@[(\ + @[(stack %a)@]@ \ + @[(map %a)@]@ \ + @[(extra %a)@]\ + )@]" + print_stack stack + print_map map + print_extra extra +end + +(* Result of the flow analysis: reachable code ids *) +(* *********************************************** *) + +module Reachable_code_ids = struct + type t = + { live_code_ids : Code_id.Set.t; + ancestors_of_live_code_ids : Code_id.Set.t + } + + let [@ocamlformat "disable"] print ppf { live_code_ids; ancestors_of_live_code_ids; } = + Format.fprintf ppf "@[(\ + @[(live_code_ids@ %a)@]@ \ + @[(ancestors_of_live_code_ids@ %a)@]\ + )@]" + Code_id.Set.print live_code_ids + Code_id.Set.print ancestors_of_live_code_ids +end + +(* Result of the flow analysis: data flow analysis *) +(* *********************************************** *) + +module Data_flow_result = struct + type t = + { required_names : Name.Set.t; + reachable_code_ids : Reachable_code_ids.t Or_unknown.t + } + + let[@ocamlformat "disable"] print ppf + { required_names; reachable_code_ids; } = + Format.fprintf ppf + "@[(\ + @[(required_names@ %a)@]@ \ + @[(reachable_code_ids@ %a)@]@ \ + )@]" + Name.Set.print required_names + (Or_unknown.print Reachable_code_ids.print) reachable_code_ids +end + +(* Result of the flow analysis: aliased parameters of continuations *) +(* **************************************************************** *) + +module Continuation_param_aliases = struct + type recursive_continuation_wrapper = + | No_wrapper + | Wrapper_needed + + type t = + { removed_aliased_params_and_extra_params : Variable.Set.t; + lets_to_introduce : Variable.t Variable.Map.t; + extra_args_for_aliases : Variable.Set.t; + recursive_continuation_wrapper : recursive_continuation_wrapper + } + + let [@ocamlformat "disable"] print ppf + { removed_aliased_params_and_extra_params; lets_to_introduce; + extra_args_for_aliases; recursive_continuation_wrapper } = + let pp_wrapper ppf = function + | No_wrapper -> () + | Wrapper_needed -> + Format.fprintf ppf "@ @[(recursive_continuation_wrapper needed)@]" + in + Format.fprintf ppf + "@[(\ + @[(removed_aliased_params_and_extra_params %a)@]@ \ + @[(lets_to_introduce %a)@]\ + @[(extra_args_for_aliases %a)@]\ + %a\ + )@]" + Variable.Set.print removed_aliased_params_and_extra_params + (Variable.Map.print Variable.print) lets_to_introduce + Variable.Set.print extra_args_for_aliases + pp_wrapper recursive_continuation_wrapper +end + +(* Result of the flow analysis: alias analysis result *) +(* ************************************************** *) + +module Alias_result = struct + type t = + { aliases_kind : Flambda_kind.t Variable.Map.t; + continuation_parameters : Continuation_param_aliases.t Continuation.Map.t + } + + let [@ocamlformat "disable"] print ppf + { aliases_kind; continuation_parameters } = + Format.fprintf ppf + "@[(\ + @[(aliases_kind@ %a)@]@ \ + @[(continuation_parameters@ %a)@]\ + )@]" + (Variable.Map.print Flambda_kind.print) aliases_kind + (Continuation.Map.print Continuation_param_aliases.print) continuation_parameters +end + +(* Result of the flow analysis: mutable unboxing *) +(* ********************************************* *) + +module Mutable_unboxing_result = struct + type t = + { additionnal_epa : Continuation_extra_params_and_args.t Continuation.Map.t; + let_rewrites : Named_rewrite.t Named_rewrite_id.Map.t + } + + let [@ocamlformat "disable"] print ppf { additionnal_epa; let_rewrites } = + Format.fprintf ppf + "@[(\ + @[(additionnal_epa@ %a)@]@ \ + @[(let_rewrites@ %a)@]\ + )@]" + (Continuation.Map.print Continuation_extra_params_and_args.print) additionnal_epa + (Named_rewrite_id.Map.print Named_rewrite.print) let_rewrites +end + +(* Result of the flow analysis *) +(* *************************** *) + +module Flow_result = struct + type t = + { data_flow_result : Data_flow_result.t; + aliases_result : Alias_result.t; + mutable_unboxing_result : Mutable_unboxing_result.t + } + + let [@ocamlformat "disable"] print ppf + { data_flow_result; aliases_result; mutable_unboxing_result; } = + Format.fprintf ppf + "@[(\ + @[(data_flow_result@ %a)@]@ \ + @[(aliases_result@ %a)@]@ \ + @[(mutable_unboxing_result@ %a)@]\ + )@]" + Data_flow_result.print data_flow_result + Alias_result.print aliases_result + Mutable_unboxing_result.print mutable_unboxing_result +end diff --git a/middle_end/flambda2/simplify/flow/flow_types.mli b/middle_end/flambda2/simplify/flow/flow_types.mli new file mode 100644 index 00000000000..a61493b7e1a --- /dev/null +++ b/middle_end/flambda2/simplify/flow/flow_types.mli @@ -0,0 +1,204 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart and Guillaume Bury, OCamlPro *) +(* *) +(* Copyright 2021--2021 OCamlPro SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* CR chambart/gbury: we might want to also track function_slots in addition to + value_slots. *) + +(* CR-someday chambart/gbury: get rid of Name_occurences everywhere, this is not + small while we need only the names + + mshinwell: in practice I'm not sure this will make any difference *) + +(* Continuation arguments at call sites of continuations *) +(* ***************************************************** *) + +module Cont_arg : sig + type t = + | Function_result + | Simple of Simple.t + | New_let_binding of Variable.t * Name_occurrences.t + + val print : Format.formatter -> t -> unit +end + +(* Primitives that we must track for mutable unboxing *) +(* ************************************************** *) + +module Mutable_prim : sig + type t = + | Is_int of Variable.t + | Get_tag of Variable.t + | Block_load of + { bak : Flambda_primitive.Block_access_kind.t; + mut : Mutability.t; + block : Variable.t; + field : int + } + | Block_set of + { bak : Flambda_primitive.Block_access_kind.t; + block : Variable.t; + field : int; + value : Simple.t + } + | Make_block of + { kind : Flambda_primitive.Block_kind.t; + mut : Mutability.t; + alloc_mode : Alloc_mode.For_allocations.t; + fields : Simple.t list + } + + val print : Format.formatter -> t -> unit +end + +(* Bindings to primitive that we track for the mutable unboxing *) +(* ************************************************************ *) + +module Mutable_let_prim : sig + type t = + { bound_var : Variable.t; + prim : Mutable_prim.t; + original_prim : Flambda_primitive.t; + named_rewrite_id : Named_rewrite_id.t + } + + val print : Format.formatter -> t -> unit + + module List : sig + type nonrec t = t list + + val print_rev : Format.formatter -> t -> unit + end +end + +(* Accumulated flow information for a single continuation handler *) +(* ************************************************************** *) + +module Continuation_info : sig + type t = + { continuation : Continuation.t; + recursive : bool; + is_exn_handler : bool; + params : Bound_parameters.t; + parent_continuation : Continuation.t option; + used_in_handler : Name_occurrences.t; + bindings : Name_occurrences.t Name.Map.t; + direct_aliases : Simple.t Variable.Map.t; + mutable_let_prims_rev : Mutable_let_prim.List.t; + defined : Variable.Set.t; + code_ids : Name_occurrences.t Code_id.Map.t; + value_slots : Name_occurrences.t Name.Map.t Value_slot.Map.t; + apply_cont_args : + Cont_arg.t Numeric_types.Int.Map.t Apply_cont_rewrite_id.Map.t + Continuation.Map.t + } + + val print : Format.formatter -> t -> unit +end + +(* Flow accumulator *) +(* **************** *) + +module Acc : sig + type t = + { stack : Continuation_info.t list; + map : Continuation_info.t Continuation.Map.t; + extra : Continuation_extra_params_and_args.t Continuation.Map.t; + dummy_toplevel_cont : Continuation.t + } + + val print : Format.formatter -> t -> unit +end + +(* Result of the flow analysis: reachable code ids *) +(* *********************************************** *) + +module Reachable_code_ids : sig + type t = + { live_code_ids : Code_id.Set.t; (** The set of code ids live/reachable. *) + ancestors_of_live_code_ids : Code_id.Set.t + (** The set of code ids that are ancestors of at least one live code + id. *) + } + + val print : Format.formatter -> t -> unit +end + +(* Result of the flow analysis: data flow analysis *) +(* *********************************************** *) + +module Data_flow_result : sig + type t = + { required_names : Name.Set.t; + (** The set of all variables that are in fact used to compute the + returned value of the function being analyzed. *) + reachable_code_ids : Reachable_code_ids.t Or_unknown.t + } + + val print : Format.formatter -> t -> unit +end + +(* Result of the flow analysis: aliased parameters of continuations *) +(* **************************************************************** *) + +module Continuation_param_aliases : sig + type recursive_continuation_wrapper = + | No_wrapper + | Wrapper_needed + + type t = + { removed_aliased_params_and_extra_params : Variable.Set.t; + lets_to_introduce : Variable.t Variable.Map.t; + extra_args_for_aliases : Variable.Set.t; + recursive_continuation_wrapper : recursive_continuation_wrapper + } + + val print : Format.formatter -> t -> unit +end + +(* Result of the flow analysis: alias analysis result *) +(* ************************************************** *) + +module Alias_result : sig + type t = + { aliases_kind : Flambda_kind.t Variable.Map.t; + continuation_parameters : Continuation_param_aliases.t Continuation.Map.t + } + + val print : Format.formatter -> t -> unit +end + +(* Result of the flow analysis: mutable unboxing *) +(* ********************************************* *) + +module Mutable_unboxing_result : sig + type t = + { additionnal_epa : Continuation_extra_params_and_args.t Continuation.Map.t; + let_rewrites : Named_rewrite.t Named_rewrite_id.Map.t + } + + val print : Format.formatter -> t -> unit +end + +(* Result of the flow analysis *) +(* *************************** *) + +module Flow_result : sig + type t = + { data_flow_result : Data_flow_result.t; + aliases_result : Alias_result.t; + mutable_unboxing_result : Mutable_unboxing_result.t + } + + val print : Format.formatter -> t -> unit +end diff --git a/middle_end/flambda2/simplify/flow/mutable_unboxing.ml b/middle_end/flambda2/simplify/flow/mutable_unboxing.ml new file mode 100644 index 00000000000..98d386780c3 --- /dev/null +++ b/middle_end/flambda2/simplify/flow/mutable_unboxing.ml @@ -0,0 +1,664 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart and Guillaume Bury, OCamlPro *) +(* *) +(* Copyright 2021--2021 OCamlPro SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module T = Flow_types +module EPA = Continuation_extra_params_and_args + +(* Types *) + +type non_escaping_block = + { tag : Tag.t; + fields_kinds : Flambda_kind.With_subkind.t list + } + +type extra_params = Bound_parameter.t list + +type extra_args = + Simple.t Numeric_types.Int.Map.t Apply_cont_rewrite_id.Map.t + Continuation.Map.t + +type t = + { non_escaping_makeblocks : non_escaping_block Variable.Map.t; + continuations_with_live_block : Variable.Set.t Continuation.Map.t; + extra_params_and_args : (extra_params * extra_args) Continuation.Map.t; + rewrites : Named_rewrite.t Named_rewrite_id.Map.t + } + +(* Escaping analysis *) + +let free_names_of_apply_cont_args + (apply_cont_args : + T.Cont_arg.t Numeric_types.Int.Map.t Apply_cont_rewrite_id.Map.t) : + Variable.Set.t = + Apply_cont_rewrite_id.Map.fold + (fun _ args free -> + Numeric_types.Int.Map.fold + (fun _ (arg : T.Cont_arg.t) free -> + match arg with + | Function_result -> free + | New_let_binding _ -> + free (* Doesn't really matter, already escaping *) + | Simple s -> ( + match Simple.must_be_var s with + | None -> free + | Some (var, _coer) -> Variable.Set.add var free)) + args free) + apply_cont_args Variable.Set.empty + +let escaping_by_alias ~(dom : Dominator_graph.alias_map) + ~(dom_graph : Dominator_graph.t) = + Variable.Map.fold + (fun flow_to flow_from escaping -> + let alias_to = + match Variable.Map.find flow_to dom with + | exception Not_found -> flow_to + | v -> v + in + let new_escaping = + Variable.Set.fold + (fun flow_from escaping -> + let alias_from = + match Variable.Map.find flow_from dom with + | exception Not_found -> flow_from + | v -> v + in + let is_escaping = not (Variable.equal alias_to alias_from) in + if is_escaping + then Variable.Set.add alias_from escaping + else escaping) + flow_from Variable.Set.empty + in + Variable.Set.union escaping new_escaping) + dom_graph.graph Variable.Set.empty + +let names_escaping_from_mutable_prim (prim : T.Mutable_prim.t) = + match prim with + | Make_block { fields; _ } -> Simple.List.free_names fields + | Block_set { value; _ } -> Simple.free_names value + | Is_int _ | Get_tag _ | Block_load _ -> Name_occurrences.empty + +let names_used_in_new_let_binding (elt : T.Continuation_info.t) = + Continuation.Map.fold + (fun _cont apply_cont_args vars -> + Apply_cont_rewrite_id.Map.fold + (fun _ args vars -> + Numeric_types.Int.Map.fold + (fun _ (arg : T.Cont_arg.t) vars -> + match arg with + | Function_result | Simple _ -> vars + | New_let_binding (_, deps) -> + Name_occurrences.fold_variables deps ~init:vars + ~f:(fun vars v -> Variable.Set.add v vars)) + args vars) + apply_cont_args vars) + elt.apply_cont_args Variable.Set.empty + +let escaping_by_use_for_one_continuation ~required_names + ~(dom : Dominator_graph.alias_map) (elt : T.Continuation_info.t) = + let add_name_occurrences occurrences init = + Name_occurrences.fold_variables occurrences ~init ~f:(fun escaping var -> + let escaping = + match Variable.Map.find var dom with + | exception Not_found -> escaping + | var -> Variable.Set.add var escaping + in + Variable.Set.add var escaping) + in + let escaping = add_name_occurrences elt.used_in_handler Variable.Set.empty in + let escaping = + Name.Map.fold + (fun name deps escaping -> + if Name.Set.mem name required_names + then add_name_occurrences deps escaping + else escaping) + elt.bindings escaping + in + let escaping = + (* CR ncourant: we could track primitives here as other primitives here + (mainly [Block_load]), but the usefulness of this is unclear for now. + + See [flambda2/tests/ref_to_var/unboxing_cse.ml] *) + Variable.Set.fold + (fun var escaping -> + match Variable.Map.find var dom with + | exception Not_found -> escaping + | var -> Variable.Set.add var escaping) + (names_used_in_new_let_binding elt) + escaping + in + let escaping = + Value_slot.Map.fold + (fun _value_slot map escaping -> + Name.Map.fold + (fun _closure_name values_in_env escaping -> + add_name_occurrences values_in_env escaping) + map escaping) + elt.value_slots escaping + in + let escaping = + List.fold_left + (fun escaping T.Mutable_let_prim.{ prim; _ } -> + add_name_occurrences (names_escaping_from_mutable_prim prim) escaping) + escaping elt.mutable_let_prims_rev + in + escaping + +let escaping_by_use ~required_names ~(dom : Dominator_graph.alias_map) + ~(source_info : T.Acc.t) = + Continuation.Map.fold + (fun _cont elt escaping -> + Variable.Set.union + (escaping_by_use_for_one_continuation ~required_names ~dom elt) + escaping) + source_info.map Variable.Set.empty + +let escaping_by_return ~(dom : Dominator_graph.alias_map) + ~(source_info : T.Acc.t) ~return_continuation ~exn_continuation = + Continuation.Map.fold + (fun _cont (elt : T.Continuation_info.t) escaping -> + let add_escaping cont escaping = + match Continuation.Map.find cont elt.apply_cont_args with + | exception Not_found -> escaping + | apply_cont_args -> + Variable.Set.fold + (fun var escaping -> + let escaping = + match Variable.Map.find var dom with + | exception Not_found -> escaping + | var -> Variable.Set.add var escaping + in + Variable.Set.add var escaping) + (free_names_of_apply_cont_args apply_cont_args) + escaping + in + let escaping = add_escaping return_continuation escaping in + add_escaping exn_continuation escaping) + source_info.map Variable.Set.empty + +let escaping ~(dom : Dominator_graph.alias_map) ~(dom_graph : Dominator_graph.t) + ~(source_info : T.Acc.t) ~return_continuation ~exn_continuation + ~required_names = + let escaping_by_alias = escaping_by_alias ~dom ~dom_graph in + let escaping_by_use = escaping_by_use ~required_names ~dom ~source_info in + let escaping_by_return = + escaping_by_return ~dom ~source_info ~return_continuation ~exn_continuation + in + Variable.Set.union escaping_by_alias + (Variable.Set.union escaping_by_return escaping_by_use) + +(* *) + +let non_escaping_makeblocks ~escaping ~source_info = + Continuation.Map.fold + (fun _cont (elt : T.Continuation_info.t) map -> + List.fold_left + (fun map T.Mutable_let_prim.{ bound_var = var; prim; _ } -> + match prim with + | Block_load _ | Block_set _ | Is_int _ | Get_tag _ -> map + | Make_block { kind; alloc_mode = _; fields; _ } -> + if Variable.Set.mem var escaping + then map + else + let non_escaping_block = + match kind with + | Values (tag, fields_kinds) -> + { tag = Tag.Scannable.to_tag tag; fields_kinds } + | Naked_floats -> + { tag = Tag.double_array_tag; + fields_kinds = + List.map + (fun _ -> Flambda_kind.With_subkind.naked_float) + fields + } + in + Variable.Map.add var non_escaping_block map) + map elt.mutable_let_prims_rev) + source_info.T.Acc.map Variable.Map.empty + +let prims_using_block ~non_escaping_blocks ~dom prim = + match (prim : T.Mutable_prim.t) with + | Make_block _ -> Variable.Set.empty + | Is_int block + | Get_tag block + | Block_set { block; _ } + | Block_load { block; _ } -> + let block = + match Variable.Map.find block dom with + | exception Not_found -> block + | block -> block + in + if Variable.Map.mem block non_escaping_blocks + then Variable.Set.singleton block + else Variable.Set.empty + +let continuations_using_blocks ~non_escaping_blocks ~dom + ~(source_info : T.Acc.t) = + Continuation.Map.mapi + (fun _cont (elt : T.Continuation_info.t) -> + let used = + List.fold_left + (fun used_block T.Mutable_let_prim.{ prim; _ } -> + Variable.Set.union used_block + (prims_using_block ~non_escaping_blocks ~dom prim)) + Variable.Set.empty elt.mutable_let_prims_rev + in + if (not (Variable.Set.is_empty used)) && Flambda_features.dump_flow () + then + Format.printf "Cont using block %a %a@." Continuation.print _cont + Variable.Set.print used; + used) + source_info.map + +let continuations_defining_blocks ~non_escaping_blocks ~(source_info : T.Acc.t) + = + Continuation.Map.mapi + (fun _cont (elt : T.Continuation_info.t) -> + let defined = + List.fold_left + (fun defined_blocks T.Mutable_let_prim.{ bound_var = var; _ } -> + if Variable.Map.mem var non_escaping_blocks + then Variable.Set.add var defined_blocks + else defined_blocks) + Variable.Set.empty elt.mutable_let_prims_rev + in + if (not (Variable.Set.is_empty defined)) && Flambda_features.dump_flow () + then + Format.printf "Cont defining block %a %a@." Continuation.print _cont + Variable.Set.print defined; + defined) + source_info.map + +let continuations_with_live_block ~non_escaping_blocks ~dom ~source_info + ~(control_flow_graph : Control_flow_graph.t) = + let continuations_defining_blocks = + continuations_defining_blocks ~non_escaping_blocks ~source_info + in + let continuations_using_blocks = + continuations_using_blocks ~non_escaping_blocks ~dom ~source_info + in + let continuations_using_blocks_but_not_defining_them = + Continuation.Map.merge + (fun _cont defined used -> + match defined, used with + | None, None -> assert false (* *) + | None, Some _used -> + Misc.fatal_errorf + "In Data_flow: incomplete map of continuation defining blocks" + | Some _defined, None -> + Misc.fatal_errorf + "In Data_flow: incomplete map of continuation using blocks" + | Some defined, Some used -> Some (Variable.Set.diff used defined)) + continuations_defining_blocks continuations_using_blocks + in + Control_flow_graph.fixpoint control_flow_graph + ~init:continuations_using_blocks_but_not_defining_them + ~f:(fun + ~caller + ~caller_set:old_using_blocks + ~callee:_ + ~callee_set:used_blocks + -> + let defined_blocks = + Continuation.Map.find caller continuations_defining_blocks + in + Variable.Set.diff + (Variable.Set.union old_using_blocks used_blocks) + defined_blocks) + +let list_to_int_map l = + let _, map = + List.fold_left + (fun (i, fields) elt -> + let fields = Numeric_types.Int.Map.add i elt fields in + i + 1, fields) + (0, Numeric_types.Int.Map.empty) + l + in + map + +let int_map_to_list m = List.map snd (Numeric_types.Int.Map.bindings m) + +module Fold_prims = struct + type env = + { bindings : Simple.t Numeric_types.Int.Map.t Variable.Map.t; + (* non escaping / unboxed blocks fields values *) + rewrites : Named_rewrite.t Named_rewrite_id.Map.t + } + + let with_unboxed_block ~block ~dom ~env ~non_escaping_blocks ~f = + let block = + match Variable.Map.find block dom with + | exception Not_found -> block + | block -> block + in + match Variable.Map.find block non_escaping_blocks with + | exception Not_found -> env + | { tag; fields_kinds } -> f ~block ~tag ~fields_kinds + + let with_unboxed_fields ~block ~dom ~env ~f = + let block = + match Variable.Map.find block dom with + | exception Not_found -> block + | block -> block + in + match Variable.Map.find block env.bindings with + | exception Not_found -> env + | fields -> f ~block fields + + let apply_prim ~dom ~non_escaping_blocks env rewrite_id var + (prim : T.Mutable_prim.t) = + match prim with + | Is_int block -> + with_unboxed_fields ~block ~dom ~env ~f:(fun ~block _fields -> + ignore block; + (* ensure that only the canonical alias of block is in scope *) + (* We only consider for unboxing vluaes which are aliases to a single + makeblock. In particular, for variants, this means that we only + consider for unboxing variant values which are blocks. *) + let bound_to = Simple.untagged_const_bool false in + let rewrite = + Named_rewrite.prim_rewrite + (Named_rewrite.Prim_rewrite.replace_by_binding ~var ~bound_to) + in + { env with + rewrites = Named_rewrite_id.Map.add rewrite_id rewrite env.rewrites + }) + | Get_tag block -> + with_unboxed_block ~block ~dom ~env ~non_escaping_blocks + ~f:(fun ~block ~tag ~fields_kinds:_ -> + ignore block; + (* ensure that only the canonical alias of block is in scope *) + let bound_to = + Simple.untagged_const_int (Tag.to_targetint_31_63 tag) + in + let rewrite = + Named_rewrite.prim_rewrite + (Named_rewrite.Prim_rewrite.replace_by_binding ~var ~bound_to) + in + { env with + rewrites = Named_rewrite_id.Map.add rewrite_id rewrite env.rewrites + }) + | Block_load { block; field; bak; _ } -> + with_unboxed_fields ~block ~dom ~env ~f:(fun ~block fields -> + ignore block; + (* ensure that only the canonical alias of block is in scope *) + let rewrite = + match Numeric_types.Int.Map.find field fields with + | bound_to -> + Named_rewrite.prim_rewrite + (Named_rewrite.Prim_rewrite.replace_by_binding ~var ~bound_to) + | exception Not_found -> + let k = + Flambda_primitive.Block_access_kind.element_kind_for_load bak + in + Named_rewrite.prim_rewrite (Named_rewrite.Prim_rewrite.invalid k) + in + { env with + rewrites = Named_rewrite_id.Map.add rewrite_id rewrite env.rewrites + }) + | Block_set { bak; block; field; value } -> + with_unboxed_fields ~block ~dom ~env ~f:(fun ~block fields -> + if Flambda_features.dump_flow () + then Format.printf "Remove Block set %a@." Variable.print var; + let rewrite, fields = + if Numeric_types.Int.Map.mem field fields + then + ( Named_rewrite.prim_rewrite Named_rewrite.Prim_rewrite.remove_prim, + Numeric_types.Int.Map.add field value fields ) + else + let k = + Flambda_primitive.Block_access_kind.element_kind_for_load bak + in + ( Named_rewrite.prim_rewrite (Named_rewrite.Prim_rewrite.invalid k), + fields ) + in + { bindings = Variable.Map.add block fields env.bindings; + rewrites = Named_rewrite_id.Map.add rewrite_id rewrite env.rewrites + }) + | Make_block { fields; _ } -> + if not (Variable.Map.mem var non_escaping_blocks) + then env + else ( + if Flambda_features.dump_flow () + then Format.printf "Remove Makeblock %a@." Variable.print var; + let rewrite = + Named_rewrite.prim_rewrite Named_rewrite.Prim_rewrite.remove_prim + in + let fields = list_to_int_map fields in + { bindings = Variable.Map.add var fields env.bindings; + rewrites = Named_rewrite_id.Map.add rewrite_id rewrite env.rewrites + }) + + let init_env ~(non_escaping_blocks : non_escaping_block Variable.Map.t) + ~(blocks_needed : Variable.Set.t) ~rewrites = + let env, params = + Variable.Set.fold + (fun block_needed (env, params) -> + let { tag = _; fields_kinds } = + Variable.Map.find block_needed non_escaping_blocks + in + let block_params = + List.mapi + (fun i kind -> + let name = Variable.unique_name block_needed in + let var = Variable.create (Printf.sprintf "%s_%i" name i) in + Bound_parameter.create var kind) + fields_kinds + in + let env = + let fields = + list_to_int_map + (List.map + (fun bp -> Simple.var (Bound_parameter.var bp)) + block_params) + in + { env with + bindings = Variable.Map.add block_needed fields env.bindings + } + in + env, List.rev_append block_params params) + blocks_needed + ({ bindings = Variable.Map.empty; rewrites }, []) + in + env, List.rev params + + let append_int_map i1 i2 = + if Numeric_types.Int.Map.is_empty i1 + then i2 + else + let max, _ = Numeric_types.Int.Map.max_binding i1 in + let shifted_i2 = + Numeric_types.Int.Map.map_keys (fun i -> i + max + 1) i2 + in + Numeric_types.Int.Map.disjoint_union i1 shifted_i2 + + let compute_rewrites + ~(non_escaping_blocks : non_escaping_block Variable.Map.t) + ~continuations_with_live_block ~dom ~(source_info : T.Acc.t) = + let rewrites = ref Named_rewrite_id.Map.empty in + let extra_params_and_args = + Continuation.Map.mapi + (fun cont (blocks_needed : Variable.Set.t) -> + let elt = Continuation.Map.find cont source_info.map in + let env, extra_block_params = + init_env ~non_escaping_blocks ~blocks_needed ~rewrites:!rewrites + in + let env = + List.fold_left + (fun env + T.Mutable_let_prim. + { named_rewrite_id; bound_var; prim; original_prim = _ } -> + apply_prim ~dom ~non_escaping_blocks env named_rewrite_id + bound_var prim) + env + (List.rev elt.mutable_let_prims_rev) + in + rewrites := env.rewrites; + let blocks_params_to_add cont rewrites = + Apply_cont_rewrite_id.Map.map + (fun _args -> + match + Continuation.Map.find cont continuations_with_live_block + with + | exception Not_found -> Numeric_types.Int.Map.empty + | blocks_needed -> + let extra_args = + Variable.Set.fold + (fun block_needed extra_args -> + let args = + Variable.Map.find block_needed env.bindings + in + append_int_map extra_args args) + blocks_needed Numeric_types.Int.Map.empty + in + extra_args) + rewrites + in + let new_apply_cont_args = + Continuation.Map.mapi blocks_params_to_add elt.apply_cont_args + in + extra_block_params, new_apply_cont_args) + continuations_with_live_block + in + extra_params_and_args, !rewrites +end + +let create ~(dom : Dominator_graph.alias_map) ~(dom_graph : Dominator_graph.t) + ~(source_info : T.Acc.t) ~(control_flow_graph : Control_flow_graph.t) + ~required_names ~return_continuation ~exn_continuation : t = + let escaping = + escaping ~dom ~dom_graph ~source_info ~required_names ~return_continuation + ~exn_continuation + in + let non_escaping_blocks = non_escaping_makeblocks ~escaping ~source_info in + if (not (Variable.Map.is_empty non_escaping_blocks)) + && Flambda_features.dump_flow () + then + Format.printf "Non escaping makeblocks %a@." + (Variable.Map.print (fun ppf { tag; fields_kinds } -> + Format.fprintf ppf "{%a}[%a]" Tag.print tag + (Format.pp_print_list ~pp_sep:Format.pp_print_space + Flambda_kind.With_subkind.print) + fields_kinds)) + non_escaping_blocks; + let continuations_with_live_block = + continuations_with_live_block ~non_escaping_blocks ~dom ~source_info + ~control_flow_graph + in + let toplevel_used = + Continuation.Map.find source_info.dummy_toplevel_cont + continuations_with_live_block + in + if not (Variable.Set.is_empty toplevel_used) + then + Misc.fatal_errorf + "Toplevel continuation cannot have needed extra argument for block: %a@." + Variable.Set.print toplevel_used; + let extra_params_and_args, rewrites = + Fold_prims.compute_rewrites ~dom ~source_info ~continuations_with_live_block + ~non_escaping_blocks + in + { extra_params_and_args; + non_escaping_makeblocks = non_escaping_blocks; + continuations_with_live_block; + rewrites + } + +let pp_node { non_escaping_makeblocks = _; continuations_with_live_block; _ } + ppf cont = + match Continuation.Map.find cont continuations_with_live_block with + | exception Not_found -> () + | live_blocks -> Format.fprintf ppf " %a" Variable.Set.print live_blocks + +let add_to_extra_params_and_args result = + let epa = Continuation.Map.empty in + let extra_block_args : + EPA.Extra_arg.t Apply_cont_rewrite_id.Map.t list Continuation.Map.t = + Continuation.Map.fold + (fun _caller_cont (_extra_params, extra_args) all_extra_args -> + Continuation.Map.fold + (fun callee_cont + (caller_extra_args : + Simple.t Numeric_types.Int.Map.t Apply_cont_rewrite_id.Map.t) + (all_extra_args : + EPA.Extra_arg.t Apply_cont_rewrite_id.Map.t list + Continuation.Map.t) : + EPA.Extra_arg.t Apply_cont_rewrite_id.Map.t list + Continuation.Map.t -> + Continuation.Map.update callee_cont + (fun previous_extra_args -> + let previous_extra_args : + EPA.Extra_arg.t Apply_cont_rewrite_id.Map.t list = + match previous_extra_args with + | None -> ( + match + Continuation.Map.find callee_cont + result.extra_params_and_args + with + | exception Not_found -> [] + | extra_params, _ -> + List.map + (fun _ -> Apply_cont_rewrite_id.Map.empty) + extra_params) + | Some extra_args -> extra_args + in + let extra_args = + Apply_cont_rewrite_id.Map.fold + (fun rewrite_id (args : Simple.t Numeric_types.Int.Map.t) + (previous_extra_args : + EPA.Extra_arg.t Apply_cont_rewrite_id.Map.t list) -> + let args = int_map_to_list args in + List.map2 + (fun arg previous_extra_args -> + Apply_cont_rewrite_id.Map.add rewrite_id + (EPA.Extra_arg.Already_in_scope arg) + previous_extra_args) + args previous_extra_args) + caller_extra_args previous_extra_args + in + Some extra_args) + all_extra_args) + extra_args all_extra_args) + result.extra_params_and_args Continuation.Map.empty + in + let epa = + Continuation.Map.fold + (fun cont extra_args epa -> + let extra_params = + match Continuation.Map.find cont result.extra_params_and_args with + | exception Not_found -> [] + | extra_params, _ -> extra_params + in + Continuation.Map.update cont + (fun epa_for_cont -> + let epa_for_cont = + match epa_for_cont with None -> EPA.empty | Some epa -> epa + in + let epa_for_cont = + List.fold_left2 + (fun epa_for_cont extra_param extra_args -> + EPA.add epa_for_cont ~extra_param ~extra_args) + epa_for_cont extra_params extra_args + in + Some epa_for_cont) + epa) + extra_block_args epa + in + epa + +let make_result result = + let additionnal_epa = add_to_extra_params_and_args result in + let let_rewrites = result.rewrites in + ( T.Mutable_unboxing_result.{ additionnal_epa; let_rewrites }, + Variable.Map.keys result.non_escaping_makeblocks ) diff --git a/middle_end/flambda2/simplify/flow/mutable_unboxing.mli b/middle_end/flambda2/simplify/flow/mutable_unboxing.mli new file mode 100644 index 00000000000..66db5443411 --- /dev/null +++ b/middle_end/flambda2/simplify/flow/mutable_unboxing.mli @@ -0,0 +1,29 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart and Guillaume Bury, OCamlPro *) +(* *) +(* Copyright 2021--2021 OCamlPro SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type t + +val create : + dom:Dominator_graph.alias_map -> + dom_graph:Dominator_graph.t -> + source_info:Flow_types.Acc.t -> + control_flow_graph:Control_flow_graph.t -> + required_names:Name.Set.t -> + return_continuation:Continuation.t -> + exn_continuation:Continuation.t -> + t + +val make_result : t -> Flow_types.Mutable_unboxing_result.t * Variable.Set.t + +val pp_node : t -> Format.formatter -> Continuation.t -> unit diff --git a/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.ml b/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.ml index c63a9b574dd..4d620452fe8 100644 --- a/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.ml +++ b/middle_end/flambda2/simplify/inlining/call_site_inlining_decision.ml @@ -64,20 +64,21 @@ let speculative_inlining dacc ~apply ~function_type ~simplify_expr ~return_arity in let scope = DE.get_continuation_scope (DA.denv dacc) in let dummy_toplevel_cont = - Continuation.create ~name:"dummy_toplevel_continuation" () + Continuation.create ~name:"speculative_inlining_toplevel_continuation" () in let dacc = - DA.map_data_flow dacc ~f:(fun _ -> - Data_flow.init_toplevel dummy_toplevel_cont [] Data_flow.empty) + DA.map_flow_acc dacc ~f:(fun _ -> + Flow.Acc.init_toplevel ~dummy_toplevel_cont Bound_parameters.empty + (Flow.Acc.empty ())) in let _, uacc = simplify_expr dacc expr ~down_to_up:(fun dacc ~rebuild -> let exn_continuation = Apply.exn_continuation apply in let dacc = - DA.map_data_flow dacc - ~f:(Data_flow.exit_continuation dummy_toplevel_cont) + DA.map_flow_acc dacc + ~f:(Flow.Acc.exit_continuation dummy_toplevel_cont) in - let data_flow = DA.data_flow dacc in + let data_flow = DA.flow_acc dacc in (* The dataflow analysis *) let function_return_cont = match Apply.continuation apply with @@ -92,8 +93,9 @@ let speculative_inlining dacc ~apply ~function_type ~simplify_expr ~return_arity Thus we here provide empty/dummy values for the used_value_slots and code_age_relation, and ignore the reachable_code_id part of the data_flow analysis. *) - let ({ required_names; reachable_code_ids = _ } : Data_flow.result) = - Data_flow.analyze data_flow ~code_age_relation:Code_age_relation.empty + let flow_result = + Flow.Analysis.analyze data_flow ~speculative:true + ~print_name:"speculative" ~code_age_relation:Code_age_relation.empty ~used_value_slots:Unknown ~return_continuation:function_return_cont ~exn_continuation:(Exn_continuation.exn_handler exn_continuation) in @@ -117,8 +119,7 @@ let speculative_inlining dacc ~apply ~function_type ~simplify_expr ~return_arity scope return_arity in let uacc = - UA.create ~required_names ~reachable_code_ids:Unknown - ~compute_slot_offsets:false uenv dacc + UA.create ~flow_result ~compute_slot_offsets:false uenv dacc in rebuild uacc ~after_rebuild:(fun expr uacc -> expr, uacc)) in @@ -195,6 +196,15 @@ let make_decision dacc ~simplify_expr ~function_type ~apply ~return_arity : in if not (Code_or_metadata.code_present code_or_metadata) then Missing_code + else if Loopify_attribute.was_loopified + (Code_metadata.loopify + (Code_or_metadata.code_metadata code_or_metadata)) + && + match inlined with + | Unroll _ -> true + | Never_inlined | Default_inlined | Always_inlined | Hint_inlined -> + false + then Unroll_attribute_used_with_loopified_function else (* The unrolling process is rather subtle, but it boils down to two steps: diff --git a/middle_end/flambda2/simplify/inlining/inlining_transforms.ml b/middle_end/flambda2/simplify/inlining/inlining_transforms.ml index 134c431e757..77c68dcf20b 100644 --- a/middle_end/flambda2/simplify/inlining/inlining_transforms.ml +++ b/middle_end/flambda2/simplify/inlining/inlining_transforms.ml @@ -92,11 +92,7 @@ let inline dacc ~apply ~unroll_to ~was_inline_always function_decl = (* CR-someday mshinwell: Add meet constraint to the return continuation *) let denv = DA.denv dacc in let code = - match DE.find_code_exn denv (FT.code_id function_decl) with - | Code_present code -> code - | Metadata_only code_metadata -> - Misc.fatal_errorf "Cannot inline using only code metadata:@ %a" - Code_metadata.print code_metadata + Code_or_metadata.get_code (DE.find_code_exn denv (FT.code_id function_decl)) in let rec_info = match T.meet_rec_info (DE.typing_env denv) (FT.rec_info function_decl) with diff --git a/middle_end/flambda2/simplify/join_points.ml b/middle_end/flambda2/simplify/join_points.ml index 5549af66f90..0f357973413 100644 --- a/middle_end/flambda2/simplify/join_points.ml +++ b/middle_end/flambda2/simplify/join_points.ml @@ -25,9 +25,9 @@ type result = escapes : bool } -let join ?cut_after denv typing_env params ~env_at_fork_plus_params - ~consts_lifted_during_body ~use_envs_with_ids = - let definition_scope = DE.get_continuation_scope env_at_fork_plus_params in +let join ?cut_after denv params ~consts_lifted_during_body ~use_envs_with_ids = + let typing_env = DE.typing_env denv in + let definition_scope = DE.get_continuation_scope denv in let extra_lifted_consts_in_use_envs = LCS.all_defined_symbols consts_lifted_during_body in @@ -96,26 +96,27 @@ let meet_equations_on_params typing_env ~params:params' ~param_types = param_types; List.fold_left2 (fun typing_env param param_type -> - let kind = Bound_parameter.kind param |> Flambda_kind.With_subkind.kind in + let kind = Bound_parameter.kind param in + let raw_kind = Flambda_kind.With_subkind.kind kind in let name = Bound_parameter.name param in - let existing_type = TE.find typing_env name (Some kind) in - match T.meet typing_env existing_type param_type with + let type_from_kind = T.unknown_with_subkind kind in + match T.meet typing_env type_from_kind param_type with | Bottom -> (* This should really replace the corresponding uses with [Invalid], but this seems an unusual situation, so we don't do that currently. *) - TE.add_equation typing_env name (T.bottom kind) + TE.add_equation typing_env name (T.bottom raw_kind) | Ok (meet_ty, env_extension) -> let typing_env = TE.add_equation typing_env name meet_ty in TE.add_env_extension typing_env env_extension) typing_env params param_types -let compute_handler_env ?cut_after uses ~env_at_fork_plus_params - ~consts_lifted_during_body ~params ~code_age_relation_after_body = - (* Augment the environment at each use with the necessary equations about the - parameters (whose variables will already be defined in the environment). *) +let compute_handler_env ?cut_after uses ~env_at_fork ~consts_lifted_during_body + ~params ~code_age_relation_after_body = + (* Augment the environment at each use with the parameter definitions and + associated equations. *) let need_to_meet_param_types = (* If there is information available from the subkinds of the parameters, we - will need to meet the existing parameter types (e.g. "unknown boxed + will need to meet the types from the subkinds (e.g. "unknown boxed float") with the argument types at each use. *) Bound_parameters.exists (fun param -> @@ -127,6 +128,7 @@ let compute_handler_env ?cut_after uses ~env_at_fork_plus_params List.map (fun use -> let add_or_meet_param_type typing_env = + let typing_env = TE.add_definitions_of_params typing_env ~params in let param_types = U.arg_types use in if need_to_meet_param_types then meet_equations_on_params typing_env ~params ~param_types @@ -161,17 +163,20 @@ let compute_handler_env ?cut_after uses ~env_at_fork_plus_params handler is simplified using the depth from the fork environment. Likewise for the inlining history tracker and debuginfo. *) let handler_env = - DE.set_inlining_state handler_env - (DE.get_inlining_state env_at_fork_plus_params) + DE.set_inlining_state handler_env (DE.get_inlining_state env_at_fork) in let handler_env = DE.set_inlining_history_tracker - (DE.inlining_history_tracker env_at_fork_plus_params) + (DE.inlining_history_tracker env_at_fork) handler_env in let handler_env = DE.set_inlined_debuginfo handler_env - (DE.get_inlined_debuginfo env_at_fork_plus_params) + (DE.get_inlined_debuginfo env_at_fork) + in + let handler_env = + DE.set_at_unit_toplevel_state handler_env + (DE.at_unit_toplevel env_at_fork) in { handler_env; arg_types_by_use_id; @@ -187,10 +192,7 @@ let compute_handler_env ?cut_after uses ~env_at_fork_plus_params overall makes things easier; the join operation can just discard any equation about a lifted constant (any such equation could not be materially more precise anyway). *) - let denv = - LCS.add_to_denv env_at_fork_plus_params consts_lifted_during_body - in - let typing_env = DE.typing_env denv in + let denv = LCS.add_to_denv env_at_fork consts_lifted_during_body in let should_do_join = Flambda_features.join_points () || match use_envs_with_ids with [] | [_] -> true | _ :: _ :: _ -> false @@ -198,9 +200,15 @@ let compute_handler_env ?cut_after uses ~env_at_fork_plus_params let handler_env, extra_params_and_args = if should_do_join then - join ?cut_after denv typing_env params ~env_at_fork_plus_params - ~consts_lifted_during_body ~use_envs_with_ids - else denv, Continuation_extra_params_and_args.empty + (* No need to add equations, as they will be computed from the use + environments *) + let denv = DE.define_parameters denv ~params in + join ?cut_after denv params ~consts_lifted_during_body + ~use_envs_with_ids + else + (* Define parameters with basic equations from the subkinds *) + let denv = DE.add_parameters_with_unknown_types denv params in + denv, Continuation_extra_params_and_args.empty in let handler_env = DE.map_typing_env handler_env ~f:(fun handler_env -> diff --git a/middle_end/flambda2/simplify/join_points.mli b/middle_end/flambda2/simplify/join_points.mli index 1f69abaa2ea..c1af265e201 100644 --- a/middle_end/flambda2/simplify/join_points.mli +++ b/middle_end/flambda2/simplify/join_points.mli @@ -29,7 +29,7 @@ type result = private val compute_handler_env : ?cut_after:Scope.t -> Continuation_uses.t -> - env_at_fork_plus_params:Downwards_env.t -> + env_at_fork:Downwards_env.t -> consts_lifted_during_body:Lifted_constant_state.t -> params:Bound_parameters.t -> code_age_relation_after_body:Code_age_relation.t -> diff --git a/middle_end/flambda2/simplify/lifting/lifted_constant.ml b/middle_end/flambda2/simplify/lifting/lifted_constant.ml index 2369871e7f2..e5e783cd269 100644 --- a/middle_end/flambda2/simplify/lifting/lifted_constant.ml +++ b/middle_end/flambda2/simplify/lifting/lifted_constant.ml @@ -294,7 +294,8 @@ let apply_projection t proj = | Block_load { index } -> T.meet_block_field_simple typing_env ~min_name_mode:Name_mode.normal ty index - | Project_value_slot { project_from = _; value_slot } -> + | Project_value_slot { project_from = _; value_slot; kind = _ } -> + (* CR mshinwell: could use [kind]? *) T.meet_project_value_slot_simple typing_env ~min_name_mode:Name_mode.normal ty value_slot in diff --git a/middle_end/flambda2/simplify/lifting/lifted_constant_state.ml b/middle_end/flambda2/simplify/lifting/lifted_constant_state.ml index 4f78d31e472..d92865059a3 100644 --- a/middle_end/flambda2/simplify/lifting/lifted_constant_state.ml +++ b/middle_end/flambda2/simplify/lifting/lifted_constant_state.ml @@ -111,7 +111,8 @@ let add_to_denv ?maybe_already_defined denv lifted = be combined into one *) T.make_suitable_for_environment (DE.typing_env denv_at_definition) - (Everything_not_in typing_env) [sym, typ] + (Everything_not_in typing_env) + [sym, typ] in TE.add_env_extension_with_extra_variables typing_env env_extension) types_of_symbols typing_env) diff --git a/middle_end/flambda2/simplify/loopify_state.ml b/middle_end/flambda2/simplify/loopify_state.ml new file mode 100644 index 00000000000..c19ce8a8016 --- /dev/null +++ b/middle_end/flambda2/simplify/loopify_state.ml @@ -0,0 +1,26 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nathanaëlle Courant, OCamlPro *) +(* *) +(* Copyright 2022 OCamlPro SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type t = + | Do_not_loopify + | Loopify of Continuation.t + +let print ppf = function + | Do_not_loopify -> Format.fprintf ppf "do_not_loopify" + | Loopify cont -> + Format.fprintf ppf "@[(loopify@ %a)@]" Continuation.print cont + +let do_not_loopify = Do_not_loopify + +let loopify cont = Loopify cont diff --git a/ocaml/asmcomp/debug/available_regs.mli b/middle_end/flambda2/simplify/loopify_state.mli similarity index 73% rename from ocaml/asmcomp/debug/available_regs.mli rename to middle_end/flambda2/simplify/loopify_state.mli index d065d388c37..46e5c874aef 100644 --- a/ocaml/asmcomp/debug/available_regs.mli +++ b/middle_end/flambda2/simplify/loopify_state.mli @@ -2,9 +2,9 @@ (* *) (* OCaml *) (* *) -(* Mark Shinwell and Thomas Refis, Jane Street Europe *) +(* Nathanaëlle Courant, OCamlPro *) (* *) -(* Copyright 2013--2017 Jane Street Group LLC *) +(* Copyright 2022 OCamlPro SAS *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) @@ -12,7 +12,12 @@ (* *) (**************************************************************************) -(** Available registers analysis used to determine which variables may be - shown in the debugger. *) +type t = private + | Do_not_loopify + | Loopify of Continuation.t -val fundecl : Mach.fundecl -> Mach.fundecl +val print : Format.formatter -> t -> unit + +val do_not_loopify : t + +val loopify : Continuation.t -> t diff --git a/middle_end/flambda2/simplify/named_rewrite.ml b/middle_end/flambda2/simplify/named_rewrite.ml new file mode 100644 index 00000000000..5dac36893ac --- /dev/null +++ b/middle_end/flambda2/simplify/named_rewrite.ml @@ -0,0 +1,48 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nathanaëlle Courant, Guillaume Bury and Pierre Chambart, OCamlPro *) +(* *) +(* Copyright 2022--2022 OCamlPro SAS *) +(* Copyright 2022--2022 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Rewriting of primitives. Currently this is only used by the mutable unboxing + (aka ref-to-var) analysis, and these rewrite are applied when going upwards + and rebuilding expressions. *) +module Prim_rewrite = struct + type t = + | Remove_prim + | Invalid of Flambda_kind.t + | Replace_by_binding of + { var : Variable.t; + bound_to : Simple.t + } + + let print ppf = function + | Invalid _ -> Format.fprintf ppf "Invalid" + | Remove_prim -> Format.fprintf ppf "Remove_prim" + | Replace_by_binding { var; bound_to } -> + Format.fprintf ppf "Replace_by_binding { %a = %a }" Variable.print var + Simple.print bound_to + + let invalid k = Invalid k + + let remove_prim = Remove_prim + + let replace_by_binding ~var ~bound_to = Replace_by_binding { var; bound_to } +end + +(* We currently only rewrite primitives *) +type t = Prim_rewrite of Prim_rewrite.t + +let print ppf = function + | Prim_rewrite prim_rewrite -> Prim_rewrite.print ppf prim_rewrite + +let prim_rewrite prim_rewrite = Prim_rewrite prim_rewrite diff --git a/middle_end/flambda2/simplify/named_rewrite.mli b/middle_end/flambda2/simplify/named_rewrite.mli new file mode 100644 index 00000000000..f5b4d747847 --- /dev/null +++ b/middle_end/flambda2/simplify/named_rewrite.mli @@ -0,0 +1,44 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nathanaëlle Courant, Guillaume Bury and Pierre Chambart, OCamlPro *) +(* *) +(* Copyright 2022--2022 OCamlPro SAS *) +(* Copyright 2022--2022 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Prim_rewrite : sig + (** Rewrite for primitives *) + type t = private + | Remove_prim + | Invalid of Flambda_kind.t + | Replace_by_binding of + { var : Variable.t; + bound_to : Simple.t + } + (**) + + val print : Format.formatter -> t -> unit + + (** Replace the primitive by the [Invalid] primitive. *) + val invalid : Flambda_kind.t -> t + + (** Remove the primitve (and its binding) *) + val remove_prim : t + + (** Replace the primitive by the given [Simple.t] *) + val replace_by_binding : var:Variable.t -> bound_to:Simple.t -> t +end + +(** Named rewrites. These apply at [let_expr] constructions. *) +type t = private Prim_rewrite of Prim_rewrite.t + +val print : Format.formatter -> t -> unit + +val prim_rewrite : Prim_rewrite.t -> t diff --git a/middle_end/flambda2/simplify/rebuilt_expr.ml b/middle_end/flambda2/simplify/rebuilt_expr.ml index 85a3205e471..0f999ed1294 100644 --- a/middle_end/flambda2/simplify/rebuilt_expr.ml +++ b/middle_end/flambda2/simplify/rebuilt_expr.ml @@ -87,6 +87,9 @@ end module Continuation_handler = struct type t = Continuation_handler.t + let print ~cont ~recursive ppf ch = + Continuation_handler.print ~cont ~recursive ppf ch + let dummy = Continuation_handler.create Bound_parameters.empty ~handler:term_not_rebuilt ~free_names_of_handler:Unknown ~is_exn_handler:false @@ -98,6 +101,13 @@ module Continuation_handler = struct else Continuation_handler.create params ~handler ~free_names_of_handler:(Known free_names_of_handler) ~is_exn_handler + + let create' are_rebuilding params ~handler ~is_exn_handler = + if ART.do_not_rebuild_terms are_rebuilding + then dummy + else + Continuation_handler.create params ~handler ~free_names_of_handler:Unknown + ~is_exn_handler end let create_non_recursive_let_cont are_rebuilding cont handler ~body @@ -117,6 +127,13 @@ let create_non_recursive_let_cont' are_rebuilding cont handler ~body ~num_free_occurrences_of_cont_in_body: (Known num_free_occurrences_of_cont_in_body) ~is_applied_with_traps +let create_non_recursive_let_cont_without_free_names are_rebuilding cont handler + ~body = + if ART.do_not_rebuild_terms are_rebuilding + then term_not_rebuilt + else + Let_cont.create_non_recursive cont handler ~body ~free_names_of_body:Unknown + let create_recursive_let_cont are_rebuilding handlers ~body = if ART.do_not_rebuild_terms are_rebuilding then term_not_rebuilt diff --git a/middle_end/flambda2/simplify/rebuilt_expr.mli b/middle_end/flambda2/simplify/rebuilt_expr.mli index c7cecd0517a..9ae9837291c 100644 --- a/middle_end/flambda2/simplify/rebuilt_expr.mli +++ b/middle_end/flambda2/simplify/rebuilt_expr.mli @@ -80,6 +80,13 @@ end module Continuation_handler : sig type t + val print : + cont:Continuation.t -> + recursive:Recursive.t -> + Format.formatter -> + t -> + unit + val create : Are_rebuilding_terms.t -> Bound_parameters.t -> @@ -87,6 +94,13 @@ module Continuation_handler : sig free_names_of_handler:Name_occurrences.t -> is_exn_handler:bool -> t + + val create' : + Are_rebuilding_terms.t -> + Bound_parameters.t -> + handler:rebuilt_expr -> + is_exn_handler:bool -> + t end val create_non_recursive_let_cont : @@ -106,6 +120,13 @@ val create_non_recursive_let_cont' : is_applied_with_traps:bool -> t +val create_non_recursive_let_cont_without_free_names : + Are_rebuilding_terms.t -> + Continuation.t -> + Continuation_handler.t -> + body:t -> + t + val create_recursive_let_cont : Are_rebuilding_terms.t -> Continuation_handler.t Continuation.Map.t -> diff --git a/middle_end/flambda2/simplify/rebuilt_static_const.ml b/middle_end/flambda2/simplify/rebuilt_static_const.ml index 1b363fac584..3925d8bf9b0 100644 --- a/middle_end/flambda2/simplify/rebuilt_static_const.ml +++ b/middle_end/flambda2/simplify/rebuilt_static_const.ml @@ -57,9 +57,10 @@ let create_code are_rebuilding ~params_and_body ~free_names_of_params_and_body = if ART.do_not_rebuild_terms are_rebuilding then Code_metadata.createk (fun code_metadata -> - Code_not_rebuilt - (Non_constructed_code.create_with_metadata - ~free_names_of_params_and_body ~code_metadata)) + ( Code_not_rebuilt + (Non_constructed_code.create_with_metadata + ~free_names_of_params_and_body ~code_metadata), + None )) else let params_and_body = Rebuilt_expr.Function_params_and_body.to_function_params_and_body @@ -70,10 +71,11 @@ let create_code are_rebuilding ~params_and_body ~free_names_of_params_and_body = Code.create_with_metadata ~params_and_body ~free_names_of_params_and_body ~code_metadata in - Normal - { const = Static_const_or_code.create_code code; - free_names = Code.free_names code - }) + ( Normal + { const = Static_const_or_code.create_code code; + free_names = Code.free_names code + }, + Some code )) let create_code' code = Normal diff --git a/middle_end/flambda2/simplify/rebuilt_static_const.mli b/middle_end/flambda2/simplify/rebuilt_static_const.mli index 3e59d5f0e89..03f487f5ebe 100644 --- a/middle_end/flambda2/simplify/rebuilt_static_const.mli +++ b/middle_end/flambda2/simplify/rebuilt_static_const.mli @@ -30,7 +30,7 @@ val create_code : Are_rebuilding_terms.t -> params_and_body:Rebuilt_expr.Function_params_and_body.t -> free_names_of_params_and_body:Name_occurrences.t -> - t Code_metadata.create_type + (t * Code.t option) Code_metadata.create_type (* This function should be used when a [Code.t] is already in hand, e.g. from the input term to the simplifier, rather than when one needs to be diff --git a/middle_end/flambda2/simplify/simplify_apply_cont_expr.ml b/middle_end/flambda2/simplify/simplify_apply_cont_expr.ml index b73c7129b94..0b6fff0048f 100644 --- a/middle_end/flambda2/simplify/simplify_apply_cont_expr.ml +++ b/middle_end/flambda2/simplify/simplify_apply_cont_expr.ml @@ -137,15 +137,6 @@ let simplify_apply_cont dacc apply_cont ~down_to_up = let { S.simples = args; simple_tys = arg_types } = S.simplify_simples dacc (AC.args apply_cont) in - let dacc = - let record_args_for_data_flow data_flow = - Data_flow.add_apply_cont_args - (AC.continuation apply_cont) - (List.map Simple.free_names args) - data_flow - in - DA.map_data_flow dacc ~f:record_args_for_data_flow - in let use_kind = Simplify_common.apply_cont_use_kind ~context:Apply_cont_expr apply_cont in @@ -154,6 +145,14 @@ let simplify_apply_cont dacc apply_cont ~down_to_up = (AC.continuation apply_cont) use_kind ~env_at_use:(DA.denv dacc) ~arg_types in + let dacc = + let record_args_for_data_flow data_flow = + Flow.Acc.add_apply_cont_args + (AC.continuation apply_cont) + ~rewrite_id args data_flow + in + DA.map_flow_acc dacc ~f:record_args_for_data_flow + in let dbg = AC.debuginfo apply_cont in let dbg = DE.add_inlined_debuginfo (DA.denv dacc) dbg in let apply_cont = AC.with_debuginfo apply_cont ~dbg in diff --git a/middle_end/flambda2/simplify/simplify_apply_expr.ml b/middle_end/flambda2/simplify/simplify_apply_expr.ml index 450eb205bf8..71870ecc512 100644 --- a/middle_end/flambda2/simplify/simplify_apply_expr.ml +++ b/middle_end/flambda2/simplify/simplify_apply_expr.ml @@ -34,24 +34,36 @@ let warn_not_inlined_if_needed apply reason = (Debuginfo.to_location (Apply.dbg apply)) (Warnings.Inlining_impossible reason) -(* Note that this considers that the extra arguments of the exn_continuation are - always used. *) -let record_free_names_of_apply_as_used0 apply data_flow = +let record_free_names_of_apply_as_used0 apply ~use_id ~exn_cont_use_id data_flow + = let data_flow = - Data_flow.add_used_in_current_handler (Apply.free_names apply) data_flow + Flow.Acc.add_used_in_current_handler + (Apply.free_names_without_exn_continuation apply) + data_flow + in + let exn_cont = Apply.exn_continuation apply in + let result_cont = + match Apply.continuation apply, use_id with + | Never_returns, None -> None + | Return k, Some use_id -> Some (use_id, k) + | Never_returns, Some _ | Return _, None -> assert false in - match Apply.continuation apply with - | Never_returns -> data_flow - | Return k -> Data_flow.add_apply_result_cont k data_flow + Flow.Acc.add_apply_conts + ~exn_cont:(exn_cont_use_id, exn_cont) + ~result_cont data_flow -let record_free_names_of_apply_as_used dacc apply = - DA.map_data_flow dacc ~f:(record_free_names_of_apply_as_used0 apply) +let record_free_names_of_apply_as_used dacc ~use_id ~exn_cont_use_id apply = + DA.map_flow_acc dacc + ~f:(record_free_names_of_apply_as_used0 ~use_id ~exn_cont_use_id apply) -let simplify_direct_tuple_application ~simplify_expr dacc apply - ~params_arity:param_arity ~result_arity ~apply_alloc_mode - ~contains_no_escaping_local_allocs ~current_region ~down_to_up = +let simplify_direct_tuple_application ~simplify_expr dacc apply ~result_arity + ~apply_alloc_mode ~current_region ~callee's_code_id ~callee's_code_metadata + ~down_to_up = let dbg = Apply.dbg apply in - let n = Flambda_arity.With_subkinds.cardinal param_arity in + let n = + Flambda_arity.With_subkinds.cardinal + (Code_metadata.params_arity callee's_code_metadata) + in (* Split the tuple argument from other potential over application arguments *) let tuple, over_application_args = match Apply.args apply with @@ -80,9 +92,9 @@ let simplify_direct_tuple_application ~simplify_expr dacc apply (* [apply] already got a correct relative_history and [split_direct_over_application] infers the relative history from the one on [apply] so there's nothing to do here. *) - Simplify_common.split_direct_over_application apply ~param_arity - ~result_arity ~apply_alloc_mode ~contains_no_escaping_local_allocs - ~current_region + Simplify_common.split_direct_over_application apply ~result_arity + ~apply_alloc_mode ~current_region ~callee's_code_id + ~callee's_code_metadata in (* Insert the projections and simplify the new expression, to allow field projections to be simplified, and over-application/full_application @@ -125,7 +137,7 @@ let rebuild_non_inlined_direct_full_application apply ~use_id ~exn_cont_use_id in after_rebuild expr uacc -let simplify_direct_full_application ~simplify_expr dacc apply function_type +let simplify_direct_full_application0 ~simplify_expr dacc apply function_type ~params_arity ~result_arity ~(result_types : _ Or_unknown_or_bottom.t) ~down_to_up ~coming_from_indirect ~callee's_code_metadata = let inlined = @@ -176,7 +188,6 @@ let simplify_direct_full_application ~simplify_expr dacc apply function_type match inlined with | Some (dacc, inlined) -> simplify_expr dacc inlined ~down_to_up | None -> - let dacc = record_free_names_of_apply_as_used dacc apply in let dacc, use_id, result_continuation = let result_continuation = Apply.continuation apply in match result_continuation, result_types with @@ -266,11 +277,55 @@ let simplify_direct_full_application ~simplify_expr dacc apply function_type (Exn_continuation.arity (Apply.exn_continuation apply))) in let apply = Apply.with_continuation apply result_continuation in + let dacc = + record_free_names_of_apply_as_used dacc ~use_id ~exn_cont_use_id apply + in down_to_up dacc ~rebuild: (rebuild_non_inlined_direct_full_application apply ~use_id ~exn_cont_use_id ~result_arity ~coming_from_indirect) +let loopify_decision_for_call dacc apply = + let denv = DA.denv dacc in + match DE.closure_info denv with + | Not_in_a_closure | In_a_set_of_closures_but_not_yet_in_a_specific_closure -> + Loopify_state.do_not_loopify + | Closure { return_continuation; exn_continuation; my_closure; _ } -> + let tenv = DE.typing_env denv in + let[@inline always] canon simple = + Simple.without_coercion (TE.get_canonical_simple_exn tenv simple) + in + if Simple.equal (canon (Simple.var my_closure)) (canon (Apply.callee apply)) + && (match Apply.continuation apply with + | Never_returns -> + (* If we never return, then this call is a tail-call *) + true + | Return apply_return_continuation -> + Continuation.equal apply_return_continuation return_continuation) + && Exn_continuation.equal + (Apply.exn_continuation apply) + (Exn_continuation.create ~exn_handler:exn_continuation + ~extra_args:[]) + then DE.loopify_state denv + else Loopify_state.do_not_loopify + +let simplify_self_tail_call dacc apply self_cont ~down_to_up = + Simplify_apply_cont_expr.simplify_apply_cont dacc + (Apply_cont_expr.create self_cont ~args:(Apply.args apply) + ~dbg:(Apply.dbg apply)) + ~down_to_up + +let simplify_direct_full_application ~simplify_expr dacc apply function_type + ~params_arity ~result_arity ~result_types ~down_to_up ~coming_from_indirect + ~callee's_code_metadata = + match loopify_decision_for_call dacc apply with + | Loopify self_cont -> + simplify_self_tail_call dacc apply self_cont ~down_to_up + | Do_not_loopify -> + simplify_direct_full_application0 ~simplify_expr dacc apply function_type + ~params_arity ~result_arity ~result_types ~down_to_up + ~coming_from_indirect ~callee's_code_metadata + (* CR mshinwell: need to work out what to do for local alloc transformations when there are zero args. *) @@ -320,12 +375,7 @@ let simplify_direct_partial_application ~simplify_expr dacc apply assert (arity > args_arity); let applied_args, remaining_param_arity = Misc.Stdlib.List.map2_prefix - (fun arg kind -> - if not (K.equal (K.With_subkind.kind kind) K.value) - then - Misc.fatal_errorf "Non-[value] kind in partial application: %a" - Apply.print apply; - arg) + (fun arg kind -> arg, kind) args (Flambda_arity.With_subkinds.to_list param_arity) in @@ -357,6 +407,18 @@ let simplify_direct_partial_application ~simplify_expr dacc apply "New closure alloc mode cannot be [Heap] when existing closure alloc \ mode is [Local]: direct partial application:@ %a" Apply.print apply)); + (match new_closure_alloc_mode with + | Heap -> () + | Local _ -> ( + match Apply.call_kind apply with + | Function { alloc_mode; _ } | Method { alloc_mode; _ } -> ( + match alloc_mode with + | Local | Heap_or_local -> () + | Heap -> + Misc.fatal_errorf "Partial application of %a with wrong mode at %s" + Code_id.print callee's_code_id + (Debuginfo.to_string (Apply.dbg apply))) + | C_call _ -> ())); let contains_no_escaping_local_allocs = Code_metadata.contains_no_escaping_local_allocs callee's_code_metadata in @@ -397,12 +459,13 @@ let simplify_direct_partial_application ~simplify_expr dacc apply { var : Variable.t; (* name to bind to projected variable *) value : Simple.t; - (* value to store in closure *) + kind : K.With_subkind.t; + (* value to store in closure, with kind *) value_slot : Value_slot.t } end in let mk_value_slot () = Value_slot.create compilation_unit ~name:"arg" in - let applied_value value = + let applied_value (value, kind) = Simple.pattern_match' value ~const:(fun const -> Const const) ~symbol:(fun symbol ~coercion -> @@ -410,11 +473,23 @@ let simplify_direct_partial_application ~simplify_expr dacc apply then Symbol symbol else let var = Variable.create "symbol" in - In_closure { var; value; value_slot = mk_value_slot () }) + if not (K.equal (K.With_subkind.kind kind) K.value) + then + Misc.fatal_errorf + "Simple %a which is a symbol should be of kind Value" + Simple.print value; + In_closure + { var; + value; + kind = K.With_subkind.any_value; + value_slot = mk_value_slot () + }) ~var:(fun var ~coercion:_ -> - In_closure { var; value; value_slot = mk_value_slot () }) + In_closure { var; value; kind; value_slot = mk_value_slot () }) + in + let applied_callee = + applied_value (Apply.callee apply, K.With_subkind.any_value) in - let applied_callee = applied_value (Apply.callee apply) in let applied_args = List.map applied_value applied_args in let applied_values = applied_callee :: applied_args in let my_closure = Variable.create "my_closure" in @@ -449,12 +524,12 @@ let simplify_direct_partial_application ~simplify_expr dacc apply (fun (expr, cost_metrics, free_names) applied_value -> match applied_value with | Const _ | Symbol _ -> expr, cost_metrics, free_names - | In_closure { var; value_slot; value = _ } -> + | In_closure { var; value_slot; value = _; kind } -> let arg = VB.create var Name_mode.normal in let prim = P.Unary ( Project_value_slot - { project_from = wrapper_function_slot; value_slot }, + { project_from = wrapper_function_slot; value_slot; kind }, Simple.var my_closure ) in let cost_metrics_of_defining_expr = @@ -507,13 +582,14 @@ let simplify_direct_partial_application ~simplify_expr dacc apply ~params_arity:(Bound_parameters.arity_with_subkinds remaining_params) ~num_trailing_local_params ~result_arity ~result_types:Unknown ~contains_no_escaping_local_allocs ~stub:true ~inline:Default_inline - ~check:Check_attribute.Default_check ~is_a_functor:false ~recursive - ~cost_metrics:cost_metrics_of_body + ~poll_attribute:Default ~check:Check_attribute.Default_check + ~is_a_functor:false ~recursive ~cost_metrics:cost_metrics_of_body ~inlining_arguments:(DE.inlining_arguments (DA.denv dacc)) ~dbg ~is_tupled:false ~is_my_closure_used: (Function_params_and_body.is_my_closure_used params_and_body) ~inlining_decision:Stub ~absolute_history ~relative_history + ~loopify:Never_loopify in Static_const_or_code.create_code code in @@ -526,7 +602,8 @@ let simplify_direct_partial_application ~simplify_expr dacc apply (fun value -> match value with | Const _ | Symbol _ -> None - | In_closure { value_slot; value; var = _ } -> Some (value_slot, value)) + | In_closure { value_slot; value; kind; var = _ } -> + Some (value_slot, (value, kind))) applied_values |> Value_slot.Map.of_list in @@ -579,14 +656,14 @@ let simplify_direct_partial_application ~simplify_expr dacc apply in simplify_expr dacc expr ~down_to_up -let simplify_direct_over_application ~simplify_expr dacc apply ~param_arity - ~result_arity ~down_to_up ~coming_from_indirect ~apply_alloc_mode - ~contains_no_escaping_local_allocs ~current_region = +let simplify_direct_over_application ~simplify_expr dacc apply ~result_arity + ~down_to_up ~coming_from_indirect ~apply_alloc_mode ~current_region + ~callee's_code_id ~callee's_code_metadata = fail_if_probe apply; let expr = - Simplify_common.split_direct_over_application apply ~param_arity - ~result_arity ~apply_alloc_mode ~contains_no_escaping_local_allocs - ~current_region + Simplify_common.split_direct_over_application apply ~result_arity + ~apply_alloc_mode ~current_region ~callee's_code_id + ~callee's_code_metadata in let down_to_up dacc ~rebuild = let rebuild uacc ~after_rebuild = @@ -669,12 +746,9 @@ let simplify_direct_function_call ~simplify_expr dacc apply tuple argument, irrespective of what [Code.params_arity] says. *) if must_be_detupled then - simplify_direct_tuple_application ~simplify_expr dacc apply ~params_arity - ~result_arity ~apply_alloc_mode - ~contains_no_escaping_local_allocs: - (Code_metadata.contains_no_escaping_local_allocs - callee's_code_metadata) - ~current_region ~down_to_up + simplify_direct_tuple_application ~simplify_expr dacc apply ~result_arity + ~apply_alloc_mode ~current_region ~callee's_code_id + ~callee's_code_metadata ~down_to_up else let args = Apply.args apply in let provided_num_args = List.length args in @@ -686,13 +760,9 @@ let simplify_direct_function_call ~simplify_expr dacc apply ~coming_from_indirect ~callee's_code_metadata else if provided_num_args > num_params then - simplify_direct_over_application ~simplify_expr dacc apply - ~param_arity:params_arity ~result_arity ~down_to_up - ~coming_from_indirect ~apply_alloc_mode - ~contains_no_escaping_local_allocs: - (Code_metadata.contains_no_escaping_local_allocs - callee's_code_metadata) - ~current_region + simplify_direct_over_application ~simplify_expr dacc apply ~result_arity + ~down_to_up ~coming_from_indirect ~apply_alloc_mode ~current_region + ~callee's_code_id ~callee's_code_metadata else if provided_num_args > 0 && provided_num_args < num_params then simplify_direct_partial_application ~simplify_expr dacc apply @@ -738,7 +808,6 @@ let simplify_function_call_where_callee's_type_unavailable dacc apply ~tracker:(DE.inlining_history_tracker denv) ~apply (); let env_at_use = denv in - let dacc = record_free_names_of_apply_as_used dacc apply in let dacc, exn_cont_use_id = DA.record_continuation_use dacc (Exn_continuation.exn_handler (Apply.exn_continuation apply)) @@ -798,6 +867,10 @@ let simplify_function_call_where_callee's_type_unavailable dacc apply in call_kind, use_id, dacc in + let dacc = + record_free_names_of_apply_as_used ~use_id:(Some use_id) ~exn_cont_use_id + dacc apply + in down_to_up dacc ~rebuild: (rebuild_function_call_where_callee's_type_unavailable apply call_kind @@ -947,7 +1020,6 @@ let simplify_method_call dacc apply ~callee_ty ~kind:_ ~obj ~arg_types Misc.fatal_errorf "All arguments to a method call must be of kind [Value]:@ %a" Apply.print apply; - let dacc = record_free_names_of_apply_as_used dacc apply in let dacc, use_id = DA.record_continuation_use dacc apply_cont (Non_inlinable { escaping = true }) @@ -962,6 +1034,10 @@ let simplify_method_call dacc apply ~callee_ty ~kind:_ ~obj ~arg_types (T.unknown_types_from_arity_with_subkinds (Exn_continuation.arity (Apply.exn_continuation apply))) in + let dacc = + record_free_names_of_apply_as_used dacc ~use_id:(Some use_id) + ~exn_cont_use_id apply + in down_to_up dacc ~rebuild:(rebuild_method_call apply ~use_id ~exn_cont_use_id) let rebuild_c_call apply ~use_id ~exn_cont_use_id ~return_arity uacc @@ -1016,7 +1092,6 @@ let simplify_c_call ~simplify_expr dacc apply ~callee_ty ~param_arity in simplify_expr dacc expr ~down_to_up | Unchanged { return_types } -> - let dacc = record_free_names_of_apply_as_used dacc apply in let dacc, use_id = match Apply.continuation apply with | Return apply_continuation -> @@ -1045,6 +1120,9 @@ let simplify_c_call ~simplify_expr dacc apply ~callee_ty ~param_arity (T.unknown_types_from_arity_with_subkinds (Exn_continuation.arity (Apply.exn_continuation apply))) in + let dacc = + record_free_names_of_apply_as_used dacc ~use_id ~exn_cont_use_id apply + in down_to_up dacc ~rebuild:(rebuild_c_call apply ~use_id ~exn_cont_use_id ~return_arity) | Invalid -> diff --git a/middle_end/flambda2/simplify/simplify_common.ml b/middle_end/flambda2/simplify/simplify_common.ml index c2e2c9ea687..443aaf9744c 100644 --- a/middle_end/flambda2/simplify/simplify_common.ml +++ b/middle_end/flambda2/simplify/simplify_common.ml @@ -47,6 +47,9 @@ type simplify_function_body = exn_continuation:Continuation.t -> return_cont_scope:Scope.t -> exn_cont_scope:Scope.t -> + loopify_state:Loopify_state.t -> + params:Bound_parameters.t -> + implicit_params:Bound_parameters.t -> Rebuilt_expr.t * Upwards_acc.t let simplify_projection dacc ~original_term ~deconstructing ~shape ~result_var @@ -91,14 +94,20 @@ let project_tuple ~dbg ~size ~field tuple = let prim = P.Binary (Block_load (bak, mutability), tuple, index) in Named.create_prim prim dbg -let split_direct_over_application apply ~param_arity ~result_arity - ~(apply_alloc_mode : Alloc_mode.For_types.t) - ~contains_no_escaping_local_allocs ~current_region = - let arity = Flambda_arity.With_subkinds.cardinal param_arity in +let split_direct_over_application apply ~result_arity + ~(apply_alloc_mode : Alloc_mode.For_types.t) ~current_region + ~callee's_code_id ~callee's_code_metadata = + let arity = + Flambda_arity.With_subkinds.cardinal + (Code_metadata.params_arity callee's_code_metadata) + in let args = Apply.args apply in assert (arity < List.length args); let first_args, remaining_args = Misc.Stdlib.List.split_at arity args in let func_var = Variable.create "full_apply" in + let contains_no_escaping_local_allocs = + Code_metadata.contains_no_escaping_local_allocs callee's_code_metadata + in let needs_region = (* If the function being called might do a local allocation that escapes, then we need a region for such function's return value, unless the @@ -119,11 +128,6 @@ let split_direct_over_application apply ~param_arity ~result_arity | None -> current_region | Some (region, _) -> region in - let alloc_mode = - if contains_no_escaping_local_allocs - then Alloc_mode.For_types.heap - else Alloc_mode.For_types.unknown () - in let continuation = (* If there is no need for a new region, then the second (over) application jumps directly to the return continuation of the original @@ -137,7 +141,8 @@ let split_direct_over_application apply ~param_arity ~result_arity Apply.create ~callee:(Simple.var func_var) ~continuation (Apply.exn_continuation apply) ~args:remaining_args - ~call_kind:(Call_kind.indirect_function_call_unknown_arity alloc_mode) + ~call_kind: + (Call_kind.indirect_function_call_unknown_arity apply_alloc_mode) (Apply.dbg apply) ~inlined:(Apply.inlined apply) ~inlining_state:(Apply.inlining_state apply) ~probe_name:(Apply.probe_name apply) ~position:(Apply.position apply) @@ -214,9 +219,24 @@ let split_direct_over_application apply ~param_arity ~result_arity ~is_exn_handler:false in let full_apply = - Apply.with_continuation_callee_and_args apply - (Return after_full_application) ~callee:(Apply.callee apply) - ~args:first_args ~region:current_region + let alloc_mode = + if contains_no_escaping_local_allocs + then Alloc_mode.For_types.heap + else Alloc_mode.For_types.unknown () + in + Apply.create ~callee:(Apply.callee apply) + ~continuation:(Return after_full_application) + (Apply.exn_continuation apply) + ~args:first_args + ~call_kind: + (Call_kind.direct_function_call callee's_code_id + ~return_arity:(Code_metadata.result_arity callee's_code_metadata) + alloc_mode) + (Apply.dbg apply) ~inlined:(Apply.inlined apply) + ~inlining_state:(Apply.inlining_state apply) + ~probe_name:(Apply.probe_name apply) ~position:(Apply.position apply) + ~relative_history:(Apply.relative_history apply) + ~region:current_region in let both_applications = Let_cont.create_non_recursive after_full_application @@ -314,6 +334,9 @@ let clear_demoted_trap_action_and_patch_unused_exn_bucket uacc apply_cont = let apply_cont = clear_demoted_trap_action uacc apply_cont in patch_unused_exn_bucket uacc apply_cont +(* Warning: This function relies on [T.meet_is_flat_float_array], which could + return any kind for empty arrays. So this function is only safe for + operations that are invalid on empty arrays. *) let specialise_array_kind dacc (array_kind : P.Array_kind.t) ~array_ty : _ Or_bottom.t = let typing_env = DA.typing_env dacc in diff --git a/middle_end/flambda2/simplify/simplify_common.mli b/middle_end/flambda2/simplify/simplify_common.mli index 577c9317f4f..9b54f282093 100644 --- a/middle_end/flambda2/simplify/simplify_common.mli +++ b/middle_end/flambda2/simplify/simplify_common.mli @@ -90,6 +90,9 @@ type simplify_function_body = exn_continuation:Continuation.t -> return_cont_scope:Scope.t -> exn_cont_scope:Scope.t -> + loopify_state:Loopify_state.t -> + params:Bound_parameters.t -> + implicit_params:Bound_parameters.t -> Rebuilt_expr.t * Upwards_acc.t val simplify_projection : @@ -116,11 +119,11 @@ val project_tuple : application of the leftover arguments. *) val split_direct_over_application : Apply_expr.t -> - param_arity:Flambda_arity.With_subkinds.t -> result_arity:Flambda_arity.With_subkinds.t -> apply_alloc_mode:Alloc_mode.For_types.t -> - contains_no_escaping_local_allocs:bool -> current_region:Variable.t -> + callee's_code_id:Code_id.t -> + callee's_code_metadata:Code_metadata.t -> Expr.t type apply_cont_context = @@ -133,6 +136,9 @@ val apply_cont_use_kind : val clear_demoted_trap_action_and_patch_unused_exn_bucket : Upwards_acc.t -> Apply_cont.t -> Apply_cont.t +(** Warning: This function relies on [T.meet_is_flat_float_array], which could + return any kind for empty arrays. So this function is only safe for + operations that are invalid on empty arrays. *) val specialise_array_kind : Downwards_acc.t -> Flambda_primitive.Array_kind.t -> diff --git a/middle_end/flambda2/simplify/simplify_expr.ml b/middle_end/flambda2/simplify/simplify_expr.ml index 4d614b5ff14..b8aa34bbb8d 100644 --- a/middle_end/flambda2/simplify/simplify_expr.ml +++ b/middle_end/flambda2/simplify/simplify_expr.ml @@ -16,8 +16,7 @@ open! Simplify_import -let simplify_toplevel_common dacc simplify - ~(in_or_out_of_closure : Closure_info.in_or_out_of_closure) +let simplify_toplevel_common dacc simplify ~params ~implicit_params ~return_continuation ~return_arity ~exn_continuation ~return_cont_scope ~exn_cont_scope = (* The usage analysis needs a continuation whose handler holds the toplevel @@ -27,40 +26,39 @@ let simplify_toplevel_common dacc simplify Continuation.create ~name:"dummy_toplevel_continuation" () in let dacc = - DA.map_data_flow dacc ~f:(Data_flow.init_toplevel dummy_toplevel_cont []) + DA.map_flow_acc dacc + ~f: + (Flow.Acc.init_toplevel ~dummy_toplevel_cont + (Bound_parameters.append params implicit_params)) in let expr, uacc = simplify dacc ~down_to_up:(fun dacc ~rebuild -> let dacc = - DA.map_data_flow dacc - ~f:(Data_flow.exit_continuation dummy_toplevel_cont) + DA.map_flow_acc dacc + ~f:(Flow.Acc.exit_continuation dummy_toplevel_cont) in - let data_flow = DA.data_flow dacc in + let data_flow = DA.flow_acc dacc in + let closure_info = DE.closure_info (DA.denv dacc) in (* The code_age_relation and used value_slots are only correct at toplevel, and they are only necessary to compute the live code ids, which are only used when simplifying at the toplevel. So if we are in a closure, we use empty/dummy values for the code_age_relation and used_value_slots, and in return we do not use the reachable_code_id part of the data_flow analysis. *) - let code_age_relation, used_value_slots = - match in_or_out_of_closure with - | In_a_closure -> Code_age_relation.empty, Or_unknown.Unknown + let code_age_relation, used_value_slots, print_name = + match closure_info with + | Closure { code_id; _ } -> + Code_age_relation.empty, Or_unknown.Unknown, Code_id.name code_id + | In_a_set_of_closures_but_not_yet_in_a_specific_closure -> + assert false | Not_in_a_closure -> ( DA.code_age_relation dacc, - Or_unknown.Known (DA.used_value_slots dacc) ) + Or_unknown.Known (DA.used_value_slots dacc), + "toplevel" ) in - let ({ required_names; reachable_code_ids } : Data_flow.result) = - Data_flow.analyze data_flow ~code_age_relation ~used_value_slots - ~return_continuation ~exn_continuation - in - (* The code_id part of the data_flow analysis is correct only at - toplevel where all the code_ids are, so when in a closure, we state - the the live code ids are unknown, which will prevent any from being - mistakenly deleted. *) - let reachable_code_ids : _ Or_unknown.t = - match in_or_out_of_closure with - | In_a_closure -> Unknown - | Not_in_a_closure -> Known reachable_code_ids + let flow_result = + Flow.Analysis.analyze data_flow ~print_name ~code_age_relation + ~used_value_slots ~return_continuation ~exn_continuation in let uenv = UE.add_function_return_or_exn_continuation @@ -73,8 +71,14 @@ let simplify_toplevel_common dacc simplify (Flambda_arity.With_subkinds.create [K.With_subkind.any_value]) in let uacc = - UA.create ~required_names ~reachable_code_ids - ~compute_slot_offsets:true uenv dacc + UA.create ~flow_result ~compute_slot_offsets:true uenv dacc + in + let uacc = + if not + (Named_rewrite_id.Map.is_empty + flow_result.mutable_unboxing_result.let_rewrites) + then UA.set_resimplify uacc + else uacc in rebuild uacc ~after_rebuild:(fun expr uacc -> expr, uacc)) in @@ -120,11 +124,31 @@ let rec simplify_expr dacc expr ~down_to_up = EB.rebuild_invalid uacc (Message message) ~after_rebuild) and simplify_function_body dacc expr ~return_continuation ~return_arity - ~exn_continuation ~return_cont_scope ~exn_cont_scope = - simplify_toplevel_common dacc - (fun dacc -> simplify_expr dacc expr) - ~in_or_out_of_closure:In_a_closure ~return_continuation ~return_arity ~exn_continuation ~return_cont_scope ~exn_cont_scope + ~(loopify_state : Loopify_state.t) ~params ~implicit_params = + match loopify_state with + | Do_not_loopify -> + simplify_toplevel_common dacc + (fun dacc -> simplify_expr dacc expr) + ~params ~implicit_params ~return_continuation ~return_arity + ~exn_continuation ~return_cont_scope ~exn_cont_scope + | Loopify cont -> + let call_self_cont_expr = + let args = Bound_parameters.simples params in + Expr.create_apply_cont (Apply_cont_expr.create cont ~args ~dbg:[]) + in + let handlers = + Continuation.Map.singleton cont + (Continuation_handler.create params ~handler:expr + ~free_names_of_handler:Unknown ~is_exn_handler:false) + in + simplify_toplevel_common dacc + (fun dacc -> + Simplify_let_cont_expr.simplify_as_recursive_let_cont ~simplify_expr + dacc + (call_self_cont_expr, handlers)) + ~params ~implicit_params ~return_continuation ~return_arity + ~exn_continuation ~return_cont_scope ~exn_cont_scope and[@inline always] simplify_let dacc let_expr ~down_to_up = Simplify_let_expr.simplify_let ~simplify_expr ~simplify_function_body dacc @@ -132,7 +156,9 @@ and[@inline always] simplify_let dacc let_expr ~down_to_up = let simplify_toplevel dacc expr ~return_continuation ~return_arity ~exn_continuation ~return_cont_scope ~exn_cont_scope = + let params = Bound_parameters.empty in + let implicit_params = Bound_parameters.empty in simplify_toplevel_common dacc (fun dacc -> simplify_expr dacc expr) - ~in_or_out_of_closure:Not_in_a_closure ~return_continuation ~return_arity + ~params ~implicit_params ~return_continuation ~return_arity ~exn_continuation ~return_cont_scope ~exn_cont_scope diff --git a/middle_end/flambda2/simplify/simplify_extcall.ml b/middle_end/flambda2/simplify/simplify_extcall.ml index e2130b533c7..c0f6630c3c8 100644 --- a/middle_end/flambda2/simplify/simplify_extcall.ml +++ b/middle_end/flambda2/simplify/simplify_extcall.ml @@ -121,38 +121,32 @@ let simplify_comparison ~dbg ~dacc ~cont ~tagged_prim ~float_prim let simplify_caml_make_vect dacc ~len_ty ~init_value_ty : t = let typing_env = DA.typing_env dacc in - let element_kind : _ Or_unknown.t Or_bottom.t = + let element_kind : _ Or_unknown_or_bottom.t = (* We can't deduce subkind information, e.g. an array is all-immediates rather than arbitrary values, but we can deduce kind information. *) if not (Flambda_features.flat_float_array ()) - then - Ok - (Known - (Flambda_kind.With_subkind.create (T.kind init_value_ty) Anything)) + then Ok (Flambda_kind.With_subkind.create (T.kind init_value_ty) Anything) else match T.prove_is_or_is_not_a_boxed_float typing_env init_value_ty with | Proved true -> (* A boxed float provided to [caml_make_vect] with the float array optimisation on will always yield a flat array of naked floats. *) - Ok (Known Flambda_kind.With_subkind.naked_float) - | Proved false | Unknown -> Ok Unknown + Ok Flambda_kind.With_subkind.naked_float + | Proved false | Unknown -> Unknown in - match element_kind with - | Bottom -> Invalid - | Ok element_kind -> - (* CR-someday mshinwell: We should really adjust the kind of the parameter - of the return continuation, e.g. to go from "any value" to "float array" - -- but that will need some more infrastructure, since the actual - continuation definition needs to be changed on the upwards traversal. - Also we would need to think about what would happen if there were other - uses of the return continuation possibly with different kinds. + (* CR-someday mshinwell: We should really adjust the kind of the parameter of + the return continuation, e.g. to go from "any value" to "float array" -- + but that will need some more infrastructure, since the actual continuation + definition needs to be changed on the upwards traversal. Also we would need + to think about what would happen if there were other uses of the return + continuation possibly with different kinds. - Also maybe we should allow static allocation of these arrays for - reasonable sizes. *) - let type_of_returned_array = - T.mutable_array ~element_kind ~length:len_ty Alloc_mode.For_types.heap - in - Unchanged { return_types = Known [type_of_returned_array] } + Also maybe we should allow static allocation of these arrays for reasonable + sizes. *) + let type_of_returned_array = + T.mutable_array ~element_kind ~length:len_ty Alloc_mode.For_types.heap + in + Unchanged { return_types = Known [type_of_returned_array] } let simplify_returning_extcall ~dbg ~cont ~exn_cont:_ dacc fun_name args ~arg_types = diff --git a/middle_end/flambda2/simplify/simplify_import.ml b/middle_end/flambda2/simplify/simplify_import.ml index d05ff55de7e..963c040533b 100644 --- a/middle_end/flambda2/simplify/simplify_import.ml +++ b/middle_end/flambda2/simplify/simplify_import.ml @@ -36,7 +36,6 @@ module CIS = Code_id_or_symbol module CUE = Continuation_uses_env module DA = Downwards_acc module DE = Downwards_env -module DF = Data_flow module EA = Continuation_extra_params_and_args.Extra_arg module EB = Expr_builder module EPA = Continuation_extra_params_and_args diff --git a/middle_end/flambda2/simplify/simplify_import.mli b/middle_end/flambda2/simplify/simplify_import.mli index d05ff55de7e..963c040533b 100644 --- a/middle_end/flambda2/simplify/simplify_import.mli +++ b/middle_end/flambda2/simplify/simplify_import.mli @@ -36,7 +36,6 @@ module CIS = Code_id_or_symbol module CUE = Continuation_uses_env module DA = Downwards_acc module DE = Downwards_env -module DF = Data_flow module EA = Continuation_extra_params_and_args.Extra_arg module EB = Expr_builder module EPA = Continuation_extra_params_and_args diff --git a/middle_end/flambda2/simplify/simplify_let_cont_expr.ml b/middle_end/flambda2/simplify/simplify_let_cont_expr.ml index 88db263a8ad..156bfddd521 100644 --- a/middle_end/flambda2/simplify/simplify_let_cont_expr.ml +++ b/middle_end/flambda2/simplify/simplify_let_cont_expr.ml @@ -119,28 +119,86 @@ let compute_used_params uacc params ~is_exn_handler ~is_single_inlinable_use in { params_used_as_normal; params_not_used_as_normal } +let add_extra_params_for_continuation_param_aliases cont uacc rewrite_ids + extra_params_and_args = + let Flow_types.Alias_result.{ continuation_parameters; aliases_kind; _ } = + UA.continuation_param_aliases uacc + in + let required_extra_args = + Continuation.Map.find cont continuation_parameters + in + Variable.Set.fold + (fun var epa -> + let extra_args = + Apply_cont_rewrite_id.Map.of_set + (fun _id -> EPA.Extra_arg.Already_in_scope (Simple.var var)) + rewrite_ids + in + let var_kind = + Flambda_kind.With_subkind.create + (Variable.Map.find var aliases_kind) + Anything + in + EPA.add ~extra_param:(Bound_parameter.create var var_kind) ~extra_args epa) + required_extra_args.extra_args_for_aliases extra_params_and_args + +let add_extra_params_for_reference_fields cont uacc extra_params_and_args = + let Flow_types.Mutable_unboxing_result.{ additionnal_epa; _ } = + UA.mutable_unboxing_result uacc + in + match Continuation.Map.find cont additionnal_epa with + | exception Not_found -> extra_params_and_args + | additionnal_epa -> + EPA.concat ~outer:extra_params_and_args ~inner:additionnal_epa + let rebuild_one_continuation_handler cont ~at_unit_toplevel (recursive : Recursive.t) ~params ~(extra_params_and_args : EPA.t) - ~is_single_inlinable_use ~is_exn_handler handler uacc ~after_rebuild = - let handler, uacc = - (* We might need to place lifted constants now, as they could depend on - continuation parameters. As such we must also compute the unused - parameters after placing any constants! *) - if not at_unit_toplevel - then handler, uacc - else - let uacc, lifted_constants_from_body = - UA.get_and_clear_lifted_constants uacc - in - EB.place_lifted_constants uacc - ~lifted_constants_from_defining_expr:LCS.empty - ~lifted_constants_from_body - ~put_bindings_around_body:(fun uacc ~body -> body, uacc) - ~body:handler + ~rewrite_ids ~is_single_inlinable_use ~is_exn_handler handler uacc + ~after_rebuild = + let Flow_types.Alias_result.{ continuation_parameters; _ } = + UA.continuation_param_aliases uacc + in + let continuation_parameters = + Continuation.Map.find cont continuation_parameters + in + let add_lets_around_handler uacc handler = + let handler, uacc = + Variable.Map.fold + (fun var bound_to (handler, uacc) -> + let bound_pattern = + Bound_pattern.singleton (Bound_var.create var Name_mode.normal) + in + let named = Named.create_simple (Simple.var bound_to) in + let handler, uacc = + Expr_builder.create_let_binding uacc bound_pattern named + ~free_names_of_defining_expr: + (Name_occurrences.singleton_variable bound_to Name_mode.normal) + ~cost_metrics_of_defining_expr:Cost_metrics.zero ~body:handler + in + handler, uacc) + continuation_parameters.lets_to_introduce (handler, uacc) + in + let handler, uacc = + (* We might need to place lifted constants now, as they could depend on + continuation parameters. As such we must also compute the unused + parameters after placing any constants! *) + if not at_unit_toplevel + then handler, uacc + else + let uacc, lifted_constants_from_body = + UA.get_and_clear_lifted_constants uacc + in + EB.place_lifted_constants uacc + ~lifted_constants_from_defining_expr:LCS.empty + ~lifted_constants_from_body + ~put_bindings_around_body:(fun uacc ~body -> body, uacc) + ~body:handler + in + let free_names = UA.name_occurrences uacc in + let cost_metrics = UA.cost_metrics uacc in + handler, uacc, free_names, cost_metrics in - let free_names = UA.name_occurrences uacc in - let cost_metrics = UA.cost_metrics uacc in - let uacc, params, new_phantom_params = + let uacc, params, new_phantom_params, handler, free_names, cost_metrics = match recursive with | Recursive -> ( (* In the recursive case, we have already added an apply_cont_rewrite for @@ -153,6 +211,9 @@ let rebuild_one_continuation_handler cont ~at_unit_toplevel have already been added" Continuation.print cont | Some rewrite -> + let handler, uacc, free_names, cost_metrics = + add_lets_around_handler uacc handler + in let used_params_set = Apply_cont_rewrite.used_params rewrite in let used_params, unused_params = List.partition @@ -171,12 +232,23 @@ let rebuild_one_continuation_handler cont ~at_unit_toplevel in ( uacc, Bound_parameters.create (used_params @ used_extra_params), - new_phantom_params )) + new_phantom_params, + handler, + free_names, + cost_metrics )) | Non_recursive -> (* If the continuation is going to be inlined out, we don't need to spend time here calculating unused parameters, since the creation of [Let]-expressions around the continuation's handler will do that anyway. *) + let handler, uacc, free_names, cost_metrics = + add_lets_around_handler uacc handler + in + let extra_params_and_args = + add_extra_params_for_continuation_param_aliases cont uacc rewrite_ids + extra_params_and_args + |> add_extra_params_for_reference_fields cont uacc + in let { extra_params_used_as_normal; extra_params_not_used_as_normal } = compute_used_extra_params uacc extra_params_and_args ~is_single_inlinable_use ~free_names ~handler @@ -204,7 +276,10 @@ let rebuild_one_continuation_handler cont ~at_unit_toplevel ( uacc, Bound_parameters.create (params_used_as_normal @ extra_params_used_as_normal), - Bound_parameters.create new_phantom_params ) + Bound_parameters.create new_phantom_params, + handler, + free_names, + cost_metrics ) in let handler, uacc = let new_phantom_param_bindings_outermost_first = @@ -235,8 +310,8 @@ let rebuild_one_continuation_handler cont ~at_unit_toplevel ~cost_metrics_of_handler:cost_metrics uacc let simplify_one_continuation_handler ~simplify_expr dacc cont ~at_unit_toplevel - recursive ~params ~handler ~extra_params_and_args ~is_single_inlinable_use - ~is_exn_handler ~down_to_up = + recursive ~params ~handler ~extra_params_and_args ~rewrite_ids + ~is_single_inlinable_use ~is_exn_handler ~down_to_up = let down_to_up dacc ~rebuild = let rebuild uacc ~after_rebuild = (* The name occurrences component of this [uacc] is cleared (see further @@ -245,7 +320,7 @@ let simplify_one_continuation_handler ~simplify_expr dacc cont ~at_unit_toplevel assert (NO.is_empty (UA.name_occurrences uacc)); let after_rebuild handler uacc = rebuild_one_continuation_handler cont ~at_unit_toplevel recursive - ~params ~extra_params_and_args ~is_single_inlinable_use + ~params ~extra_params_and_args ~rewrite_ids ~is_single_inlinable_use ~is_exn_handler handler uacc ~after_rebuild in rebuild uacc ~after_rebuild @@ -262,8 +337,8 @@ type behaviour = let rebuild_non_recursive_let_cont_handler cont (uses : Join_points.result option) ~params ~handler ~free_names_of_handler ~cost_metrics_of_handler ~is_single_inlinable_use scope ~is_exn_handler - (extra_params_and_args : EPA.t) (cont_handler : RE.Continuation_handler.t) - uacc ~after_rebuild = + (extra_params_and_args : EPA.t) ~rewrite_ids:_ + (cont_handler : RE.Continuation_handler.t) uacc ~after_rebuild = let uenv = UA.uenv uacc in let uenv = (* CR mshinwell: Change types so that [free_names_of_handler] only needs to @@ -337,21 +412,37 @@ let rebuild_non_recursive_let_cont_handler cont let simplify_non_recursive_let_cont_handler ~simplify_expr ~denv_before_body ~dacc_after_body cont params ~(handler : Expr.t) ~prior_lifted_constants - ~scope ~is_exn_handler ~denv_for_toplevel_check ~unit_toplevel_exn_cont - ~prior_cont_uses_env ~down_to_up = + ~scope ~is_exn_handler ~unit_toplevel_exn_cont ~prior_cont_uses_env + ~down_to_up = let cont_uses_env = DA.continuation_uses_env dacc_after_body in + let at_unit_toplevel = + (* We try to show that [handler] postdominates [body] (which is done by + showing that [body] can only return through [cont]) and that if [body] + raises any exceptions then it only does so to toplevel. If this can be + shown and we are currently at the toplevel of a compilation unit, the + handler for the environment can remain marked as toplevel (and suitable + for "let symbol" bindings); otherwise, it cannot. *) + DE.at_unit_toplevel denv_before_body + && (not is_exn_handler) + && Continuation.Set.subset + (CUE.all_continuations_used cont_uses_env) + (Continuation.Set.of_list [cont; unit_toplevel_exn_cont]) + in + let env_at_fork = + DE.set_at_unit_toplevel_state denv_before_body at_unit_toplevel + in let code_age_relation_after_body = TE.code_age_relation (DA.typing_env dacc_after_body) in let consts_lifted_during_body = DA.get_lifted_constants dacc_after_body in - let uses = + let uses, rewrite_ids = match CUE.get_continuation_uses cont_uses_env cont with - | None -> None + | None -> None, Apply_cont_rewrite_id.Set.empty | Some uses -> - Some - (Join_points.compute_handler_env uses ~params - ~env_at_fork_plus_params:denv_before_body ~consts_lifted_during_body - ~code_age_relation_after_body) + ( Some + (Join_points.compute_handler_env uses ~params ~env_at_fork + ~consts_lifted_during_body ~code_age_relation_after_body), + Continuation_uses.get_use_ids uses ) in let dacc = DA.add_to_lifted_constant_accumulator dacc_after_body prior_lifted_constants @@ -380,7 +471,8 @@ let simplify_non_recursive_let_cont_handler ~simplify_expr ~denv_before_body ~free_names_of_handler:NO.empty ~cost_metrics_of_handler:Cost_metrics.zero ~is_single_inlinable_use:false scope ~is_exn_handler EPA.empty - cont_handler uacc ~after_rebuild + ~rewrite_ids:Apply_cont_rewrite_id.Set.empty cont_handler uacc + ~after_rebuild in down_to_up dacc ~continuation_has_zero_uses:true ~rebuild | Some @@ -439,39 +531,18 @@ let simplify_non_recursive_let_cont_handler ~simplify_expr ~denv_before_body handler_env, extra_params_and_args, false, dacc in let dacc = - DA.map_data_flow dacc - ~f:(Data_flow.add_extra_params_and_args cont extra_params_and_args) - in - let at_unit_toplevel = - (* We try to show that [handler] postdominates [body] (which is done by - showing that [body] can only return through [cont]) and that if [body] - raises any exceptions then it only does so to toplevel. If this can be - shown and we are currently at the toplevel of a compilation unit, the - handler for the environment can remain marked as toplevel (and suitable - for "let symbol" bindings); otherwise, it cannot. *) - DE.at_unit_toplevel denv_for_toplevel_check - && (not is_exn_handler) - && Continuation.Set.subset - (CUE.all_continuations_used cont_uses_env) - (Continuation.Set.of_list [cont; unit_toplevel_exn_cont]) + DA.map_flow_acc dacc + ~f:(Flow.Acc.add_extra_params_and_args cont extra_params_and_args) in let dacc = let cont_uses_env = CUE.union prior_cont_uses_env (CUE.remove cont_uses_env cont) in let dacc = DA.with_continuation_uses_env dacc ~cont_uses_env in - let denv = - (* Install the environment arising from the join into [dacc]. Note that - this environment doesn't just contain the joined types; it may also - contain definitions of code that were produced during simplification - of the body. (The [DE] component of [dacc_after_body] is discarded - since we are now moving into a different scope.) *) - DE.set_at_unit_toplevel_state handler_env at_unit_toplevel - in let denv = if not at_unit_toplevel - then denv - else DE.mark_parameters_as_toplevel denv params + then handler_env + else DE.mark_parameters_as_toplevel handler_env params in DA.with_denv dacc denv in @@ -482,14 +553,14 @@ let simplify_non_recursive_let_cont_handler ~simplify_expr ~denv_before_body rebuild_non_recursive_let_cont_handler cont uses ~params ~handler ~free_names_of_handler ~cost_metrics_of_handler ~is_single_inlinable_use scope ~is_exn_handler extra_params_and_args - cont_handler uacc ~after_rebuild + ~rewrite_ids cont_handler uacc ~after_rebuild in rebuild uacc ~after_rebuild in down_to_up dacc ~continuation_has_zero_uses:false ~rebuild in simplify_one_continuation_handler ~simplify_expr dacc cont ~at_unit_toplevel - Non_recursive ~params ~handler ~extra_params_and_args + Non_recursive ~params ~handler ~extra_params_and_args ~rewrite_ids ~is_single_inlinable_use ~is_exn_handler ~down_to_up let after_non_recursive_let_cont_body_rebuilt cont ~uenv_without_cont @@ -614,7 +685,7 @@ let after_non_recursive_let_cont_handler_rebuilt ~rebuild_body let after_downwards_traversal_of_non_recursive_let_cont_handler ~down_to_up ~rebuild_body cont dacc ~continuation_has_zero_uses ~rebuild:rebuild_handler = - let dacc = DA.map_data_flow dacc ~f:(Data_flow.exit_continuation cont) in + let dacc = DA.map_flow_acc dacc ~f:(Flow.Acc.exit_continuation cont) in let rebuild uacc ~after_rebuild = let uenv_without_cont = UA.uenv uacc in (* Now, on the upwards traversal, the handler is rebuilt. We need to be @@ -643,18 +714,20 @@ let after_downwards_traversal_of_non_recursive_let_cont_handler ~down_to_up down_to_up dacc ~rebuild let after_downwards_traversal_of_non_recursive_let_cont_body ~simplify_expr - ~denv_before_body ~denv_for_toplevel_check ~unit_toplevel_exn_cont - ~prior_lifted_constants ~scope ~is_exn_handler ~prior_cont_uses_env cont - params ~handler ~down_to_up dacc_after_body ~rebuild:rebuild_body = + ~denv_before_body ~unit_toplevel_exn_cont ~prior_lifted_constants ~scope + ~is_exn_handler ~prior_cont_uses_env cont params ~handler ~down_to_up + dacc_after_body ~rebuild:rebuild_body = let dacc_after_body = - DA.map_data_flow dacc_after_body - ~f:(Data_flow.enter_continuation cont (Bound_parameters.vars params)) + DA.map_flow_acc dacc_after_body + ~f: + (Flow.Acc.enter_continuation cont ~recursive:false ~is_exn_handler + params) in (* Before the upwards traversal of the body, we do the downwards traversal of the handler. *) simplify_non_recursive_let_cont_handler ~simplify_expr ~denv_before_body ~dacc_after_body cont params ~handler ~prior_lifted_constants ~scope - ~is_exn_handler ~denv_for_toplevel_check ~unit_toplevel_exn_cont + ~is_exn_handler ~unit_toplevel_exn_cont ~prior_cont_uses_env (* After doing the downwards traversal of the handler, we continue the downwards traversal of any surrounding expression (which would have to @@ -668,7 +741,6 @@ let after_downwards_traversal_of_non_recursive_let_cont_body ~simplify_expr let simplify_non_recursive_let_cont_stage1 ~simplify_expr dacc cont ~is_exn_handler ~body ~down_to_up params ~handler = let denv = DA.denv dacc in - let denv_for_toplevel_check = denv in let unit_toplevel_exn_cont = DE.unit_toplevel_exn_continuation denv in let scope = DE.get_continuation_scope denv in let dacc, prior_lifted_constants = @@ -678,12 +750,7 @@ let simplify_non_recursive_let_cont_stage1 ~simplify_expr dacc cont later. *) DA.get_and_clear_lifted_constants dacc in - let denv_before_body = - (* We add the parameters assuming that none of them are at toplevel. When we - do the toplevel calculation before simplifying the handler, we will mark - any of the parameters that are in fact at toplevel as such. *) - DE.add_parameters_with_unknown_types denv params ~at_unit_toplevel:false - in + let denv_before_body = DA.denv dacc in let dacc_for_body = (* This increment is required so that we can extract the portion of the environment(s) arising between the fork point and the use(s) of the @@ -700,9 +767,9 @@ let simplify_non_recursive_let_cont_stage1 ~simplify_expr dacc cont simplify_expr dacc_for_body body ~down_to_up: (after_downwards_traversal_of_non_recursive_let_cont_body ~simplify_expr - ~denv_before_body ~denv_for_toplevel_check ~unit_toplevel_exn_cont - ~prior_lifted_constants ~scope ~is_exn_handler ~prior_cont_uses_env - cont params ~handler ~down_to_up) + ~denv_before_body ~unit_toplevel_exn_cont ~prior_lifted_constants + ~scope ~is_exn_handler ~prior_cont_uses_env cont params ~handler + ~down_to_up) let simplify_non_recursive_let_cont_stage0 ~simplify_expr dacc non_rec ~down_to_up cont ~body = @@ -719,58 +786,213 @@ let simplify_non_recursive_let_cont ~simplify_expr dacc non_rec ~down_to_up = (simplify_non_recursive_let_cont_stage0 ~simplify_expr dacc non_rec ~down_to_up) +type make_rewrite_context = + | In_handler + | In_body of { rewrite_ids : Apply_cont_rewrite_id.Set.t } + +let make_rewrite_for_recursive_continuation uacc ~cont ~original_cont_scope + ~original_params ~context ~extra_params_and_args = + let extra_params_and_args = + match context with + | In_handler -> extra_params_and_args + | In_body { rewrite_ids } -> + (* In the body, the rewrite will refer to the wrapper continuation, if + there is one, which might have additionnal arguments for the aliases *) + let extra_params_and_args = + add_extra_params_for_continuation_param_aliases cont uacc rewrite_ids + extra_params_and_args + in + extra_params_and_args + in + let extra_params_and_args = + add_extra_params_for_reference_fields cont uacc extra_params_and_args + in + let required_names = UA.required_names uacc in + let Flow_types.Alias_result.{ continuation_parameters; _ } = + UA.continuation_param_aliases uacc + in + let { Flow_types.Continuation_param_aliases + .removed_aliased_params_and_extra_params; + _ + } = + Continuation.Map.find cont continuation_parameters + in + let kept_param param = + let var = BP.var param in + (not (Variable.Set.mem var removed_aliased_params_and_extra_params)) + && Name.Set.mem (Name.var var) required_names + in + let used_params_list = Bound_parameters.filter kept_param original_params in + let used_params = Bound_parameters.to_set used_params_list in + let extra_params = EPA.extra_params extra_params_and_args in + let used_extra_params_list = + Bound_parameters.filter kept_param extra_params + in + let used_extra_params = Bound_parameters.to_set used_extra_params_list in + let rewrite = + Apply_cont_rewrite.create ~original_params ~used_params + ~extra_params:(EPA.extra_params extra_params_and_args) + ~extra_args:(EPA.extra_args extra_params_and_args) + ~used_extra_params + in + let uacc = + UA.map_uenv uacc ~f:(fun uenv -> + match context with + | In_handler -> UE.add_apply_cont_rewrite uenv cont rewrite + | In_body _ -> UE.replace_apply_cont_rewrite uenv cont rewrite) + in + let uacc = + UA.map_uenv uacc ~f:(fun uenv -> + let params = + Bound_parameters.append used_params_list used_extra_params_list + in + UE.add_non_inlinable_continuation uenv cont original_cont_scope ~params + ~handler:Unknown) + in + uacc, rewrite + +let recursive_let_cont_handler_wrapper_params uacc ~cont ~rewrite = + let required_names = UA.required_names uacc in + let Flow_types.Alias_result.{ continuation_parameters; _ } = + UA.continuation_param_aliases uacc + in + let { Flow_types.Continuation_param_aliases + .removed_aliased_params_and_extra_params; + _ + } = + Continuation.Map.find cont continuation_parameters + in + let kept_param param = + let var = BP.var param in + (not (Variable.Set.mem var removed_aliased_params_and_extra_params)) + && Name.Set.mem (Name.var var) required_names + in + let original_params = + Bound_parameters.to_list (Apply_cont_rewrite.original_params rewrite) + in + let used_extra_params = + Bound_parameters.to_list (Apply_cont_rewrite.used_extra_params rewrite) + in + let params = List.filter kept_param (original_params @ used_extra_params) in + Bound_parameters.create params + +type decision = + | Inline + | Non_rec + | Rec +[@@warning "-37"] + type recursive_let_cont_handlers_element = + | Unused_rec_continuation of Continuation.t + | Inlined_handler of Continuation.t * RE.Continuation_handler.t | Non_recursive_handler of Continuation.t * RE.Continuation_handler.t | Recursive_handlers of RE.Continuation_handler.t Continuation.Map.t +[@@warning "-37"] let rebuild_recursive_let_cont_handlers cont ~params ~original_cont_scope - cont_handler ~handler ~free_names_of_handler ~cost_metrics_of_handler - ~cont_uses_in_body uacc ~after_rebuild = - let is_actually_recursive = + cont_handler ~handler ~free_names_of_handler ~cost_metrics_of_handler:_ + ~cont_uses_in_body:_ ~extra_params_and_args ~original_params ~rewrite_ids + uacc ~after_rebuild = + (* Temporarily disable this optimisation until the refactor/re-writing of + simplify_let_cont *) + let _is_actually_recursive = Continuation.Set.mem cont (Name_occurrences.continuations_including_in_trap_actions free_names_of_handler) in - let will_be_inlined = - if is_actually_recursive - then false - else - match Continuation_uses.get_uses cont_uses_in_body with - | [use] -> ( - match One_continuation_use.use_kind use with - | Inlinable -> true - | Non_inlinable _ -> false) - | _ -> false + let decision = + Rec + (* + * if is_actually_recursive + * then Rec + * else + * match Continuation_uses.get_uses cont_uses_in_body with + * | [use] -> ( + * match One_continuation_use.use_kind use with + * | Inlinable -> (* Inline *) Non_rec + * | Non_inlinable _ -> Non_rec) + * | _ -> Non_rec + *) in let uacc, handlers = - if will_be_inlined - then - let uacc = - UA.map_uenv uacc ~f:(fun uenv -> - UE.add_linearly_used_inlinable_continuation uenv cont - original_cont_scope ~params ~handler ~free_names_of_handler - ~cost_metrics_of_handler) - in - uacc, None - else + match decision with + | Inline -> + Misc.fatal_errorf "TODO" + (* + * let uacc = + * UA.map_uenv uacc ~f:(fun uenv -> + * UE.add_linearly_used_inlinable_continuation uenv cont + * original_cont_scope ~params ~handler ~free_names_of_handler + * ~cost_metrics_of_handler) + * in + * uacc, Inlined_handler (cont, cont_handler) + *) + | Non_rec -> + Misc.fatal_errorf "TODO" + (* + * let uacc = + * UA.map_uenv uacc ~f:(fun uenv -> + * UE.add_non_inlinable_continuation uenv cont original_cont_scope + * ~params ~handler:(Known handler)) + * in + * let handlers = Non_recursive_handler (cont, cont_handler) in + * uacc, handlers + *) + | Rec -> let uacc = UA.map_uenv uacc ~f:(fun uenv -> UE.add_non_inlinable_continuation uenv cont original_cont_scope ~params ~handler:(Known handler)) in let handlers = - if is_actually_recursive - then Recursive_handlers (Continuation.Map.singleton cont cont_handler) - else Non_recursive_handler (cont, cont_handler) + Recursive_handlers (Continuation.Map.singleton cont cont_handler) + in + (* We are inserting a rewrite for cont a second time: the first one was + int the handler, this one for the body of the let cont. Those does not + really relate to the same continuation, but to continuations with the + same name: If the rewrites are different, this one will refer to a + wrapper continuation with more arguments. *) + let uacc, rewrite = + make_rewrite_for_recursive_continuation uacc ~cont ~original_cont_scope + ~original_params + ~context:(In_body { rewrite_ids }) + ~extra_params_and_args + in + let wrapper_params = + recursive_let_cont_handler_wrapper_params uacc ~cont ~rewrite + in + let uacc = + (* If the arguments of the wrapper continuation and the recursive + continuation are different, we need to remove the arguments of the + wrapper from the free names of the handlers. + + It is correct to do, even when no wrapper are going to be introduced: + In that case the rewrite inside the handler and the one for the body + are the same: the parameters computed by + [recursive_let_cont_handler_wrapper_params] are exactly the same as + the recursive continuation, which where already removed from uacc in + after_one_recursive_let_cont_handler_rebuilt *) + let name_occurrences = + List.fold_left + (fun name_occurrences param -> + NO.remove_var name_occurrences ~var:(BP.var param)) + (UA.name_occurrences uacc) + (Bound_parameters.to_list wrapper_params) + in + UA.with_name_occurrences uacc ~name_occurrences in - uacc, Some handlers + uacc, handlers in + let name_occurrences = + Name_occurrences.increase_counts (UA.name_occurrences uacc) + in + let uacc = UA.with_name_occurrences uacc ~name_occurrences in after_rebuild handlers uacc let after_one_recursive_let_cont_handler_rebuilt cont ~original_cont_scope ~name_occurrences_subsequent_exprs ~after_rebuild cont_handler ~params - ~cont_uses_in_body ~handler ~free_names_of_handler ~cost_metrics_of_handler - uacc = + ~original_params ~extra_params_and_args ~rewrite_ids ~cont_uses_in_body + ~handler ~free_names_of_handler ~cost_metrics_of_handler uacc = let uacc = UA.add_free_names uacc name_occurrences_subsequent_exprs in (* The parameters are removed from the free name information as they are no longer in scope. *) @@ -783,63 +1005,47 @@ let after_one_recursive_let_cont_handler_rebuilt cont ~original_cont_scope UA.with_name_occurrences uacc ~name_occurrences in rebuild_recursive_let_cont_handlers cont ~params ~original_cont_scope - cont_handler ~handler ~free_names_of_handler ~cost_metrics_of_handler - ~cont_uses_in_body uacc ~after_rebuild + cont_handler ~handler ~original_params ~extra_params_and_args ~rewrite_ids + ~free_names_of_handler ~cost_metrics_of_handler ~cont_uses_in_body uacc + ~after_rebuild let prepare_to_rebuild_one_recursive_let_cont_handler cont params - (extra_params_and_args : EPA.t) ~original_cont_scope ~rebuild_handler - ~cont_uses_in_body uacc ~after_rebuild = - let required_names = UA.required_names uacc in - let used_params_list = - Bound_parameters.filter - (fun param -> Name.Set.mem (Name.var (BP.var param)) required_names) - params - in - let used_params = Bound_parameters.to_set used_params_list in - let used_extra_params_list = - Bound_parameters.filter - (fun param -> Name.Set.mem (Name.var (BP.var param)) required_names) - (EPA.extra_params extra_params_and_args) - in - let used_extra_params = Bound_parameters.to_set used_extra_params_list in - let rewrite = - Apply_cont_rewrite.create ~original_params:params ~used_params - ~extra_params:(EPA.extra_params extra_params_and_args) - ~extra_args:(EPA.extra_args extra_params_and_args) - ~used_extra_params - in - let uacc = - UA.map_uenv uacc ~f:(fun uenv -> - UE.add_apply_cont_rewrite uenv cont rewrite) - in - let uacc = - UA.map_uenv uacc ~f:(fun uenv -> - let params = - Bound_parameters.append used_params_list used_extra_params_list - in - UE.add_non_inlinable_continuation uenv cont original_cont_scope ~params - ~handler:Unknown) + (extra_params_and_args : EPA.t) ~rewrite_ids ~original_cont_scope + ~rebuild_handler ~cont_uses_in_body uacc ~after_rebuild = + let uacc, _rewrite = + make_rewrite_for_recursive_continuation uacc ~cont ~original_cont_scope + ~original_params:params ~context:In_handler ~extra_params_and_args in let name_occurrences_subsequent_exprs = UA.name_occurrences uacc in + assert (Name_occurrences.is_empty name_occurrences_subsequent_exprs); let uacc = UA.clear_name_occurrences uacc in rebuild_handler uacc ~after_rebuild: (after_one_recursive_let_cont_handler_rebuilt cont ~original_cont_scope - ~name_occurrences_subsequent_exprs ~after_rebuild ~cont_uses_in_body) + ~name_occurrences_subsequent_exprs ~after_rebuild ~cont_uses_in_body + ~extra_params_and_args ~rewrite_ids ~original_params:params) let after_downwards_traversal_of_one_recursive_let_cont_handler cont unboxing_decisions ~down_to_up params ~original_cont_scope - ~cont_uses_in_body dacc ~rebuild:rebuild_handler = - let dacc = DA.map_data_flow dacc ~f:(Data_flow.exit_continuation cont) in - let arg_types_by_use_id = + ~cont_uses_in_body ~body_continuation_uses_env dacc ~rebuild:rebuild_handler + = + let dacc = DA.map_flow_acc dacc ~f:(Flow.Acc.exit_continuation cont) in + let handler_continuation_uses_env = DA.continuation_uses_env dacc in + let continuation_uses_env = + CUE.union body_continuation_uses_env + (CUE.mark_non_inlinable handler_continuation_uses_env) + in + let rewrite_ids, arg_types_by_use_id = (* At this point all uses (in both the body and the handler) of [cont] are in [dacc]. *) - match CUE.get_continuation_uses (DA.continuation_uses_env dacc) cont with + match CUE.get_continuation_uses continuation_uses_env cont with | None -> - ListLabels.map (Bound_parameters.to_list params) ~f:(fun _ -> - Apply_cont_rewrite_id.Map.empty) + ( Apply_cont_rewrite_id.Set.empty, + ListLabels.map (Bound_parameters.to_list params) ~f:(fun _ -> + Apply_cont_rewrite_id.Map.empty) ) | Some continuation_uses -> - Continuation_uses.get_arg_types_by_use_id continuation_uses + ( Continuation_uses.get_use_ids continuation_uses, + Continuation_uses.get_arg_types_by_use_id continuation_uses ) in let extra_params_and_args = Unbox_continuation_params.compute_extra_params_and_args unboxing_decisions @@ -848,16 +1054,16 @@ let after_downwards_traversal_of_one_recursive_let_cont_handler cont let dacc = (* CR pchambart: perhaps the normal parameters and the extra params/args could be added in a single call to [Data_flow] *) - DA.map_data_flow dacc ~f:(fun data_flow -> - Data_flow.add_extra_params_and_args cont extra_params_and_args data_flow) + DA.map_flow_acc dacc ~f:(fun data_flow -> + Flow.Acc.add_extra_params_and_args cont extra_params_and_args data_flow) in - let cont_uses_env = CUE.remove (DA.continuation_uses_env dacc) cont in + let cont_uses_env = CUE.remove continuation_uses_env cont in let dacc = DA.with_continuation_uses_env dacc ~cont_uses_env in down_to_up dacc ~rebuild: (prepare_to_rebuild_one_recursive_let_cont_handler cont params - extra_params_and_args ~original_cont_scope ~rebuild_handler - ~cont_uses_in_body) + extra_params_and_args ~rewrite_ids ~original_cont_scope + ~rebuild_handler ~cont_uses_in_body) (* This only takes one handler at present since we don't yet support simplification of multiple recursive handlers. *) @@ -865,8 +1071,10 @@ let simplify_recursive_let_cont_handlers ~simplify_expr ~denv_before_body ~dacc_after_body cont params ~handler ~prior_lifted_constants ~original_cont_scope ~down_to_up = let dacc_after_body = - DA.map_data_flow dacc_after_body - ~f:(Data_flow.enter_continuation cont (Bound_parameters.vars params)) + DA.map_flow_acc dacc_after_body + ~f: + (Flow.Acc.enter_continuation cont ~recursive:true ~is_exn_handler:false + params) in let denv = DE.add_parameters_with_unknown_types ~at_unit_toplevel:false @@ -887,14 +1095,18 @@ let simplify_recursive_let_cont_handlers ~simplify_expr ~denv_before_body let dacc = DA.map_denv dacc ~f:(fun denv -> DE.set_at_unit_toplevel_state denv false) in + let body_continuation_uses_env = DA.continuation_uses_env dacc in let cont_uses_in_body = - CUE.get_continuation_uses (DA.continuation_uses_env dacc) cont + CUE.get_continuation_uses body_continuation_uses_env cont in match cont_uses_in_body with | None -> - let rebuild uacc ~after_rebuild = after_rebuild None uacc in + let rebuild uacc ~after_rebuild = + after_rebuild (Unused_rec_continuation cont) uacc + in down_to_up dacc ~rebuild | Some cont_uses_in_body -> + let dacc = DA.with_continuation_uses_env dacc ~cont_uses_env:CUE.empty in let arg_types_by_use_id_in_body = Continuation_uses.get_arg_types_by_use_id cont_uses_in_body in @@ -923,38 +1135,140 @@ let simplify_recursive_let_cont_handlers ~simplify_expr ~denv_before_body because there are no CSE parameters introduced. Therefore, we pass an empty one to {simplify_one_continuation_handler}. *) let extra_params_and_args = EPA.empty in + let rewrite_ids = Apply_cont_rewrite_id.Set.empty in simplify_one_continuation_handler ~simplify_expr dacc cont ~at_unit_toplevel:false Recursive ~params ~handler ~extra_params_and_args - ~is_single_inlinable_use:false ~is_exn_handler:false + ~rewrite_ids ~is_single_inlinable_use:false ~is_exn_handler:false ~down_to_up: (after_downwards_traversal_of_one_recursive_let_cont_handler cont unboxing_decisions params ~original_cont_scope ~down_to_up - ~cont_uses_in_body) - -let rebuild_recursive_let_cont_expr are_rebuilding_terms ~body - ~free_names_of_body ~handlers = - match handlers with - | None -> body - | Some (Non_recursive_handler (cont, handler)) -> - RE.create_non_recursive_let_cont are_rebuilding_terms cont handler ~body - ~free_names_of_body - | Some (Recursive_handlers rec_handlers) -> - RE.create_recursive_let_cont are_rebuilding_terms rec_handlers ~body + ~cont_uses_in_body ~body_continuation_uses_env) let rebuild_recursive_let_cont ~body handlers ~cost_metrics_of_handlers - ~free_names_of_body ~uenv_without_cont uacc ~after_rebuild = - let uacc = UA.with_uenv uacc uenv_without_cont in - let expr = - rebuild_recursive_let_cont_expr - (UA.are_rebuilding_terms uacc) - ~body ~handlers ~free_names_of_body - in - let uacc = - UA.add_cost_metrics - (Cost_metrics.increase_due_to_let_cont_recursive ~cost_metrics_of_handlers) - uacc - in - after_rebuild expr uacc + ~free_names_of_body:_ ~uenv_without_cont uacc ~after_rebuild = + match handlers with + | Unused_rec_continuation _cont -> + let uacc = UA.with_uenv uacc uenv_without_cont in + after_rebuild body uacc + | Inlined_handler (cont, handler) -> + Misc.fatal_errorf + "ERROR: inlined rec continuation with invariant parameters:@\n\ + %a@\n\ + @\n\ + body:@\n\ + %a@\n\ + @\n\ + %a" + (RE.Continuation_handler.print ~cont ~recursive:Non_recursive) + handler + (RE.print (UA.are_rebuilding_terms uacc)) + body UA.print uacc + (* + * let uacc = UA.with_uenv uacc uenv_without_cont in + * after_rebuild body uacc *) + | Non_recursive_handler (cont, handler) -> + Misc.fatal_errorf + "ERROR: non-rec rec continuation with invariant parameters:@\n\ + %a@\n\ + @\n\ + body:@\n\ + %a@\n\ + @\n\ + %a" + (RE.Continuation_handler.print ~cont ~recursive:Non_recursive) + handler + (RE.print (UA.are_rebuilding_terms uacc)) + body UA.print uacc + (* + * let uacc = UA.with_uenv uacc uenv_without_cont in + * (* TODO: cost metrics *) + * let expr = + * RE.create_non_recursive_let_cont (UA.are_rebuilding_terms uacc) cont handler ~body + * ~free_names_of_body + * in + * after_rebuild expr uacc *) + | Recursive_handlers rec_handlers -> + let Flow_types.Alias_result.{ continuation_parameters; _ } = + UA.continuation_param_aliases uacc + in + let cont, _handler = Continuation.Map.min_binding rec_handlers in + let ({ removed_aliased_params_and_extra_params; + extra_args_for_aliases; + recursive_continuation_wrapper; + _ + } + : Flow_types.Continuation_param_aliases.t) = + Continuation.Map.find cont continuation_parameters + in + let expr, uacc = + match recursive_continuation_wrapper with + | No_wrapper -> + ( RE.create_recursive_let_cont + (UA.are_rebuilding_terms uacc) + rec_handlers ~body, + uacc ) + | Wrapper_needed -> + let rewrite = + match UE.find_apply_cont_rewrite (UA.uenv uacc) cont with + | None -> assert false + | Some rewrite -> rewrite + in + let rec_params = + let original_params = + Bound_parameters.to_list + (Apply_cont_rewrite.original_params rewrite) + in + let used_params = Apply_cont_rewrite.used_params rewrite in + let used_original_params = + List.filter + (fun param -> BP.Set.mem param used_params) + original_params + in + let used_extra_params = + Bound_parameters.to_list + (Apply_cont_rewrite.used_extra_params rewrite) + in + List.filter + (fun param -> + (not (Variable.Set.mem (BP.var param) extra_args_for_aliases)) + && not + (Variable.Set.mem (BP.var param) + removed_aliased_params_and_extra_params)) + (used_original_params @ used_extra_params) + in + let rec_cont = + let args = + List.map (fun param -> Simple.var (BP.var param)) rec_params + in + let apply_cont = Apply_cont.create cont ~args ~dbg:Debuginfo.none in + let body = RE.create_apply_cont apply_cont in + RE.create_recursive_let_cont + (UA.are_rebuilding_terms uacc) + rec_handlers ~body + in + let params = + recursive_let_cont_handler_wrapper_params uacc ~cont ~rewrite + in + let handler = + RE.Continuation_handler.create' + (UA.are_rebuilding_terms uacc) + params ~handler:rec_cont ~is_exn_handler:false + in + let expr = + RE.create_non_recursive_let_cont_without_free_names + (UA.are_rebuilding_terms uacc) + cont handler ~body + in + expr, uacc + in + let uacc = + UA.add_cost_metrics + (Cost_metrics.increase_due_to_let_cont_recursive + ~cost_metrics_of_handlers) + uacc + in + let uacc = UA.with_uenv uacc uenv_without_cont in + after_rebuild expr uacc let after_recursive_let_cont_body_rebuilt continuation handlers ~uenv_without_cont ~free_names_of_handlers ~cost_metrics_of_handlers @@ -1024,12 +1338,9 @@ let simplify_recursive_let_cont_stage1 ~simplify_expr ~denv_before_body ~body ~original_cont_scope ~down_to_up) let simplify_recursive_let_cont_stage0 ~simplify_expr dacc ~down_to_up ~body - rec_handlers = - let module CH = Continuation_handler in - assert (not (Continuation_handlers.contains_exn_handler rec_handlers)); + handlers = let denv_before_body = DA.denv dacc in let original_cont_scope = DE.get_continuation_scope denv_before_body in - let handlers = Continuation_handlers.to_map rec_handlers in let cont, cont_handler = match Continuation.Map.bindings handlers with | [] | _ :: _ :: _ -> @@ -1038,14 +1349,22 @@ let simplify_recursive_let_cont_stage0 ~simplify_expr dacc ~down_to_up ~body yet implemented" | [c] -> c in - CH.pattern_match cont_handler + Continuation_handler.pattern_match cont_handler ~f: (simplify_recursive_let_cont_stage1 ~simplify_expr ~denv_before_body ~body cont ~original_cont_scope ~down_to_up dacc) +let simplify_as_recursive_let_cont ~simplify_expr dacc (body, handlers) + ~down_to_up = + simplify_recursive_let_cont_stage0 ~simplify_expr dacc ~down_to_up ~body + handlers + let simplify_recursive_let_cont ~simplify_expr dacc recs ~down_to_up = - Recursive_let_cont_handlers.pattern_match recs - ~f:(simplify_recursive_let_cont_stage0 ~simplify_expr dacc ~down_to_up) + Recursive_let_cont_handlers.pattern_match recs ~f:(fun ~body rec_handlers -> + assert (not (Continuation_handlers.contains_exn_handler rec_handlers)); + let handlers = Continuation_handlers.to_map rec_handlers in + simplify_recursive_let_cont_stage0 ~simplify_expr dacc ~down_to_up ~body + handlers) let simplify_let_cont ~simplify_expr dacc (let_cont : Let_cont.t) ~down_to_up = match let_cont with diff --git a/middle_end/flambda2/simplify/simplify_let_cont_expr.mli b/middle_end/flambda2/simplify/simplify_let_cont_expr.mli index b10b6dbd2c0..d0c2ae10b4b 100644 --- a/middle_end/flambda2/simplify/simplify_let_cont_expr.mli +++ b/middle_end/flambda2/simplify/simplify_let_cont_expr.mli @@ -19,3 +19,8 @@ open! Flambda val simplify_let_cont : simplify_expr:Expr.t Simplify_common.expr_simplifier -> Let_cont.t Simplify_common.expr_simplifier + +val simplify_as_recursive_let_cont : + simplify_expr:Expr.t Simplify_common.expr_simplifier -> + (Expr.t * Continuation_handler.t Continuation.Map.t) + Simplify_common.expr_simplifier diff --git a/middle_end/flambda2/simplify/simplify_let_expr.ml b/middle_end/flambda2/simplify/simplify_let_expr.ml index 4d026279df2..18025cb2f82 100644 --- a/middle_end/flambda2/simplify/simplify_let_expr.ml +++ b/middle_end/flambda2/simplify/simplify_let_expr.ml @@ -35,7 +35,7 @@ let keep_lifted_constant_only_if_used uacc acc lifted_constant = in if symbols_live || code_ids_live then LCS.add acc lifted_constant else acc -let rebuild_let simplify_named_result removed_operations +let rebuild_let simplify_named_result removed_operations ~rewrite_id ~lifted_constants_from_defining_expr ~at_unit_toplevel ~(closure_info : Closure_info.t) ~body uacc ~after_rebuild = let lifted_constants_from_defining_expr = @@ -44,12 +44,10 @@ let rebuild_let simplify_named_result removed_operations (* See the comment in [simplify_let], below; this case is analogous. *) lifted_constants_from_defining_expr | Not_in_a_closure -> - if Are_rebuilding_terms.do_not_rebuild_terms - (UA.are_rebuilding_terms uacc) - then lifted_constants_from_defining_expr - else - LCS.fold lifted_constants_from_defining_expr ~init:LCS.empty - ~f:(keep_lifted_constant_only_if_used uacc) + (* We must filter even if not rebuilding terms, otherwise the free names + of the terms might get out of sync with [Data_flow]. *) + LCS.fold lifted_constants_from_defining_expr ~init:LCS.empty + ~f:(keep_lifted_constant_only_if_used uacc) in (* At this point, the free names in [uacc] are the free names of [body], plus all used value slots seen in the whole compilation unit. *) @@ -76,6 +74,53 @@ let rebuild_let simplify_named_result removed_operations let bindings = Simplify_named_result.bindings_to_place_in_any_order simplify_named_result in + let uacc, bindings = + let Flow_types.Mutable_unboxing_result.{ let_rewrites; _ } = + UA.mutable_unboxing_result uacc + in + match Named_rewrite_id.Map.find rewrite_id let_rewrites with + | exception Not_found -> uacc, bindings + | rewrite -> ( + match bindings with + | [] -> uacc, [] + | _ :: _ :: _ -> assert false + | [binding] -> ( + match rewrite, binding.original_defining_expr with + | Prim_rewrite prim_rewrite, Prim (original_prim, dbg) -> + let uacc = + UA.notify_removed + ~operation:(Removed_operations.prim original_prim) + uacc + in + let new_bindings = + match prim_rewrite with + | Remove_prim -> [] + | Invalid k -> + let prim : P.t = Nullary (Invalid k) in + let binding = + { binding with + simplified_defining_expr = + Simplified_named.create (Named.create_prim prim dbg) + } + in + [binding] + | Replace_by_binding { var; bound_to } -> + let bv = Bound_pattern.must_be_singleton binding.let_bound in + let var' = Bound_var.var bv in + assert (Variable.equal var var'); + let binding = + { binding with + simplified_defining_expr = + Simplified_named.create (Named.create_simple bound_to) + } + in + [binding] + in + uacc, new_bindings + | ( Prim_rewrite _, + (Simple _ | Set_of_closures _ | Static_consts _ | Rec_info _) ) -> + Misc.fatal_errorf "Prim_rewrite applied to a non-prim Named.t")) + in (* Return as quickly as possible if there is nothing to do. In this case, all constants get floated up to an outer binding. *) if no_constants_to_place || not at_unit_toplevel @@ -106,13 +151,14 @@ let rebuild_let simplify_named_result removed_operations in after_rebuild body uacc -let record_one_value_slot_for_data_flow symbol value_slot simple data_flow = - DF.record_value_slot (Name.symbol symbol) value_slot +let record_one_value_slot_for_data_flow symbol value_slot (simple, _kind) + data_flow = + Flow.Acc.record_value_slot (Name.symbol symbol) value_slot (Simple.free_names simple) data_flow let record_one_function_slot_for_data_flow ~free_names ~value_slots _ (symbol, _) data_flow = - let data_flow = DF.record_symbol_binding symbol free_names data_flow in + let data_flow = Flow.Acc.record_symbol_binding symbol free_names data_flow in Value_slot.Map.fold (record_one_value_slot_for_data_flow symbol) value_slots data_flow @@ -122,12 +168,12 @@ let record_lifted_constant_definition_for_data_flow ~being_defined data_flow let module D = LC.Definition in match D.descr definition with | Code code_id -> - DF.record_code_id_binding code_id + Flow.Acc.record_code_id_binding code_id (NO.union being_defined (D.free_names definition)) data_flow | Block_like { symbol; _ } -> let free_names = NO.union being_defined (D.free_names definition) in - DF.record_symbol_binding symbol free_names data_flow + Flow.Acc.record_symbol_binding symbol free_names data_flow | Set_of_closures { closure_symbols_with_types; _ } -> ( let expr = D.defining_expr definition in match Rebuilt_static_const.to_const expr with @@ -146,7 +192,7 @@ let record_lifted_constant_definition_for_data_flow ~being_defined data_flow let free_names = NO.union being_defined (D.free_names definition) in Function_slot.Lmap.fold (fun _ (symbol, _) data_flow -> - DF.record_symbol_binding symbol free_names data_flow) + Flow.Acc.record_symbol_binding symbol free_names data_flow) closure_symbols_with_types data_flow) let record_lifted_constant_for_data_flow data_flow lifted_constant = @@ -154,7 +200,7 @@ let record_lifted_constant_for_data_flow data_flow lifted_constant = (* Record all projections as potential dependencies. *) Variable.Map.fold (fun var proj data_flow -> - DF.record_symbol_projection var + Flow.Acc.record_symbol_projection var (Symbol_projection.free_names proj) data_flow) (LC.symbol_projections lifted_constant) @@ -177,39 +223,15 @@ let record_lifted_constant_for_data_flow data_flow lifted_constant = ~init:data_flow ~f:(record_lifted_constant_definition_for_data_flow ~being_defined) -let record_new_defining_expression_binding_for_data_flow dacc data_flow - (binding : Simplify_named_result.binding_to_place) = - match binding.simplified_defining_expr with - | { free_names; named; cost_metrics = _ } -> - let can_be_removed = - match named with - | Simple _ | Set_of_closures _ | Rec_info _ -> true - | Prim (prim, _) -> - P.at_most_generative_effects prim - || Option.is_some (P.is_end_region prim) - in - if not can_be_removed - then DF.add_used_in_current_handler free_names data_flow - else - let generate_phantom_lets = DE.generate_phantom_lets (DA.denv dacc) in - let free_names = - match named with - | Simple _ | Set_of_closures _ | Rec_info _ -> free_names - | Prim (prim, _) -> - (* Uses of region variables in [End_region] don't count as uses. *) - if Option.is_some (P.is_end_region prim) - then - (* Format.eprintf "ignoring free names for %a\n%!" P.print prim;*) - NO.empty - else free_names - in - Bound_pattern.fold_all_bound_vars binding.let_bound ~init:data_flow - ~f:(fun data_flow v -> - DF.record_var_binding (VB.var v) free_names ~generate_phantom_lets - data_flow) +let record_new_defining_expression_binding_for_data_flow dacc ~rewrite_id + data_flow (binding : Simplify_named_result.binding_to_place) : Flow.Acc.t = + let generate_phantom_lets = DE.generate_phantom_lets (DA.denv dacc) in + Flow.Acc.record_let_binding ~rewrite_id ~generate_phantom_lets + ~let_bound:binding.let_bound + ~simplified_defining_expr:binding.simplified_defining_expr data_flow let update_data_flow dacc closure_info ~lifted_constants_from_defining_expr - simplify_named_result data_flow = + simplify_named_result ~rewrite_id data_flow = let data_flow = match Closure_info.in_or_out_of_closure closure_info with | In_a_closure -> @@ -225,7 +247,7 @@ let update_data_flow dacc closure_info ~lifted_constants_from_defining_expr ListLabels.fold_left (Simplify_named_result.bindings_to_place_in_any_order simplify_named_result) ~init:data_flow - ~f:(record_new_defining_expression_binding_for_data_flow dacc) + ~f:(record_new_defining_expression_binding_for_data_flow dacc ~rewrite_id) let simplify_let0 ~simplify_expr ~simplify_function_body dacc let_expr ~down_to_up bound_pattern ~body = @@ -281,10 +303,11 @@ let simplify_let0 ~simplify_expr ~simplify_function_body dacc let_expr let dacc = DA.add_to_lifted_constant_accumulator dacc prior_lifted_constants in + let rewrite_id = Named_rewrite_id.create () in let dacc = - DA.map_data_flow dacc + DA.map_flow_acc dacc ~f: - (update_data_flow dacc closure_info + (update_data_flow dacc closure_info ~rewrite_id ~lifted_constants_from_defining_expr simplify_named_result) in let at_unit_toplevel = DE.at_unit_toplevel (DA.denv dacc) in @@ -296,7 +319,7 @@ let simplify_let0 ~simplify_expr ~simplify_function_body dacc let_expr let after_rebuild body uacc = rebuild_let simplify_named_result removed_operations ~lifted_constants_from_defining_expr ~at_unit_toplevel ~closure_info - ~body uacc ~after_rebuild + ~body uacc ~after_rebuild ~rewrite_id in rebuild_body uacc ~after_rebuild in diff --git a/middle_end/flambda2/simplify/simplify_named.ml b/middle_end/flambda2/simplify/simplify_named.ml index dbd8c4c0986..aeda3f05b35 100644 --- a/middle_end/flambda2/simplify/simplify_named.ml +++ b/middle_end/flambda2/simplify/simplify_named.ml @@ -85,6 +85,7 @@ let simplify_named0 dacc (bound_pattern : Bound_pattern.t) (named : Named.t) defining_expr ~original_defining_expr:named) | Prim (prim, dbg) -> ( let bound_var = Bound_pattern.must_be_singleton bound_pattern in + let dbg = DE.add_inlined_debuginfo (DA.denv dacc) dbg in let { Simplify_primitive_result.simplified_named; try_reify; dacc } = Simplify_primitive.simplify_primitive dacc prim dbg ~result_var:bound_var in diff --git a/middle_end/flambda2/simplify/simplify_nullary_primitive.ml b/middle_end/flambda2/simplify/simplify_nullary_primitive.ml index 4c243e90717..4d4b17a72ec 100644 --- a/middle_end/flambda2/simplify/simplify_nullary_primitive.ml +++ b/middle_end/flambda2/simplify/simplify_nullary_primitive.ml @@ -18,6 +18,7 @@ open! Simplify_import let simplify_nullary_primitive dacc original_prim (prim : P.nullary_primitive) dbg ~result_var = match prim with + | Invalid _result_kind -> Simplify_primitive_result.create_invalid dacc | Optimised_out result_kind -> (match Bound_var.name_mode result_var with | Phantom -> () diff --git a/middle_end/flambda2/simplify/simplify_primitive_result.ml b/middle_end/flambda2/simplify/simplify_primitive_result.ml index aa84cc0edff..d9946310d1f 100644 --- a/middle_end/flambda2/simplify/simplify_primitive_result.ml +++ b/middle_end/flambda2/simplify/simplify_primitive_result.ml @@ -31,6 +31,13 @@ let create_simplified simplified_named ~try_reify dacc = let create_invalid dacc = { simplified_named = Invalid; try_reify = false; dacc } +let create_unit dacc ~result_var ~original_term = + (* CR gbury: would it make sense to have a Flambda2_types.unit instead of this + ? *) + let ty = Flambda2_types.this_tagged_immediate Targetint_31_63.zero in + let dacc = Downwards_acc.add_variable dacc result_var ty in + create original_term ~try_reify:false dacc + let create_unknown dacc ~result_var kind ~original_term = let ty = Flambda2_types.unknown kind in let dacc = Downwards_acc.add_variable dacc result_var ty in diff --git a/middle_end/flambda2/simplify/simplify_primitive_result.mli b/middle_end/flambda2/simplify/simplify_primitive_result.mli index eff488b23cd..4dfd1f3bed0 100644 --- a/middle_end/flambda2/simplify/simplify_primitive_result.mli +++ b/middle_end/flambda2/simplify/simplify_primitive_result.mli @@ -29,6 +29,12 @@ val create_simplified : val create_invalid : Downwards_acc.t -> t +val create_unit : + Downwards_acc.t -> + result_var:Bound_var.t -> + original_term:Flambda.Named.t -> + t + val create_unknown : Downwards_acc.t -> result_var:Bound_var.t -> diff --git a/middle_end/flambda2/simplify/simplify_set_of_closures.ml b/middle_end/flambda2/simplify/simplify_set_of_closures.ml index b457b00ed41..8a8331ba239 100644 --- a/middle_end/flambda2/simplify/simplify_set_of_closures.ml +++ b/middle_end/flambda2/simplify/simplify_set_of_closures.ml @@ -29,7 +29,7 @@ module C = Simplify_set_of_closures_context let dacc_inside_function context ~outer_dacc ~params ~my_closure ~my_region ~my_depth function_slot_opt ~closure_bound_names_inside_function ~inlining_arguments ~absolute_history code_id ~return_continuation - ~exn_continuation ~return_cont_params code_metadata = + ~exn_continuation ~loopify_state code_metadata = let dacc = C.dacc_inside_functions context in let num_leading_heap_params = Code_metadata.num_leading_heap_params code_metadata @@ -85,9 +85,10 @@ let dacc_inside_function context ~outer_dacc ~params ~my_closure ~my_region LCS.add_to_denv ~maybe_already_defined:() denv (DA.get_lifted_constants outer_dacc) |> DE.enter_closure code_id ~return_continuation ~exn_continuation + ~my_closure + |> DE.set_loopify_state loopify_state |> DE.increment_continuation_scope in - let denv = DE.add_parameters_with_unknown_types denv return_cont_params in let dacc = DA.with_denv dacc denv in let code_ids_to_remember = DA.code_ids_to_remember outer_dacc in let used_value_slots = DA.used_value_slots outer_dacc in @@ -143,19 +144,24 @@ type simplify_function_body_result = free_names_of_code : NO.t; return_cont_uses : Continuation_uses.t option; is_my_closure_used : bool; + recursive : Recursive.t; uacc_after_upwards_traversal : UA.t } let simplify_function_body context ~outer_dacc function_slot_opt ~closure_bound_names_inside_function ~inlining_arguments ~absolute_history - code_id ~return_cont_params code ~return_continuation ~exn_continuation - params ~body ~my_closure ~is_my_closure_used:_ ~my_region ~my_depth - ~free_names_of_body:_ = + code_id code ~return_continuation ~exn_continuation params ~body ~my_closure + ~is_my_closure_used:_ ~my_region ~my_depth ~free_names_of_body:_ = + let loopify_state = + if Loopify_attribute.should_loopify (Code.loopify code) + then Loopify_state.loopify (Continuation.create ~name:"self" ()) + else Loopify_state.do_not_loopify + in let dacc_at_function_entry = dacc_inside_function context ~outer_dacc ~params ~my_closure ~my_region ~my_depth function_slot_opt ~closure_bound_names_inside_function ~inlining_arguments ~absolute_history code_id ~return_continuation - ~exn_continuation ~return_cont_params (Code.code_metadata code) + ~exn_continuation ~loopify_state (Code.code_metadata code) in let dacc = dacc_at_function_entry in if not (DA.no_lifted_constants dacc) @@ -167,7 +173,14 @@ let simplify_function_body context ~outer_dacc function_slot_opt C.simplify_function_body context dacc body ~return_continuation ~exn_continuation ~return_arity:(Code.result_arity code) ~return_cont_scope:Scope.initial - ~exn_cont_scope:(Scope.next Scope.initial) + ~exn_cont_scope:(Scope.next Scope.initial) ~loopify_state ~params + ~implicit_params: + (Bound_parameters.create + [ Bound_parameter.create my_closure + Flambda_kind.With_subkind.any_value; + Bound_parameter.create my_region Flambda_kind.With_subkind.region; + Bound_parameter.create my_depth Flambda_kind.With_subkind.rec_info + ]) with | body, uacc -> let dacc_after_body = UA.creation_dacc uacc in @@ -186,6 +199,11 @@ let simplify_function_body context ~outer_dacc function_slot_opt let previously_free_depth_variables = NO.create_variables (C.previously_free_depth_variables context) NM.normal in + let recursive : Recursive.t = + if Name_occurrences.mem_var free_names_of_body my_depth + then Recursive + else Non_recursive + in let free_names_of_code = free_names_of_body |> NO.remove_continuation ~continuation:return_continuation @@ -216,6 +234,7 @@ let simplify_function_body context ~outer_dacc function_slot_opt free_names_of_code; return_cont_uses; is_my_closure_used; + recursive; uacc_after_upwards_traversal = uacc } | exception Misc.Fatal_error -> @@ -241,19 +260,16 @@ let compute_result_types ~is_a_functor ~return_cont_uses ~dacc_after_body | false, _ -> Unknown | true, None -> Bottom | true, Some uses -> - let env_at_fork_plus_params = + let env_at_fork = (* We use [C.dacc_inside_functions] not [C.dacc_prior_to_sets] to ensure that the environment contains bindings for any symbols being defined by the set of closures. *) - DE.add_parameters_with_unknown_types - (DA.denv dacc_at_function_entry) - return_cont_params + DA.denv dacc_at_function_entry in let join = Join_points.compute_handler_env - ~cut_after: - (Scope.prev (DE.get_continuation_scope env_at_fork_plus_params)) - uses ~params:return_cont_params ~env_at_fork_plus_params + ~cut_after:(Scope.prev (DE.get_continuation_scope env_at_fork)) + uses ~params:return_cont_params ~env_at_fork ~consts_lifted_during_body:lifted_consts_this_function ~code_age_relation_after_body: (TE.code_age_relation (DA.typing_env dacc_after_body)) @@ -280,10 +296,15 @@ let compute_result_types ~is_a_functor ~return_cont_uses ~dacc_after_body in Ok (Result_types.create ~params ~results:return_cont_params env_extension) +type rebuilt_code = + | Rebuilding of Code.t + | Not_rebuilding + type simplify_function_result = { code_id : Code_id.t; - code : Rebuilt_static_const.t option; - outer_dacc : DA.t + code : (rebuilt_code * Rebuilt_static_const.t) option; + outer_dacc : DA.t; + should_resimplify : bool } let simplify_function0 context ~outer_dacc function_slot_opt code_id code @@ -329,6 +350,7 @@ let simplify_function0 context ~outer_dacc function_slot_opt code_id code free_names_of_code; return_cont_uses; is_my_closure_used; + recursive; uacc_after_upwards_traversal } = Function_params_and_body.pattern_match @@ -336,8 +358,9 @@ let simplify_function0 context ~outer_dacc function_slot_opt code_id code ~f: (simplify_function_body context ~outer_dacc function_slot_opt ~closure_bound_names_inside_function ~inlining_arguments - ~absolute_history code_id ~return_cont_params code) + ~absolute_history code_id code) in + let should_resimplify = UA.resimplify uacc_after_upwards_traversal in let outer_dacc, lifted_consts_this_function = extract_accumulators_from_function outer_dacc ~dacc_after_body ~uacc_after_upwards_traversal @@ -355,7 +378,7 @@ let simplify_function0 context ~outer_dacc function_slot_opt code_id code let decision = Function_decl_inlining_decision.make_decision ~inlining_arguments ~inline:(Code.inline code) ~stub:(Code.stub code) ~cost_metrics - ~is_a_functor:(Code.is_a_functor code) ~recursive:(Code.recursive code) + ~is_a_functor:(Code.is_a_functor code) ~recursive in Inlining_report.record_decision_at_function_definition ~absolute_history ~code_metadata:(Code.code_metadata code) ~pass:After_simplify @@ -387,7 +410,20 @@ let simplify_function0 context ~outer_dacc function_slot_opt code_id code in DA.with_slot_offsets outer_dacc ~slot_offsets in - let code = + let loopify : Loopify_attribute.t = + match Code.loopify code with + | Always_loopify -> + (* CR ncourant: in this case, the function had a [@loop] attribute, so we + want to keep it in case we perform another pass. It might be better to + only keep it that way if it is still recursive, however, but this is + simpler. *) + Always_loopify + | Never_loopify -> Never_loopify + | Already_loopified -> Already_loopified + | Default_loopify_and_tailrec -> Already_loopified + | Default_loopify_and_not_tailrec -> Never_loopify + in + let code_const, new_code = Rebuilt_static_const.create_code (DA.are_rebuilding_terms dacc_after_body) code_id ~params_and_body ~free_names_of_params_and_body:free_names_of_code @@ -397,26 +433,64 @@ let simplify_function0 context ~outer_dacc function_slot_opt code_id code ~contains_no_escaping_local_allocs: (Code.contains_no_escaping_local_allocs code) ~stub:(Code.stub code) ~inline:(Code.inline code) ~check:(Code.check code) - ~is_a_functor ~recursive:(Code.recursive code) ~cost_metrics - ~inlining_arguments ~dbg:(Code.dbg code) ~is_tupled:(Code.is_tupled code) - ~is_my_closure_used ~inlining_decision ~absolute_history ~relative_history + ~poll_attribute:(Code.poll_attribute code) ~is_a_functor + ~recursive:(Code.recursive code) ~cost_metrics ~inlining_arguments + ~dbg:(Code.dbg code) ~is_tupled:(Code.is_tupled code) ~is_my_closure_used + ~inlining_decision ~absolute_history ~relative_history ~loopify + in + let code = + let are_rebuilding = DA.are_rebuilding_terms dacc_after_body in + match new_code with + | None -> + assert (not (Are_rebuilding_terms.are_rebuilding are_rebuilding)); + Not_rebuilding + | Some new_code -> + assert (Are_rebuilding_terms.are_rebuilding are_rebuilding); + Rebuilding new_code in - { code_id; code = Some code; outer_dacc } + { code_id; code = Some (code, code_const); outer_dacc; should_resimplify } + +let introduce_code dacc code_id code_const = + let code = LC.create_code code_id code_const in + DA.add_to_lifted_constant_accumulator ~also_add_to_env:() dacc + (LCS.singleton code) let simplify_function context ~outer_dacc function_slot code_id ~closure_bound_names_inside_function = - match DE.find_code_exn (DA.denv (C.dacc_prior_to_sets context)) code_id with + match + Code_or_metadata.view + (DE.find_code_exn (DA.denv (C.dacc_prior_to_sets context)) code_id) + with | Code_present code when not (Code.stub code) -> - simplify_function0 context ~outer_dacc (Some function_slot) code_id code - ~closure_bound_names_inside_function + let rec run ~outer_dacc ~code count = + let { code_id; code = new_code; outer_dacc; should_resimplify } = + simplify_function0 context ~outer_dacc (Some function_slot) code_id code + ~closure_bound_names_inside_function + in + match new_code with + | None -> code_id, outer_dacc + | Some (Not_rebuilding, new_code_const) -> + (* Not rebuilding: there is no code to resimplify *) + let outer_dacc = introduce_code outer_dacc code_id new_code_const in + code_id, outer_dacc + | Some (Rebuilding new_code, new_code_const) -> + let max_function_simplify_run = + Flambda_features.Expert.max_function_simplify_run () + in + if should_resimplify && count < max_function_simplify_run + then run ~outer_dacc ~code:new_code (count + 1) + else + let outer_dacc = introduce_code outer_dacc code_id new_code_const in + code_id, outer_dacc + in + run ~outer_dacc ~code 0 | Code_present _ | Metadata_only _ -> (* No new code ID is created in this case: there is no function body to be simplified and all other code metadata will remain the same. *) - { code_id; code = None; outer_dacc } + code_id, outer_dacc type simplify_set_of_closures0_result = { set_of_closures : Flambda.Set_of_closures.t; - code : Rebuilt_static_const.t Code_id.Lmap.t; dacc : Downwards_acc.t } @@ -432,11 +506,11 @@ let simplify_set_of_closures0 outer_dacc context set_of_closures then Misc.fatal_errorf "Did not expect lifted constants in [dacc]:@ %a" DA.print dacc; - let all_function_decls_in_set, code, fun_types, outer_dacc = + let all_function_decls_in_set, fun_types, outer_dacc = Function_slot.Lmap.fold (fun function_slot old_code_id - (result_function_decls_in_set, code, fun_types, outer_dacc) -> - let { code_id; code = new_code; outer_dacc } = + (result_function_decls_in_set, fun_types, outer_dacc) -> + let code_id, outer_dacc = simplify_function context ~outer_dacc function_slot old_code_id ~closure_bound_names_inside_function:closure_bound_names_inside in @@ -451,19 +525,12 @@ let simplify_set_of_closures0 outer_dacc context set_of_closures let result_function_decls_in_set = (function_slot, code_id) :: result_function_decls_in_set in - let code = - match new_code with - | None -> - (* CR mshinwell: Does this case ever occur? *) - code - | Some new_code -> (code_id, new_code) :: code - in let fun_types = Function_slot.Map.add function_slot function_type fun_types in - result_function_decls_in_set, code, fun_types, outer_dacc) + result_function_decls_in_set, fun_types, outer_dacc) all_function_decls_in_set - ([], [], Function_slot.Map.empty, outer_dacc) + ([], Function_slot.Map.empty, outer_dacc) in let code_ids_to_remember_this_set = List.fold_left @@ -477,7 +544,6 @@ let simplify_set_of_closures0 outer_dacc context set_of_closures let all_function_decls_in_set = Function_slot.Lmap.of_list (List.rev all_function_decls_in_set) in - let code = Code_id.Lmap.of_list (List.rev code) in let closure_types_by_bound_name = let closure_types_via_aliases = Function_slot.Map.map @@ -519,13 +585,7 @@ let simplify_set_of_closures0 outer_dacc context set_of_closures |> Set_of_closures.create ~value_slots (Set_of_closures.alloc_mode set_of_closures) in - { set_of_closures; code; dacc } - -let introduce_code dacc code = - Code_id.Lmap.bindings code - |> List.map (fun (code_id, code) -> LC.create_code code_id code) - |> LCS.singleton_list_of_constants - |> DA.add_to_lifted_constant_accumulator ~also_add_to_env:() dacc + { set_of_closures; dacc } let simplify_and_lift_set_of_closures dacc ~closure_bound_vars_inverse ~closure_bound_vars set_of_closures ~value_slots ~symbol_projections @@ -549,16 +609,17 @@ let simplify_and_lift_set_of_closures dacc ~closure_bound_vars_inverse in let value_slot_types = Value_slot.Map.map - (fun value_slot -> + (fun (value_slot, kind_with_subkind) -> + let kind = K.With_subkind.kind kind_with_subkind in Simple.pattern_match value_slot - ~const:(fun _ -> T.alias_type_of K.value value_slot) + ~const:(fun _ -> T.alias_type_of kind value_slot) ~name:(fun name ~coercion -> Name.pattern_match name ~var:(fun var -> match Variable.Map.find var closure_bound_vars_inverse with | exception Not_found -> assert (DE.mem_variable (DA.denv dacc) var); - T.alias_type_of K.value value_slot + T.alias_type_of kind value_slot | function_slot -> let closure_symbol = Function_slot.Map.find function_slot closure_symbols_map @@ -566,8 +627,8 @@ let simplify_and_lift_set_of_closures dacc ~closure_bound_vars_inverse let simple = Simple.with_coercion (Simple.symbol closure_symbol) coercion in - T.alias_type_of K.value simple) - ~symbol:(fun _sym -> T.alias_type_of K.value value_slot))) + T.alias_type_of kind simple) + ~symbol:(fun _sym -> T.alias_type_of kind value_slot))) value_slots in let context = @@ -579,7 +640,7 @@ let simplify_and_lift_set_of_closures dacc ~closure_bound_vars_inverse let closure_bound_names_inside = C.closure_bound_names_inside_functions_exactly_one_set context in - let { set_of_closures; code; dacc } = + let { set_of_closures; dacc } = simplify_set_of_closures0 dacc context set_of_closures ~closure_bound_names ~closure_bound_names_inside ~value_slots ~value_slot_types in @@ -590,7 +651,6 @@ let simplify_and_lift_set_of_closures dacc ~closure_bound_vars_inverse Symbol.Set.cardinal closure_symbols_set = Function_slot.Map.cardinal closure_symbols_map); let denv = DA.denv dacc in - let dacc = introduce_code dacc code in let closure_symbols_with_types = Function_slot.Map.map (fun symbol -> @@ -646,11 +706,10 @@ let simplify_non_lifted_set_of_closures0 dacc bound_vars ~closure_bound_vars let closure_bound_names_inside = C.closure_bound_names_inside_functions_exactly_one_set context in - let { set_of_closures; code; dacc } = + let { set_of_closures; dacc } = simplify_set_of_closures0 dacc context set_of_closures ~closure_bound_names ~closure_bound_names_inside ~value_slots ~value_slot_types in - let dacc = introduce_code dacc code in let defining_expr = let named = Named.create_set_of_closures set_of_closures in let find_code_characteristics code_id = @@ -675,7 +734,7 @@ let simplify_non_lifted_set_of_closures0 dacc bound_vars ~closure_bound_vars type lifting_decision_result = { can_lift : bool; - value_slots : Simple.t Value_slot.Map.t; + value_slots : (Simple.t * K.With_subkind.t) Value_slot.Map.t; value_slot_types : T.t Value_slot.Map.t; symbol_projections : Symbol_projection.t Variable.Map.t } @@ -693,7 +752,7 @@ let type_value_slots_and_make_lifting_decision_for_one_set dacc available.) *) let value_slots, value_slot_types, symbol_projections = Value_slot.Map.fold - (fun value_slot env_entry + (fun value_slot (env_entry, kind) (value_slots, value_slot_types, symbol_projections) -> let env_entry, ty, symbol_projections = let ty = @@ -717,7 +776,9 @@ let type_value_slots_and_make_lifting_decision_for_one_set dacc in simple, ty, symbol_projections in - let value_slots = Value_slot.Map.add value_slot env_entry value_slots in + let value_slots = + Value_slot.Map.add value_slot (env_entry, kind) value_slots + in let value_slot_types = Value_slot.Map.add value_slot ty value_slot_types in @@ -761,7 +822,7 @@ let type_value_slots_and_make_lifting_decision_for_one_set dacc | Unknown -> false) | Heap -> true in - let value_slot_permits_lifting _value_slot simple = + let value_slot_permits_lifting _value_slot (simple, _kind) = can_lift_coercion (Simple.coercion simple) && Simple.pattern_match' simple ~const:(fun _ -> true) @@ -809,11 +870,10 @@ let simplify_lifted_set_of_closures0 dacc context ~closure_symbols Function_slot.Lmap.map Bound_name.create_symbol closure_symbols |> Function_slot.Lmap.bindings |> Function_slot.Map.of_list in - let { set_of_closures; code; dacc } = + let { set_of_closures; dacc } = simplify_set_of_closures0 dacc context set_of_closures ~closure_bound_names ~closure_bound_names_inside ~value_slots ~value_slot_types in - let dacc = introduce_code dacc code in let set_of_closures_pattern = Bound_static.Pattern.set_of_closures closure_symbols in @@ -887,9 +947,13 @@ let simplify_stub_function dacc code ~all_code ~simplify_function_body = (* Unused, the type of the value slot is going to be unknown *) Function_slot.Map.empty in - let { code_id = _; code; outer_dacc } = + let { code_id = _; code; outer_dacc; should_resimplify = _ } = simplify_function0 context ~outer_dacc:dacc None (Code.code_id code) code ~closure_bound_names_inside_function in - let code = match code with None -> assert false | Some code -> code in + let code = + match code with + | None -> assert false + | Some (_, code_constant) -> code_constant + in code, outer_dacc diff --git a/middle_end/flambda2/simplify/simplify_set_of_closures_context.ml b/middle_end/flambda2/simplify/simplify_set_of_closures_context.ml index a33d799cdeb..461a9be8dac 100644 --- a/middle_end/flambda2/simplify/simplify_set_of_closures_context.ml +++ b/middle_end/flambda2/simplify/simplify_set_of_closures_context.ml @@ -115,10 +115,12 @@ let compute_closure_types_inside_functions ~denv ~all_sets_of_closures (* The types of the functions involved should reference the _new_ code IDs (where such exist), so that direct recursive calls can be compiled straight to the new code. *) - match code_or_metadata with - | Code_present code when not (Code.stub code) -> - Code_id.Map.find old_code_id old_to_new_code_ids_all_sets - | Code_present _ | Metadata_only _ -> old_code_id + if Code_or_metadata.code_present code_or_metadata + && not + (Code_metadata.stub + (Code_or_metadata.code_metadata code_or_metadata)) + then Code_id.Map.find old_code_id old_to_new_code_ids_all_sets + else old_code_id in let rec_info = (* From inside their own bodies, every function in the set @@ -205,13 +207,17 @@ let compute_old_to_new_code_ids_all_sets denv ~all_sets_of_closures = let function_decls = Set_of_closures.function_decls set_of_closures in Function_slot.Map.fold (fun _ old_code_id old_to_new_code_ids -> - match DE.find_code_exn denv old_code_id with - | Code_present code when not (Code.stub code) -> + let code = + try DE.find_code_exn denv old_code_id + with Not_found -> + Misc.fatal_errorf "Missing code for %a" Code_id.print old_code_id + in + if Code_or_metadata.code_present code + && not (Code_metadata.stub (Code_or_metadata.code_metadata code)) + then let new_code_id = Code_id.rename old_code_id in Code_id.Map.add old_code_id new_code_id old_to_new_code_ids - | Code_present _ | Metadata_only _ -> old_to_new_code_ids - | exception Not_found -> - Misc.fatal_errorf "Missing code for %a" Code_id.print old_code_id) + else old_to_new_code_ids) (Function_declarations.funs function_decls) old_to_new_code_ids_all_sets) Code_id.Map.empty all_sets_of_closures @@ -219,15 +225,17 @@ let compute_old_to_new_code_ids_all_sets denv ~all_sets_of_closures = let bind_existing_code_to_new_code_ids denv ~old_to_new_code_ids_all_sets = Code_id.Map.fold (fun old_code_id new_code_id denv -> - match DE.find_code_exn denv old_code_id with - | Code_present code when not (Code.stub code) -> + let code = DE.find_code_exn denv old_code_id in + if Code_or_metadata.code_present code + && not (Code_metadata.stub (Code_or_metadata.code_metadata code)) + then let code = - code + Code_or_metadata.get_code code |> Code.with_newer_version_of (Some old_code_id) |> Code.with_code_id new_code_id in DE.define_code denv ~code_id:new_code_id ~code - | Code_present _ | Metadata_only _ -> denv) + else denv) old_to_new_code_ids_all_sets denv let create ~dacc_prior_to_sets ~simplify_function_body ~all_sets_of_closures diff --git a/middle_end/flambda2/simplify/simplify_static_const.ml b/middle_end/flambda2/simplify/simplify_static_const.ml index 102be7272ca..0c1de3434a7 100644 --- a/middle_end/flambda2/simplify/simplify_static_const.ml +++ b/middle_end/flambda2/simplify/simplify_static_const.ml @@ -165,7 +165,7 @@ let simplify_static_const_of_kind_value dacc (static_const : Static_const.t) let fields, field_tys = List.split fields_with_tys in let dacc = bind_result_sym - (T.immutable_array ~element_kind:(Known K.With_subkind.naked_float) + (T.immutable_array ~element_kind:(Ok K.With_subkind.naked_float) ~fields:field_tys Alloc_mode.For_types.heap) in ( Rebuilt_static_const.create_immutable_float_array @@ -179,7 +179,7 @@ let simplify_static_const_of_kind_value dacc (static_const : Static_const.t) let fields, field_tys = List.split fields_with_tys in let dacc = bind_result_sym - (T.immutable_array ~element_kind:(Known K.With_subkind.any_value) + (T.immutable_array ~element_kind:(Ok K.With_subkind.any_value) ~fields:field_tys Alloc_mode.For_types.heap) in ( Rebuilt_static_const.create_immutable_value_array @@ -187,18 +187,9 @@ let simplify_static_const_of_kind_value dacc (static_const : Static_const.t) fields, dacc ) | Empty_array -> - (* CR-someday lmaurer: Comment from lthls: - - "Given that no element can be read from it (or stored in it), any kind - would work, but if we introduce a specific Invalid kind for these empty - arrays we might even be able to delete all the code that tries to read - from or write to a known empty array (although one would hope that the - bounds check would already be proved to always fail). [...] That might be - also useful for preserving the array kind during a join between a - specialised non-empty array and the empty array." *) let dacc = bind_result_sym - (T.array_of_length ~element_kind:Unknown + (T.array_of_length ~element_kind:Bottom ~length:(T.this_tagged_immediate Targetint_31_63.zero) Alloc_mode.For_types.heap) in diff --git a/middle_end/flambda2/simplify/simplify_switch_expr.ml b/middle_end/flambda2/simplify/simplify_switch_expr.ml index 5476d566a3d..f5c016ed0a3 100644 --- a/middle_end/flambda2/simplify/simplify_switch_expr.ml +++ b/middle_end/flambda2/simplify/simplify_switch_expr.ml @@ -18,6 +18,8 @@ open! Simplify_import module TE = Flambda2_types.Typing_env module Alias_set = TE.Alias_set +[@@@ocaml.warning "-37"] + type mergeable_arms = | No_arms | Mergeable of @@ -27,7 +29,37 @@ type mergeable_arms = | Not_mergeable let find_all_aliases env arg = - TE.aliases_of_simple env ~min_name_mode:NM.normal arg + let find_all_aliases () = + TE.aliases_of_simple env ~min_name_mode:NM.normal arg + in + Simple.pattern_match' + ~var:(fun _var ~coercion:_ -> + (* We use find alias to find a common simple to different + simples. + + This simple is already guaranteed to be the cannonical alias. + + * If there is a common alias between variables, the + cannonical alias must also be a common alias. + + * For constants and symbols there can be a common alias that + is not cannonical: A variable can have different constant + values in different branches: this variable is not the + cannonical alias, the cannonical would be the constant or + the symbol. But the only common alias could be a variable + in that case. + + hence there is no loss of generality in returning the + cannonical alias as the single alias if it is a variable. + + Note that the main reason for this is to allow changing the + arguments of continuations to variables that where not in + scope during the downward traversal. In particular for the + alias rewriting provided by data_flow *) + TE.Alias_set.singleton arg) + ~symbol:(fun _sym ~coercion:_ -> find_all_aliases ()) + ~const:(fun _cst -> find_all_aliases ()) + arg let rebuild_arm uacc arm (action, use_id, arity, env_at_use) ( new_let_conts, @@ -45,37 +77,43 @@ let rebuild_arm uacc arm (action, use_id, arity, env_at_use) with | Apply_cont action -> ( let action = + let cont = Apply_cont.continuation action in + let cont_info_from_uenv = UE.find_continuation (UA.uenv uacc) cont in (* First try to absorb any [Apply_cont] expression that forms the entirety of the arm's action (via an intermediate zero-arity continuation without trap action) into the [Switch] expression itself. *) - if not (Apply_cont.is_goto action) - then Some action - else - let cont = Apply_cont.continuation action in - let check_handler ~handler ~action = - match RE.to_apply_cont handler with - | Some action -> Some action - | None -> Some action - in - match UE.find_continuation (UA.uenv uacc) cont with - | Linearly_used_and_inlinable - { handler; - free_names_of_handler = _; - params; - cost_metrics_of_handler = _ - } -> - assert (Bound_parameters.is_empty params); - check_handler ~handler ~action - | Non_inlinable_zero_arity { handler = Known handler } -> - check_handler ~handler ~action - | Non_inlinable_zero_arity { handler = Unknown } -> Some action - | Invalid _ -> None - | Non_inlinable_non_zero_arity _ - | Toplevel_or_function_return_or_exn_continuation _ -> - Misc.fatal_errorf - "Inconsistency for %a between [Apply_cont.is_goto] and \ - continuation environment in [UA]:@ %a" - Continuation.print cont UA.print uacc + match cont_info_from_uenv with + | Invalid _ -> None + | Linearly_used_and_inlinable _ | Non_inlinable_zero_arity _ + | Non_inlinable_non_zero_arity _ + | Toplevel_or_function_return_or_exn_continuation _ -> ( + if not (Apply_cont.is_goto action) + then Some action + else + let check_handler ~handler ~action = + match RE.to_apply_cont handler with + | Some action -> Some action + | None -> Some action + in + match cont_info_from_uenv with + | Linearly_used_and_inlinable + { handler; + free_names_of_handler = _; + params; + cost_metrics_of_handler = _ + } -> + assert (Bound_parameters.is_empty params); + check_handler ~handler ~action + | Non_inlinable_zero_arity { handler = Known handler } -> + check_handler ~handler ~action + | Non_inlinable_zero_arity { handler = Unknown } -> Some action + | Invalid _ -> None + | Non_inlinable_non_zero_arity _ + | Toplevel_or_function_return_or_exn_continuation _ -> + Misc.fatal_errorf + "Inconsistency for %a between [Apply_cont.is_goto] and \ + continuation environment in [UA]:@ %a" + Continuation.print cont UA.print uacc) in match action with | None -> @@ -156,19 +194,24 @@ let rebuild_arm uacc arm (action, use_id, arity, env_at_use) let arms = Targetint_31_63.Map.add arm action arms in new_let_conts, arms, Not_mergeable, identity_arms, not_arms -let find_cse_simple dacc prim = +let filter_and_choose_alias required_names alias_set = + let available_alias_set = + Alias_set.filter alias_set ~f:(fun alias -> + Simple.pattern_match alias + ~name:(fun name ~coercion:_ -> Name.Set.mem name required_names) + ~const:(fun _ -> true)) + in + Alias_set.find_best available_alias_set + +let find_cse_simple dacc required_names prim = match P.Eligible_for_cse.create prim with | None -> None (* Constant *) | Some with_fixed_value -> ( match DE.find_cse (DA.denv dacc) with_fixed_value with | None -> None - | Some simple -> ( - match - TE.get_canonical_simple_exn (DA.typing_env dacc) simple - ~min_name_mode:NM.normal ~name_mode_of_existing_simple:NM.normal - with - | exception Not_found -> None - | simple -> Some simple)) + | Some simple -> + filter_and_choose_alias required_names + (find_all_aliases (DA.typing_env dacc) simple)) let rebuild_switch ~arms ~condition_dbg ~scrutinee ~scrutinee_ty ~dacc_before_switch uacc ~after_rebuild = @@ -185,7 +228,10 @@ let rebuild_switch ~arms ~condition_dbg ~scrutinee ~scrutinee_ty | No_arms | Not_mergeable -> None | Mergeable { cont; args } -> let num_args = List.length args in - let args = List.filter_map Alias_set.choose_opt args in + let required_names = UA.required_names uacc in + let args = + List.filter_map (filter_and_choose_alias required_names) args + in if List.compare_length_with args num_args = 0 then Some (cont, args) else None @@ -253,7 +299,10 @@ let rebuild_switch ~arms ~condition_dbg ~scrutinee ~scrutinee_ty UA.notify_removed ~operation:Removed_operations.branch uacc in let tagging_prim : P.t = Unary (Tag_immediate, scrutinee) in - match find_cse_simple dacc_before_switch tagging_prim with + match + find_cse_simple dacc_before_switch (UA.required_names uacc) + tagging_prim + with | None -> normal_case uacc | Some tagged_scrutinee -> let apply_cont = @@ -273,7 +322,10 @@ let rebuild_switch ~arms ~condition_dbg ~scrutinee ~scrutinee_ty let not_scrutinee = Variable.create "not_scrutinee" in let not_scrutinee' = Simple.var not_scrutinee in let tagging_prim : P.t = Unary (Tag_immediate, scrutinee) in - match find_cse_simple dacc_before_switch tagging_prim with + match + find_cse_simple dacc_before_switch (UA.required_names uacc) + tagging_prim + with | None -> normal_case uacc | Some tagged_scrutinee -> let do_tagging = @@ -328,11 +380,11 @@ let simplify_arm ~typing_env_at_use ~scrutinee_ty arm action (arms, dacc) = let arity = List.map T.kind arg_types |> Flambda_arity.create in let action = Apply_cont.update_args action ~args in let dacc = - DA.map_data_flow dacc + DA.map_flow_acc dacc ~f: - (Data_flow.add_apply_cont_args + (Flow.Acc.add_apply_cont_args ~rewrite_id (Apply_cont.continuation action) - (List.map Simple.free_names args)) + args) in let arms = Targetint_31_63.Map.add arm (action, rewrite_id, arity, env_at_use) arms @@ -357,14 +409,16 @@ let simplify_switch0 dacc switch ~down_to_up = if Targetint_31_63.Map.cardinal arms <= 1 then dacc else - DA.map_data_flow dacc - ~f:(Data_flow.add_used_in_current_handler (Simple.free_names scrutinee)) + DA.map_flow_acc dacc + ~f:(Flow.Acc.add_used_in_current_handler (Simple.free_names scrutinee)) + in + let condition_dbg = + DE.add_inlined_debuginfo (DA.denv dacc) (Switch.condition_dbg switch) in down_to_up dacc ~rebuild: - (rebuild_switch ~arms - ~condition_dbg:(Switch.condition_dbg switch) - ~scrutinee ~scrutinee_ty ~dacc_before_switch) + (rebuild_switch ~arms ~condition_dbg ~scrutinee ~scrutinee_ty + ~dacc_before_switch) let simplify_switch ~simplify_let ~simplify_function_body dacc switch ~down_to_up = @@ -383,9 +437,9 @@ let simplify_switch ~simplify_let ~simplify_function_body dacc switch ~free_names_of_body:Unknown in let dacc = - DA.map_data_flow dacc + DA.map_flow_acc dacc ~f: - (Data_flow.add_used_in_current_handler + (Flow.Acc.add_used_in_current_handler (NO.singleton_variable tagged_scrutinee NM.normal)) in simplify_let diff --git a/middle_end/flambda2/simplify/simplify_ternary_primitive.ml b/middle_end/flambda2/simplify/simplify_ternary_primitive.ml index 0b9e49eb387..21b90c13176 100644 --- a/middle_end/flambda2/simplify/simplify_ternary_primitive.ml +++ b/middle_end/flambda2/simplify/simplify_ternary_primitive.ml @@ -36,22 +36,23 @@ let simplify_array_set (array_kind : P.Array_kind.t) init_or_assign dacc (Array_set (array_kind, init_or_assign), array, index, new_value)) dbg in - let dacc = DA.add_variable dacc result_var T.any_value in + let unit_ty = Flambda2_types.this_tagged_immediate Targetint_31_63.zero in + let dacc = DA.add_variable dacc result_var unit_ty in SPR.create named ~try_reify:false dacc let simplify_block_set _block_access_kind _init_or_assign dacc ~original_term _dbg ~arg1:_ ~arg1_ty:_ ~arg2:_ ~arg2_ty:_ ~arg3:_ ~arg3_ty:_ ~result_var = - SPR.create_unknown dacc ~result_var K.value ~original_term + SPR.create_unit dacc ~result_var ~original_term let simplify_bytes_or_bigstring_set _bytes_like_value _string_accessor_width dacc ~original_term _dbg ~arg1:_ ~arg1_ty:_ ~arg2:_ ~arg2_ty:_ ~arg3:_ ~arg3_ty:_ ~result_var = - SPR.create_unknown dacc ~result_var K.value ~original_term + SPR.create_unit dacc ~result_var ~original_term let simplify_bigarray_set ~num_dimensions:_ _bigarray_kind _bigarray_layout dacc ~original_term _dbg ~arg1:_ ~arg1_ty:_ ~arg2:_ ~arg2_ty:_ ~arg3:_ ~arg3_ty:_ ~result_var = - SPR.create_unknown dacc ~result_var K.value ~original_term + SPR.create_unit dacc ~result_var ~original_term let simplify_ternary_primitive dacc original_prim (prim : P.ternary_primitive) ~arg1 ~arg1_ty ~arg2 ~arg2_ty ~arg3 ~arg3_ty dbg ~result_var = diff --git a/middle_end/flambda2/simplify/simplify_unary_primitive.ml b/middle_end/flambda2/simplify/simplify_unary_primitive.ml index 13d7a895a52..50a9021c36d 100644 --- a/middle_end/flambda2/simplify/simplify_unary_primitive.ml +++ b/middle_end/flambda2/simplify/simplify_unary_primitive.ml @@ -43,8 +43,8 @@ let simplify_project_function_slot ~move_from ~move_to ~min_name_mode dacc ~this_function_slot:move_from closures) ~result_var ~result_kind:K.value -let simplify_project_value_slot function_slot value_slot ~min_name_mode dacc - ~original_term ~arg:closure ~arg_ty:closure_ty ~result_var = +let simplify_project_value_slot function_slot value_slot kind ~min_name_mode + dacc ~original_term ~arg:closure ~arg_ty:closure_ty ~result_var = let result = (* We try a faster method before falling back to [simplify_projection]. *) match @@ -76,14 +76,15 @@ let simplify_project_value_slot function_slot value_slot ~min_name_mode dacc (T.closure_with_at_least_this_value_slot ~this_function_slot:function_slot value_slot ~value_slot_var:(Bound_var.var result_var)) - ~result_var ~result_kind:K.value + ~result_var ~result_kind:(K.With_subkind.kind kind) in let dacc = DA.add_use_of_value_slot result.dacc value_slot in SPR.with_dacc result dacc in let dacc = Simplify_common.add_symbol_projection result.dacc ~projected_from:closure - (Symbol_projection.Projection.project_value_slot function_slot value_slot) + (Symbol_projection.Projection.project_value_slot function_slot value_slot + kind) ~projection_bound_to:result_var in SPR.with_dacc result dacc @@ -470,6 +471,9 @@ let simplify_is_flat_float_array dacc ~original_term ~arg:_ ~arg_ty ~result_var let simplify_opaque_identity dacc ~original_term ~arg:_ ~arg_ty:_ ~result_var = SPR.create_unknown dacc ~result_var K.value ~original_term +let simplify_begin_try_region dacc ~original_term ~arg:_ ~arg_ty:_ ~result_var = + SPR.create_unknown dacc ~result_var K.region ~original_term + let simplify_end_region dacc ~original_term ~arg:_ ~arg_ty:_ ~result_var = let ty = T.this_tagged_immediate Targetint_31_63.zero in let dacc = DA.add_variable dacc result_var ty in @@ -552,8 +556,8 @@ let simplify_unary_primitive dacc original_prim (prim : P.unary_primitive) ~arg let original_term = Named.create_prim original_prim dbg in let simplifier = match prim with - | Project_value_slot { project_from; value_slot } -> - simplify_project_value_slot project_from value_slot ~min_name_mode + | Project_value_slot { project_from; value_slot; kind } -> + simplify_project_value_slot project_from value_slot ~min_name_mode kind | Project_function_slot { move_from; move_to } -> simplify_project_function_slot ~move_from ~move_to ~min_name_mode | Unbox_number boxable_number_kind -> @@ -592,6 +596,7 @@ let simplify_unary_primitive dacc original_prim (prim : P.unary_primitive) ~arg simplify_duplicate_array ~kind ~source_mutability ~destination_mutability | Duplicate_block { kind } -> simplify_duplicate_block ~kind | Opaque_identity { middle_end_only = _ } -> simplify_opaque_identity + | Begin_try_region -> simplify_begin_try_region | End_region -> simplify_end_region | Obj_dup -> simplify_obj_dup dbg in diff --git a/middle_end/flambda2/simplify/simplify_variadic_primitive.ml b/middle_end/flambda2/simplify/simplify_variadic_primitive.ml index 35bf4af7a47..e637bd85fc0 100644 --- a/middle_end/flambda2/simplify/simplify_variadic_primitive.ml +++ b/middle_end/flambda2/simplify/simplify_variadic_primitive.ml @@ -126,10 +126,9 @@ let simplify_make_array (array_kind : P.Array_kind.t) let alloc_mode = Alloc_mode.For_allocations.as_type alloc_mode in match mutable_or_immutable with | Mutable -> - T.mutable_array ~element_kind:(Known element_kind) ~length alloc_mode + T.mutable_array ~element_kind:(Ok element_kind) ~length alloc_mode | Immutable -> - T.immutable_array ~element_kind:(Known element_kind) ~fields:tys - alloc_mode + T.immutable_array ~element_kind:(Ok element_kind) ~fields:tys alloc_mode | Immutable_unique -> Misc.fatal_errorf "Immutable_unique is not expected for arrays:@ %a" Named.print original_term diff --git a/middle_end/flambda2/simplify/unboxing/is_unboxing_beneficial.ml b/middle_end/flambda2/simplify/unboxing/is_unboxing_beneficial.ml index 6ebd5dc581c..c30062be732 100644 --- a/middle_end/flambda2/simplify/unboxing/is_unboxing_beneficial.ml +++ b/middle_end/flambda2/simplify/unboxing/is_unboxing_beneficial.ml @@ -32,13 +32,13 @@ let rec filter_non_beneficial_decisions decision : U.decision = | Unbox (Unique_tag_and_size { tag; fields }) -> let is_unboxing_beneficial, fields = List.fold_left_map - (fun is_unboxing_beneficial ({ epa; decision } : U.field_decision) : - (_ * U.field_decision) -> + (fun is_unboxing_beneficial ({ epa; decision; kind } : U.field_decision) + : (_ * U.field_decision) -> let is_unboxing_beneficial = is_unboxing_beneficial || is_unboxing_beneficial_for_epa epa in let decision = filter_non_beneficial_decisions decision in - is_unboxing_beneficial, { epa; decision }) + is_unboxing_beneficial, { epa; decision; kind }) false fields in if is_unboxing_beneficial @@ -48,11 +48,11 @@ let rec filter_non_beneficial_decisions decision : U.decision = let is_unboxing_beneficial = ref false in let vars_within_closure = Value_slot.Map.map - (fun ({ epa; decision } : U.field_decision) : U.field_decision -> + (fun ({ epa; decision; kind } : U.field_decision) : U.field_decision -> is_unboxing_beneficial := !is_unboxing_beneficial || is_unboxing_beneficial_for_epa epa; let decision = filter_non_beneficial_decisions decision in - { epa; decision }) + { epa; decision; kind }) vars_within_closure in if !is_unboxing_beneficial @@ -63,11 +63,12 @@ let rec filter_non_beneficial_decisions decision : U.decision = let fields_by_tag = Tag.Scannable.Map.map (List.map - (fun ({ epa; decision } : U.field_decision) : U.field_decision -> + (fun ({ epa; decision; kind } : U.field_decision) : U.field_decision + -> is_unboxing_beneficial := !is_unboxing_beneficial || is_unboxing_beneficial_for_epa epa; let decision = filter_non_beneficial_decisions decision in - { epa; decision })) + { epa; decision; kind })) fields_by_tag in if !is_unboxing_beneficial diff --git a/middle_end/flambda2/simplify/unboxing/optimistic_unboxing_decision.ml b/middle_end/flambda2/simplify/unboxing/optimistic_unboxing_decision.ml index b8d4bd93020..457ecabdb85 100644 --- a/middle_end/flambda2/simplify/unboxing/optimistic_unboxing_decision.ml +++ b/middle_end/flambda2/simplify/unboxing/optimistic_unboxing_decision.ml @@ -128,6 +128,9 @@ and make_optimistic_fields ~add_tag_to_name ~depth tenv param_type (tag : Tag.t) then K.naked_float, "unboxed_float_field" else K.value, "unboxed_field" in + let field_kind_with_subkind = + K.With_subkind.create field_kind K.With_subkind.Subkind.Anything + in let field_name n = Format.asprintf "%s%a_%d" field_base_name (pp_tag add_tag_to_name) tag n in @@ -168,7 +171,7 @@ and make_optimistic_fields ~add_tag_to_name ~depth tenv param_type (tag : Tag.t) let decision = make_optimistic_decision ~depth:(depth + 1) tenv ~param_type:var_type in - { epa; decision }) + { epa; decision; kind = field_kind_with_subkind }) field_vars field_types in fields @@ -183,5 +186,10 @@ and make_optimistic_vars_within_closure ~depth tenv closures_entry = let decision = make_optimistic_decision ~depth:(depth + 1) tenv ~param_type:var_type in - { epa; decision }) + let kind = + K.With_subkind.create + (Flambda2_types.kind var_type) + K.With_subkind.Subkind.Anything + in + { epa; decision; kind }) map diff --git a/middle_end/flambda2/simplify/unboxing/unboxers.ml b/middle_end/flambda2/simplify/unboxing/unboxers.ml index b06cabd9918..0172e975148 100644 --- a/middle_end/flambda2/simplify/unboxing/unboxers.ml +++ b/middle_end/flambda2/simplify/unboxing/unboxers.ml @@ -139,15 +139,16 @@ module Field = struct end module Closure_field = struct - let unboxing_prim function_slot ~closure value_slot = + let unboxing_prim function_slot ~closure value_slot kind = P.Unary - (Project_value_slot { project_from = function_slot; value_slot }, closure) + ( Project_value_slot { project_from = function_slot; value_slot; kind }, + closure ) - let unboxer function_slot value_slot = + let unboxer function_slot value_slot kind = { var_name = "closure_field_at_use"; invalid_const = Const.const_zero; unboxing_prim = - (fun closure -> unboxing_prim function_slot ~closure value_slot); + (fun closure -> unboxing_prim function_slot ~closure value_slot kind); prove_simple = (fun tenv ~min_name_mode t -> T.meet_project_value_slot_simple tenv ~min_name_mode t value_slot) diff --git a/middle_end/flambda2/simplify/unboxing/unboxers.mli b/middle_end/flambda2/simplify/unboxing/unboxers.mli index ddd4e4e393e..bfa61f223c4 100644 --- a/middle_end/flambda2/simplify/unboxing/unboxers.mli +++ b/middle_end/flambda2/simplify/unboxing/unboxers.mli @@ -60,7 +60,13 @@ module Field : sig end module Closure_field : sig - val unboxing_prim : Function_slot.t -> closure:Simple.t -> Value_slot.t -> P.t + val unboxing_prim : + Function_slot.t -> + closure:Simple.t -> + Value_slot.t -> + Flambda_kind.With_subkind.t -> + P.t - val unboxer : Function_slot.t -> Value_slot.t -> unboxer + val unboxer : + Function_slot.t -> Value_slot.t -> Flambda_kind.With_subkind.t -> unboxer end diff --git a/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml b/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml index 42649e39f48..e5e7737d91e 100644 --- a/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml +++ b/middle_end/flambda2/simplify/unboxing/unboxing_epa.ml @@ -272,7 +272,7 @@ and compute_extra_args_for_block ~pass rewrite_id ~typing_env_at_use in let _, fields = List.fold_left_map - (fun field_nth ({ epa; decision } : U.field_decision) : + (fun field_nth ({ epa; decision; kind } : U.field_decision) : (_ * U.field_decision) -> let unboxer = Unboxers.Field.unboxer ~invalid_const bak ~index:field_nth @@ -287,7 +287,7 @@ and compute_extra_args_for_block ~pass rewrite_id ~typing_env_at_use compute_extra_args_for_one_decision_and_use ~pass rewrite_id ~typing_env_at_use new_arg_being_unboxed decision in - Targetint_31_63.(add one field_nth), { epa; decision }) + Targetint_31_63.(add one field_nth), { epa; decision; kind }) Targetint_31_63.zero fields in Unbox (Unique_tag_and_size { tag; fields }) @@ -296,8 +296,8 @@ and compute_extra_args_for_closure ~pass rewrite_id ~typing_env_at_use arg_being_unboxed function_slot vars_within_closure : U.decision = let vars_within_closure = Value_slot.Map.mapi - (fun var ({ epa; decision } : U.field_decision) : U.field_decision -> - let unboxer = Unboxers.Closure_field.unboxer function_slot var in + (fun var ({ epa; decision; kind } : U.field_decision) : U.field_decision -> + let unboxer = Unboxers.Closure_field.unboxer function_slot var kind in let new_extra_arg, new_arg_being_unboxed = unbox_arg unboxer ~typing_env_at_use arg_being_unboxed in @@ -308,7 +308,7 @@ and compute_extra_args_for_closure ~pass rewrite_id ~typing_env_at_use compute_extra_args_for_one_decision_and_use ~pass rewrite_id ~typing_env_at_use new_arg_being_unboxed decision in - { epa; decision }) + { epa; decision; kind }) vars_within_closure in Unbox (Closure_single_entry { function_slot; vars_within_closure }) @@ -377,7 +377,7 @@ and compute_extra_args_for_variant ~pass rewrite_id ~typing_env_at_use let new_fields_decisions, _ = List.fold_left (fun (new_decisions, field_nth) - ({ epa; decision } : U.field_decision) -> + ({ epa; decision; kind } : U.field_decision) -> let new_extra_arg, new_arg_being_unboxed = if are_there_non_const_ctors_at_use && Tag.Scannable.equal tag_at_use_site tag_decision @@ -398,7 +398,7 @@ and compute_extra_args_for_variant ~pass rewrite_id ~typing_env_at_use compute_extra_args_for_one_decision_and_use ~pass rewrite_id ~typing_env_at_use new_arg_being_unboxed decision in - let field_decision : U.field_decision = { epa; decision } in + let field_decision : U.field_decision = { epa; decision; kind } in let new_decisions = field_decision :: new_decisions in new_decisions, Targetint_31_63.(add one field_nth)) ([], Targetint_31_63.zero) block_fields @@ -412,14 +412,9 @@ let add_extra_params_and_args extra_params_and_args decision = let rec aux extra_params_and_args (decision : U.decision) = match decision with | Do_not_unbox _ -> extra_params_and_args - | Unbox (Unique_tag_and_size { tag; fields }) -> + | Unbox (Unique_tag_and_size { tag = _; fields }) -> List.fold_left - (fun extra_params_and_args ({ epa; decision } : U.field_decision) -> - let kind = - if Tag.equal Tag.double_array_tag tag - then K.With_subkind.naked_float - else K.With_subkind.any_value - in + (fun extra_params_and_args ({ epa; decision; kind } : U.field_decision) -> let extra_param = BP.create epa.param kind in let extra_params_and_args = EPA.add extra_params_and_args ~extra_param ~extra_args:epa.args @@ -428,8 +423,9 @@ let add_extra_params_and_args extra_params_and_args decision = extra_params_and_args fields | Unbox (Closure_single_entry { function_slot = _; vars_within_closure }) -> Value_slot.Map.fold - (fun _ ({ epa; decision } : U.field_decision) extra_params_and_args -> - let extra_param = BP.create epa.param K.With_subkind.any_value in + (fun _ ({ epa; decision; kind } : U.field_decision) + extra_params_and_args -> + let extra_param = BP.create epa.param kind in let extra_params_and_args = EPA.add extra_params_and_args ~extra_param ~extra_args:epa.args in @@ -440,10 +436,9 @@ let add_extra_params_and_args extra_params_and_args decision = Tag.Scannable.Map.fold (fun _ block_fields extra_params_and_args -> List.fold_left - (fun extra_params_and_args ({ epa; decision } : U.field_decision) -> - let extra_param = - BP.create epa.param K.With_subkind.any_value - in + (fun extra_params_and_args + ({ epa; decision; kind } : U.field_decision) -> + let extra_param = BP.create epa.param kind in let extra_params_and_args = EPA.add extra_params_and_args ~extra_param ~extra_args:epa.args diff --git a/middle_end/flambda2/simplify/unboxing/unboxing_types.ml b/middle_end/flambda2/simplify/unboxing/unboxing_types.ml index e85ec3ad58e..0efd64cffbb 100644 --- a/middle_end/flambda2/simplify/unboxing/unboxing_types.ml +++ b/middle_end/flambda2/simplify/unboxing/unboxing_types.ml @@ -64,7 +64,8 @@ type unboxing_decision = and field_decision = { epa : Extra_param_and_args.t; - decision : decision + decision : decision; + kind : Flambda_kind.With_subkind.t } and const_ctors_decision = @@ -126,10 +127,11 @@ let rec print_decision ppf = function "@[(number@ @[(kind %a)@]@ @[(var %a)@])@]" Flambda_kind.Naked_number_kind.print kind Extra_param_and_args.print epa -and print_field_decision ppf { epa; decision } = +and print_field_decision ppf { epa; decision; kind } = Format.fprintf ppf - "@[(@,@[(var %a)@]@ @[(decision@ %a)@])@]" + "@[(@,@[(var %a)@]@ @[(decision@ %a)@]@ (kind@ %a))@]" Extra_param_and_args.print epa print_decision decision + Flambda_kind.With_subkind.print kind and print_fields_decisions ppf l = let pp_sep = Format.pp_print_space in diff --git a/middle_end/flambda2/simplify/unboxing/unboxing_types.mli b/middle_end/flambda2/simplify/unboxing/unboxing_types.mli index a4ea06e687e..8660f4e8404 100644 --- a/middle_end/flambda2/simplify/unboxing/unboxing_types.mli +++ b/middle_end/flambda2/simplify/unboxing/unboxing_types.mli @@ -57,7 +57,8 @@ type unboxing_decision = and field_decision = { epa : Extra_param_and_args.t; - decision : decision + decision : decision; + kind : Flambda_kind.With_subkind.t } and const_ctors_decision = diff --git a/middle_end/flambda2/simplify_shared/call_site_inlining_decision_type.ml b/middle_end/flambda2/simplify_shared/call_site_inlining_decision_type.ml index 4a3866819b9..fd5628f8d2d 100644 --- a/middle_end/flambda2/simplify_shared/call_site_inlining_decision_type.ml +++ b/middle_end/flambda2/simplify_shared/call_site_inlining_decision_type.ml @@ -33,6 +33,7 @@ type t = | Max_inlining_depth_exceeded | Recursion_depth_exceeded | Never_inlined_attribute + | Unroll_attribute_used_with_loopified_function | Speculatively_not_inline of { cost_metrics : Cost_metrics.t; evaluated_to : float; @@ -64,6 +65,8 @@ let [@ocamlformat "disable"] print ppf t = Format.fprintf ppf "Recursion_depth_exceeded" | Never_inlined_attribute -> Format.fprintf ppf "Never_inlined_attribute" + | Unroll_attribute_used_with_loopified_function -> + Format.fprintf ppf "Unroll_attribute_used_with_loopified_function" | Attribute_always -> Format.fprintf ppf "Attribute_always" | Definition_says_inline { was_inline_always } -> @@ -126,6 +129,10 @@ let can_inline (t : t) : can_inline = attribute when we stop unrolling, which is fine *) Do_not_inline { warn_if_attribute_ignored = false; because_of_definition = true } + | Unroll_attribute_used_with_loopified_function -> + (* We have an [@unrolled] attribute, but can't unroll loopified functions *) + Do_not_inline + { warn_if_attribute_ignored = true; because_of_definition = true } | Attribute_unroll unroll_to -> Inline { unroll_to = Some unroll_to; was_inline_always = false } | Definition_says_inline { was_inline_always } -> @@ -156,6 +163,11 @@ let report_reason fmt t = Format.fprintf fmt "the@ maximum@ recursion@ depth@ has@ been@ exceeded" | Never_inlined_attribute -> Format.fprintf fmt "the@ call@ has@ an@ attribute@ forbidding@ inlining" + | Unroll_attribute_used_with_loopified_function -> + Format.fprintf fmt + "the@ code@ of@ this@ function@ has@ been@ transformed@ to@ a@ loop,@ \ + which@ cannot@ be@ unrolled@ yet@ (consider@ adding@ [@loop never]@ to@ \ + the@ definition)" | Attribute_always -> Format.fprintf fmt "the@ call@ has@ an@ [@@inline always]@ attribute" | Attribute_unroll n -> diff --git a/middle_end/flambda2/simplify_shared/call_site_inlining_decision_type.mli b/middle_end/flambda2/simplify_shared/call_site_inlining_decision_type.mli index 9c44112961a..8b42232f2e6 100644 --- a/middle_end/flambda2/simplify_shared/call_site_inlining_decision_type.mli +++ b/middle_end/flambda2/simplify_shared/call_site_inlining_decision_type.mli @@ -26,6 +26,7 @@ type t = | Max_inlining_depth_exceeded | Recursion_depth_exceeded | Never_inlined_attribute + | Unroll_attribute_used_with_loopified_function | Speculatively_not_inline of { cost_metrics : Cost_metrics.t; evaluated_to : float; diff --git a/middle_end/flambda2/simplify_shared/exported_offsets.ml b/middle_end/flambda2/simplify_shared/exported_offsets.ml index f605411f396..c3483188e03 100644 --- a/middle_end/flambda2/simplify_shared/exported_offsets.ml +++ b/middle_end/flambda2/simplify_shared/exported_offsets.ml @@ -19,11 +19,13 @@ compilation cannot see, all offsets that occur in the current compilation unit should be re-exported. *) +type words = int + type function_slot_info = | Dead_function_slot | Live_function_slot of - { offset : int; - size : int + { offset : words; + size : words (* Number of fields taken for the function: 2 fields (code pointer + arity) for function of arity one @@ -33,7 +35,11 @@ type function_slot_info = type value_slot_info = | Dead_value_slot - | Live_value_slot of { offset : int } + | Live_value_slot of + { offset : words; + size : words; + is_scanned : bool + } type t = { function_slot_offsets : function_slot_info Function_slot.Map.t; @@ -48,7 +54,8 @@ let print_function_slot_info fmt = function let print_value_slot_info fmt (info : value_slot_info) = match info with | Dead_value_slot -> Format.fprintf fmt "@[(removed)@]" - | Live_value_slot { offset } -> Format.fprintf fmt "@[(o:%d)@]" offset + | Live_value_slot { offset; size; is_scanned } -> + Format.fprintf fmt "@[(o:%d, s:%d, v:%b)@]" offset size is_scanned let [@ocamlformat "disable"] print fmt env = Format.fprintf fmt "{@[closures: @[%a@]@,value_slots: @[%a@]@]}" @@ -74,7 +81,9 @@ let equal_function_slot_info (info1 : function_slot_info) let equal_value_slot_info (info1 : value_slot_info) (info2 : value_slot_info) = match info1, info2 with | Dead_value_slot, Dead_value_slot -> true - | Live_value_slot { offset = o1 }, Live_value_slot { offset = o2 } -> o1 = o2 + | ( Live_value_slot { offset = o1; size = s1; is_scanned = v1 }, + Live_value_slot { offset = o2; size = s2; is_scanned = v2 } ) -> + o1 = o2 && s1 = s2 && v1 = v2 | Dead_value_slot, Live_value_slot _ | Live_value_slot _, Dead_value_slot -> false diff --git a/middle_end/flambda2/simplify_shared/exported_offsets.mli b/middle_end/flambda2/simplify_shared/exported_offsets.mli index 700b79d7de6..1446ba79679 100644 --- a/middle_end/flambda2/simplify_shared/exported_offsets.mli +++ b/middle_end/flambda2/simplify_shared/exported_offsets.mli @@ -15,11 +15,13 @@ (** Public state to store the mapping from elements of a closure to offset. *) type t +type words = int + type function_slot_info = | Dead_function_slot | Live_function_slot of - { offset : int; - size : int + { offset : words; + size : words (* Number of fields taken for the function: 2 fields (code pointer + arity) for function of arity one @@ -29,7 +31,11 @@ type function_slot_info = type value_slot_info = | Dead_value_slot - | Live_value_slot of { offset : int } + | Live_value_slot of + { offset : words; + size : words; + is_scanned : bool + } (** The empty environment *) val empty : t diff --git a/middle_end/flambda2/simplify_shared/slot_offsets.ml b/middle_end/flambda2/simplify_shared/slot_offsets.ml index 8880d315597..1c71da5943e 100644 --- a/middle_end/flambda2/simplify_shared/slot_offsets.ml +++ b/middle_end/flambda2/simplify_shared/slot_offsets.ml @@ -32,16 +32,21 @@ type used_slots = all_value_slots : Value_slot.Set.t } -let[@inline] value_slot_is_used ~used_value_slots v = - if Compilation_unit.is_current (Value_slot.get_compilation_unit v) - then Value_slot.Set.mem v used_value_slots - else true - let[@inline] function_slot_is_used ~used_function_slots v = if Compilation_unit.is_current (Function_slot.get_compilation_unit v) then Function_slot.Set.mem v used_function_slots else true +let[@inline] unboxed_slot_is_used ~used_unboxed_slots v = + if Compilation_unit.is_current (Value_slot.get_compilation_unit v) + then Value_slot.Set.mem v used_unboxed_slots + else true + +let[@inline] value_slot_is_used ~used_value_slots v = + if Compilation_unit.is_current (Value_slot.get_compilation_unit v) + then Value_slot.Set.mem v used_value_slots + else true + (* Compute offsets of the runtime memory layout of sets of closures. These offsets are computed in words, not in bytes. @@ -69,6 +74,15 @@ let[@inline] function_slot_is_used ~used_function_slots v = * | last function slot | * | | * |----------------------| + * | unboxed slot 0 | + * |----------------------| + * | unboxed slot 1 | + * |----------------------| + * . . + * . . + * |----------------------| + * | last unboxed slot | + * |----------------------| * | value slot 0 size=1 | <- start of the environment part of the block * |----------------------| * | value slot 1 | @@ -82,17 +96,21 @@ let[@inline] function_slot_is_used ~used_function_slots v = (* However, that ideal layout may not be possible in certain circumstances, as there may be arbitrary holes between slots (i.e. unused words in the block). - All function slots must occur before all value slots, since the offset to the - start of the environment is recorded in the arity field of each function - slot. *) + Due to the representation above, all function slots must occur before all + unboxed slots, which themselves must be before all value slots. *) module Layout = struct type slot = - | Value_slot of Value_slot.t + | Value_slot of + { size : words; + is_scanned : bool; + value_slot : Value_slot.t + } | Infix_header | Function_slot of { size : words; - function_slot : Function_slot.t + function_slot : Function_slot.t; + last_function_slot : bool } type t = @@ -102,11 +120,14 @@ module Layout = struct } let print_slot fmt = function - | Value_slot v -> Format.fprintf fmt "value_slot %a" Value_slot.print v + | Value_slot { size; is_scanned; value_slot } -> + Format.fprintf fmt "value_slot(%d,%b) %a" size is_scanned Value_slot.print + value_slot | Infix_header -> Format.fprintf fmt "infix_header" - | Function_slot { size; function_slot } -> - Format.fprintf fmt "function_slot(%d) %a" size Function_slot.print - function_slot + | Function_slot { size; function_slot; last_function_slot } -> + Format.fprintf fmt "function_slot%s(%d) %a" + (if last_function_slot then "[last]" else "") + size Function_slot.print function_slot let print fmt l = Format.fprintf fmt "@[startenv: %d;@ " l.startenv; @@ -122,20 +143,36 @@ module Layout = struct | Some Dead_function_slot -> acc | Some (Live_function_slot { size; offset }) -> Numeric_types.Int.Map.add offset - (Function_slot { size; function_slot }) + (Function_slot { size; function_slot; last_function_slot = false }) acc | None -> Misc.fatal_errorf "No function_slot offset for %a" Function_slot.print function_slot) l acc + let mark_last_function_slot map = + match Numeric_types.Int.Map.max_binding map with + | offset, Function_slot slot -> + Numeric_types.Int.Map.add offset + (Function_slot { slot with last_function_slot = true }) + map + | _, (Value_slot _ | Infix_header) -> + Misc.fatal_errorf + "Slot_offsets: function slots should be added before any other so that \ + the last function slot can be computed correctly" + | exception Not_found -> + Misc.fatal_errorf + "Slot_offsets: set of closures msut have at least one function slot" + let order_value_slots env l acc = Value_slot.Map.fold (fun value_slot _ acc -> match EO.value_slot_offset env value_slot with | Some Dead_value_slot -> acc - | Some (Live_value_slot { offset }) -> - Numeric_types.Int.Map.add offset (Value_slot value_slot) acc + | Some (Live_value_slot { offset; is_scanned; size }) -> + Numeric_types.Int.Map.add offset + (Value_slot { value_slot; is_scanned; size }) + acc | None -> Misc.fatal_errorf "No value slot offset for %a" Value_slot.print value_slot) @@ -165,13 +202,14 @@ module Layout = struct (offset, slot) :: (offset - 1, Infix_header) :: acc_slots in startenv, acc_slots - | Value_slot _ -> + | Value_slot { is_scanned; _ } -> let startenv = match startenv with | Some i -> + assert is_scanned; assert (i < offset); startenv - | None -> Some offset + | None -> if is_scanned then Some offset else None in let acc_slots = (offset, slot) :: acc_slots in startenv, acc_slots @@ -181,10 +219,13 @@ module Layout = struct assert false let make env function_slots value_slots = + (* Function slots must be added first to the map so that we can then + identify the last function slot *) let map = Numeric_types.Int.Map.empty - |> order_value_slots env value_slots |> order_function_slots env function_slots + |> mark_last_function_slot + |> order_value_slots env value_slots in let startenv_opt, rev_slots = Numeric_types.Int.Map.fold layout_aux map (None, []) @@ -197,11 +238,13 @@ module Layout = struct | Some i, _ -> i, false | None, [] -> 0, true (* will raise a fatal_error later *) | None, (offset, Function_slot { size; _ }) :: _ -> offset + size, true + | None, (offset, Value_slot { is_scanned = false; size; _ }) :: _ -> + offset + size, false | None, (_, Infix_header) :: _ -> (* Cannot happen because a infix header is *always* preceded by a function slot (because the slot list is reversed) *) assert false - | None, (_, Value_slot _) :: _ -> + | None, (_, Value_slot { is_scanned = true; _ }) :: _ -> (* Cannot happen because if there is a value slot in the acc, then startenv_opt should be Some _ *) assert false @@ -265,13 +308,16 @@ end = struct type value_slot = Value + type unboxed_slot = Unboxed + type function_slot = Function (* silence warning 37 (unused constructor) *) - let _ = Value, Function + let _ = Value, Unboxed, Function type _ slot_desc = | Function_slot : Function_slot.t -> function_slot slot_desc + | Unboxed_slot : Value_slot.t -> unboxed_slot slot_desc | Value_slot : Value_slot.t -> value_slot slot_desc (* This module helps to distinguish between the two different notions of @@ -312,14 +358,14 @@ end = struct let offset = match slot with | Function_slot _ -> first_offset_used_including_header + 1 - | Value_slot _ -> first_offset_used_including_header + | Unboxed_slot _ | Value_slot _ -> first_offset_used_including_header in Offset offset let range_used_by (type a) (slot : a slot_desc) (Offset pos) ~slot_size = match slot with | Function_slot _ -> pos - 1, pos + slot_size - | Value_slot _ -> pos, pos + slot_size + | Unboxed_slot _ | Value_slot _ -> pos, pos + slot_size let add_slot_to_exported_offsets (type a) offsets (slot : a slot_desc) (Offset pos) ~slot_size = @@ -329,8 +375,17 @@ end = struct EO.Live_function_slot { offset = pos; size = slot_size } in EO.add_function_slot_offset offsets function_slot info + | Unboxed_slot unboxed_slot -> + let (info : EO.value_slot_info) = + EO.Live_value_slot + { offset = pos; is_scanned = false; size = slot_size } + in + EO.add_value_slot_offset offsets unboxed_slot info | Value_slot value_slot -> - let (info : EO.value_slot_info) = EO.Live_value_slot { offset = pos } in + let (info : EO.value_slot_info) = + EO.Live_value_slot + { offset = pos; is_scanned = true; size = slot_size } + in EO.add_value_slot_offset offsets value_slot info end @@ -346,11 +401,17 @@ end = struct (* metadata used for priorities *) num_value_slots : int; num_function_slots : int; - (* Info about start of environment *) - mutable first_slot_used_by_value_slots : words; + (* Info about transitions between different types of slots *) mutable first_slot_after_function_slots : words; - (* invariant : first_slot_after_function_slots <= - first_slot_used_by_calue_slots *) + mutable first_slot_used_by_unboxed_slots : words; + mutable first_slot_after_unboxed_slots : words; + mutable first_slot_used_by_value_slots : words; + (* invariants : + * first_slot_after_function_slots <= first_slot_used_by_unboxed_slots + * first_slot_after_function_slots <= first_slot_after_unboxed_slots + * first_slot_after_unboxed_slots <= first_slot_used_by_value_slots + * first_slot_after_function_slots <= first_slot_used_by_value_slots + *) mutable allocated_slots : any_slot Numeric_types.Int.Map.t (* map indexed by the offset of the first word used by a slot (including its infix header if it exists). *) @@ -373,9 +434,11 @@ end = struct type state = { mutable used_offsets : EO.t; mutable function_slots : function_slot slot Function_slot.Map.t; + mutable unboxed_slots : unboxed_slot slot Value_slot.Map.t; mutable value_slots : value_slot slot Value_slot.Map.t; mutable sets_of_closures : set_of_closures list; mutable function_slots_to_assign : function_slot slot list; + mutable unboxed_slots_to_assign : unboxed_slot slot list; mutable value_slots_to_assign : value_slot slot list } @@ -399,6 +462,8 @@ end = struct num_value_slots; num_function_slots; first_slot_after_function_slots = 0; + first_slot_used_by_unboxed_slots = max_int; + first_slot_after_unboxed_slots = 0; first_slot_used_by_value_slots = max_int; allocated_slots = Numeric_types.Int.Map.empty } @@ -406,9 +471,11 @@ end = struct let create_initial_state () = { used_offsets = EO.empty; function_slots = Function_slot.Map.empty; + unboxed_slots = Value_slot.Map.empty; value_slots = Value_slot.Map.empty; sets_of_closures = []; function_slots_to_assign = []; + unboxed_slots_to_assign = []; value_slots_to_assign = [] } @@ -421,7 +488,8 @@ end = struct let print_desc (type a) fmt (slot_desc : a slot_desc) = match slot_desc with | Function_slot c -> Format.fprintf fmt "%a" Function_slot.print c - | Value_slot v -> Format.fprintf fmt "%a" Value_slot.print v + | Unboxed_slot v | Value_slot v -> + Format.fprintf fmt "%a" Value_slot.print v let print_slot_pos fmt = function | Assigned offset -> Format.fprintf fmt "%a" Exported_offset.print offset @@ -449,12 +517,16 @@ end = struct Format.fprintf fmt "@[%d:@ \ @[first_slot_after_function_slots: %d;@ \ + first_slot_used_by_unboxed_slots: %d;@ \ + first_slot_after_unboxed_slots: %d;@ \ first_slot_used_by_value_slots: %d;@ \ allocated: @[%a@]\ @]\ @]" s.id s.first_slot_after_function_slots + s.first_slot_used_by_unboxed_slots + s.first_slot_after_unboxed_slots s.first_slot_used_by_value_slots print_any_slot_map s.allocated_slots @@ -462,15 +534,17 @@ end = struct List.iter (function s -> Format.fprintf fmt "%a@ " print_set s) l let [@ocamlformat "disable"] print fmt { - used_offsets = _; function_slots = _; value_slots = _; - sets_of_closures; function_slots_to_assign; value_slots_to_assign; } = + used_offsets = _; function_slots = _; unboxed_slots = _; value_slots = _; + sets_of_closures; function_slots_to_assign; unboxed_slots_to_assign; value_slots_to_assign; } = Format.fprintf fmt "@[(@,\ (function slots to assign@ @[%a@])@ \ + (unboxed slots to assign@ @[%a@])@ \ (value slots to assign@ @[%a@])\ (sets of closures@ @[%a@])@,\ )@]" print_slot_list function_slots_to_assign + print_slot_list unboxed_slots_to_assign print_slot_list value_slots_to_assign print_sets sets_of_closures [@@warning "-32"] @@ -483,22 +557,36 @@ end = struct | Assigned offset -> ( match slot.desc with | Value_slot _ -> + if slot.size <> 1 + then + Misc.fatal_errorf "Value slot has size %d, which is not 1." slot.size; let start, _ = Exported_offset.range_used_by slot.desc offset ~slot_size:1 in set.first_slot_used_by_value_slots - <- min set.first_slot_used_by_value_slots start + <- min set.first_slot_used_by_value_slots start; + set.first_slot_used_by_unboxed_slots + <- min set.first_slot_used_by_unboxed_slots start + | Unboxed_slot _ -> + let start, last = + Exported_offset.range_used_by slot.desc offset ~slot_size:slot.size + in + set.first_slot_used_by_unboxed_slots + <- min set.first_slot_used_by_unboxed_slots start; + set.first_slot_after_unboxed_slots + <- max set.first_slot_after_unboxed_slots last | Function_slot _ -> let _, last = Exported_offset.range_used_by slot.desc offset ~slot_size:slot.size in set.first_slot_after_function_slots - <- max set.first_slot_after_function_slots last)); - if set.first_slot_used_by_value_slots < set.first_slot_after_function_slots - then - Misc.fatal_errorf - "Set of closures invariant (all function slots before all value slots) \ - is broken" + <- max set.first_slot_after_function_slots last; + set.first_slot_after_unboxed_slots + <- max set.first_slot_after_unboxed_slots last)); + if set.first_slot_used_by_value_slots < set.first_slot_after_unboxed_slots + || set.first_slot_used_by_unboxed_slots + < set.first_slot_after_function_slots + then Misc.fatal_errorf "Set of closures invariant (slot ordering) is broken" (* Slots *) @@ -536,7 +624,7 @@ end = struct let (info : EO.function_slot_info) = EO.Dead_function_slot in state.used_offsets <- EO.add_function_slot_offset state.used_offsets function_slot info - | Value_slot v -> + | Unboxed_slot v | Value_slot v -> let (info : EO.value_slot_info) = EO.Dead_value_slot in state.used_offsets <- EO.add_value_slot_offset state.used_offsets v info ) @@ -551,6 +639,8 @@ end = struct match slot.desc with | Function_slot _ -> state.function_slots_to_assign <- slot :: state.function_slots_to_assign + | Unboxed_slot _ -> + state.unboxed_slots_to_assign <- slot :: state.unboxed_slots_to_assign | Value_slot _ -> state.value_slots_to_assign <- slot :: state.value_slots_to_assign @@ -563,6 +653,11 @@ end = struct slot.lowest_num_slots_in_sets <- min slot.lowest_num_slots_in_sets set.num_function_slots + let update_metadata_for_unboxed_slot set slot = + slot.occurrences <- slot.occurrences + 1; + slot.lowest_num_slots_in_sets + <- min slot.lowest_num_slots_in_sets set.num_value_slots + let update_metadata_for_value_slot set slot = slot.occurrences <- slot.occurrences + 1; slot.lowest_num_slots_in_sets @@ -601,6 +696,12 @@ end = struct state.function_slots <- Function_slot.Map.add function_slot slot state.function_slots + let use_unboxed_slot_info state var info = + state.used_offsets <- EO.add_value_slot_offset state.used_offsets var info + + let add_unboxed_slot state var slot = + state.unboxed_slots <- Value_slot.Map.add var slot state.unboxed_slots + let use_value_slot_info state var info = state.used_offsets <- EO.add_value_slot_offset state.used_offsets var info @@ -610,6 +711,9 @@ end = struct let find_function_slot state closure = Function_slot.Map.find_opt closure state.function_slots + let find_unboxed_slot state var = + Value_slot.Map.find_opt var state.unboxed_slots + let find_value_slot state var = Value_slot.Map.find_opt var state.value_slots (* Create slots (and create the cross-referencing). *) @@ -660,6 +764,43 @@ end = struct add_allocated_slot_to_set s set; s + let create_unboxed_slot set state value_slot size = + if Compilation_unit.is_current (Value_slot.get_compilation_unit value_slot) + then ( + let s = create_slot ~size (Unboxed_slot value_slot) Unassigned in + add_unboxed_slot state value_slot s; + add_unallocated_slot_to_set state s set; + s) + else + (* Same as the comments for the function_slots *) + let imported_offsets = EO.imported_offsets () in + match EO.value_slot_offset imported_offsets value_slot with + | None -> + (* See comment for the function_slot *) + Misc.fatal_errorf + "Could not find the offset for value slot %a from another \ + compilation unit (because of -opaque, or missing cmx)." + Value_slot.print value_slot + | Some Dead_value_slot -> + Misc.fatal_errorf + "The value slot %a has been removed by its original compilation \ + unit, it should not occur in a set of closures in this compilation \ + unit." + Value_slot.print value_slot + | Some (Live_value_slot { offset; is_scanned; size = sz } as info) -> + if is_scanned || sz <> size + then + Misc.fatal_errorf + "The unboxed slot %a existed but was not unboxed or of a different \ + size in the original compilation unit, this should not happen." + Value_slot.print value_slot; + let offset = Exported_offset.from_exported_offset offset in + let s = create_slot ~size (Unboxed_slot value_slot) (Assigned offset) in + use_unboxed_slot_info state value_slot info; + add_unboxed_slot state value_slot s; + add_allocated_slot_to_set s set; + s + let create_value_slot set state value_slot = if Compilation_unit.is_current (Value_slot.get_compilation_unit value_slot) then ( @@ -683,7 +824,13 @@ end = struct unit, it should not occur in a set of closures in this compilation \ unit." Value_slot.print value_slot - | Some (Live_value_slot { offset } as info) -> + | Some (Live_value_slot { offset; is_scanned; size = sz } as info) -> + if (not is_scanned) || sz <> 1 + then + Misc.fatal_errorf + "The value slot %a existed but was unboxed or of a different size \ + in the original compilation unit, this should not happen." + Value_slot.print value_slot; let offset = Exported_offset.from_exported_offset offset in let s = create_slot ~size:1 (Value_slot value_slot) (Assigned offset) in use_value_slot_info state value_slot info; @@ -719,13 +866,38 @@ end = struct closure_map; (* Fill value slot slots *) Value_slot.Map.iter - (fun value_slot _ -> - let s = - match Value_slot.Map.find_opt value_slot state.value_slots with - | None -> create_value_slot set state value_slot - | Some s -> s + (fun value_slot (_, kind) -> + let size, is_unboxed = + match Flambda_kind.With_subkind.kind kind with + | Region | Rec_info -> + Misc.fatal_errorf "Value slot %a has Region or Rec_info kind" + Value_slot.print value_slot + | Naked_number _ -> + 1, true + (* flambda only supports 64-bits for now, so naked numbers can only + be of size 1 *) + | Value -> ( + match[@ocaml.warning "-4"] + Flambda_kind.With_subkind.subkind kind + with + | Tagged_immediate -> 1, true + | _ -> 1, false) in - update_metadata_for_value_slot set s) + if is_unboxed + then + let s = + match Value_slot.Map.find_opt value_slot state.unboxed_slots with + | None -> create_unboxed_slot set state value_slot size + | Some s -> s + in + update_metadata_for_unboxed_slot set s + else + let s = + match Value_slot.Map.find_opt value_slot state.value_slots with + | None -> create_value_slot set state value_slot + | Some s -> s + in + update_metadata_for_value_slot set s) env_map (* Find the first space available to fit a given slot. @@ -749,16 +921,17 @@ end = struct let needed_space = match slot.desc with | Function_slot _ -> slot.size + 1 (* header word *) - | Value_slot _ -> slot.size + | Unboxed_slot _ | Value_slot _ -> slot.size in (* Ensure that for value slots, we are after all function slots. *) let curr = match slot.desc with | Function_slot _ -> start - | Value_slot _ -> + | Unboxed_slot _ -> (* first_slot_after_function_slots is always >=0, thus ensuring we do not place a value slot at offset -1 *) max start set.first_slot_after_function_slots + | Value_slot _ -> max start set.first_slot_after_unboxed_slots in (* Adjust a starting position to not point in the middle of a block. Additionally, ensure the value slot slots are put after the function @@ -841,6 +1014,19 @@ end = struct (* else mark_slot_as_removed state slot *)) function_slots_to_assign + let assign_unboxed_slot_offsets ~used_unboxed_slots state = + let unboxed_slots_to_assign = + List.sort compare_priority state.unboxed_slots_to_assign + in + state.unboxed_slots_to_assign <- []; + List.iter + (function + | { desc = Unboxed_slot v; _ } as slot -> + if unboxed_slot_is_used ~used_unboxed_slots v + then assign_slot_offset state slot + else mark_slot_as_removed state slot) + unboxed_slots_to_assign + let assign_value_slot_offsets ~used_value_slots state = let value_slots_to_assign = List.sort compare_priority state.value_slots_to_assign @@ -902,28 +1088,42 @@ end = struct (fun value_slot -> if Compilation_unit.is_current (Value_slot.get_compilation_unit value_slot) - then ( + then (* a value slot appears in a set of closures iff it has a slot *) - match find_value_slot state value_slot with - | Some _ -> true - | None -> + match + ( find_value_slot state value_slot, + find_unboxed_slot state value_slot ) + with + | None, None -> state.used_offsets <- EO.add_value_slot_offset state.used_offsets value_slot Dead_value_slot; - false) + false + | _ -> true else true) value_slots_in_normal_projections in - live_function_slots, live_value_slots + let live_value_slots, live_unboxed_slots = + Value_slot.Set.partition + (fun value_slot -> Option.is_some (find_value_slot state value_slot)) + live_value_slots + in + live_function_slots, live_unboxed_slots, live_value_slots (* Transform an internal accumulator state for slots into an actual mapping that assigns offsets. *) let finalize ~used_slots state = add_used_imported_offsets ~used_slots state; - let used_function_slots, used_value_slots = live_slots state used_slots in + let used_function_slots, used_unboxed_slots, used_value_slots = + live_slots state used_slots + in assign_function_slot_offsets ~used_function_slots state; + assign_unboxed_slot_offsets ~used_unboxed_slots state; assign_value_slot_offsets ~used_value_slots state; - { used_value_slots; exported_offsets = state.used_offsets } + { used_value_slots = + Value_slot.Set.union used_value_slots used_unboxed_slots; + exported_offsets = state.used_offsets + } end type t = Set_of_closures.t list diff --git a/middle_end/flambda2/simplify_shared/slot_offsets.mli b/middle_end/flambda2/simplify_shared/slot_offsets.mli index 214604692ba..9a0a6182ba0 100644 --- a/middle_end/flambda2/simplify_shared/slot_offsets.mli +++ b/middle_end/flambda2/simplify_shared/slot_offsets.mli @@ -70,6 +70,8 @@ val finalize_offsets : t -> result +type words = int + (** {2 Offsets & Layouts} *) module Layout : sig (**) @@ -78,20 +80,25 @@ module Layout : sig layout slot can take up more than one word of memory (this is the case for closures, which can take either 2 or 3 words depending on arity). *) type slot = private - | Value_slot of Value_slot.t + | Value_slot of + { size : words; + is_scanned : bool; + value_slot : Value_slot.t + } | Infix_header | Function_slot of - { size : int; - function_slot : Function_slot.t + { size : words; + function_slot : Function_slot.t; + last_function_slot : bool } (**) (** Alias for complete layouts. The list is sorted according to offsets (in increasing order). *) type t = private - { startenv : int; + { startenv : words; empty_env : bool; - slots : (int * slot) list + slots : (words * slot) list } (** Order the given function slots and env vars into a list of layout slots diff --git a/middle_end/flambda2/term_basics/symbol_projection.ml b/middle_end/flambda2/term_basics/symbol_projection.ml index 2d11ae9b547..8f77c60b983 100644 --- a/middle_end/flambda2/term_basics/symbol_projection.ml +++ b/middle_end/flambda2/term_basics/symbol_projection.ml @@ -17,19 +17,23 @@ module Projection = struct | Block_load of { index : Targetint_31_63.t } | Project_value_slot of { project_from : Function_slot.t; - value_slot : Value_slot.t + value_slot : Value_slot.t; + kind : Flambda_kind.With_subkind.t } let block_load ~index = Block_load { index } - let project_value_slot project_from value_slot = - Project_value_slot { project_from; value_slot } + let project_value_slot project_from value_slot kind = + Project_value_slot { project_from; value_slot; kind } let hash t = match t with | Block_load { index } -> Targetint_31_63.hash index - | Project_value_slot { project_from; value_slot } -> - Hashtbl.hash (Function_slot.hash project_from, Value_slot.hash value_slot) + | Project_value_slot { project_from; value_slot; kind } -> + Hashtbl.hash + ( Function_slot.hash project_from, + Value_slot.hash value_slot, + Flambda_kind.With_subkind.hash kind ) let [@ocamlformat "disable"] print ppf t = match t with @@ -38,24 +42,36 @@ module Projection = struct @[(index@ %a)@]\ )@]" Targetint_31_63.print index - | Project_value_slot { project_from; value_slot; } -> + | Project_value_slot { project_from; value_slot; kind } -> Format.fprintf ppf "@[(Project_value_slot@ \ @[(project_from@ %a)@]@ \ - @[(var@ %a)@]\ + @[(var@ %a)@]@ \ + @[(kind@ %a)@]\ )@]" Function_slot.print project_from Value_slot.print value_slot + Flambda_kind.With_subkind.print kind let compare t1 t2 = match t1, t2 with | Block_load { index = index1 }, Block_load { index = index2 } -> Targetint_31_63.compare index1 index2 | ( Project_value_slot - { project_from = project_from1; value_slot = value_slot1 }, + { project_from = project_from1; + value_slot = value_slot1; + kind = kind1 + }, Project_value_slot - { project_from = project_from2; value_slot = value_slot2 } ) -> + { project_from = project_from2; + value_slot = value_slot2; + kind = kind2 + } ) -> let c = Function_slot.compare project_from1 project_from2 in - if c <> 0 then c else Value_slot.compare value_slot1 value_slot2 + if c <> 0 + then c + else + let c = Value_slot.compare value_slot1 value_slot2 in + if c <> 0 then c else Flambda_kind.With_subkind.compare kind1 kind2 | Block_load _, Project_value_slot _ -> -1 | Project_value_slot _, Block_load _ -> 1 end @@ -97,7 +113,7 @@ let free_names { symbol; projection } = let free_names = Name_occurrences.singleton_symbol symbol Name_mode.normal in match projection with | Block_load _ -> free_names - | Project_value_slot { project_from; value_slot } -> + | Project_value_slot { project_from; value_slot; kind = _ } -> Name_occurrences.add_function_slot_in_projection (Name_occurrences.add_value_slot_in_projection free_names value_slot Name_mode.normal) diff --git a/middle_end/flambda2/term_basics/symbol_projection.mli b/middle_end/flambda2/term_basics/symbol_projection.mli index 1659b18ba39..43bf206a574 100644 --- a/middle_end/flambda2/term_basics/symbol_projection.mli +++ b/middle_end/flambda2/term_basics/symbol_projection.mli @@ -17,12 +17,14 @@ module Projection : sig | Block_load of { index : Targetint_31_63.t } | Project_value_slot of { project_from : Function_slot.t; - value_slot : Value_slot.t + value_slot : Value_slot.t; + kind : Flambda_kind.With_subkind.t } val block_load : index:Targetint_31_63.t -> t - val project_value_slot : Function_slot.t -> Value_slot.t -> t + val project_value_slot : + Function_slot.t -> Value_slot.t -> Flambda_kind.With_subkind.t -> t end type t diff --git a/middle_end/flambda2/terms/apply_expr.ml b/middle_end/flambda2/terms/apply_expr.ml index 6f354917382..e9f5d82e2e7 100644 --- a/middle_end/flambda2/terms/apply_expr.ml +++ b/middle_end/flambda2/terms/apply_expr.ml @@ -204,10 +204,10 @@ let relative_history t = t.relative_history let position t = t.position -let free_names +let free_names_without_exn_continuation { callee; continuation; - exn_continuation; + exn_continuation = _; args; call_kind; dbg = _; @@ -221,11 +221,36 @@ let free_names Name_occurrences.union_list [ Simple.free_names callee; Result_continuation.free_names continuation; + Simple.List.free_names args; + Call_kind.free_names call_kind; + Name_occurrences.singleton_variable region Name_mode.normal ] + +let free_names_except_callee + { callee = _; + continuation; + exn_continuation; + args; + call_kind; + dbg = _; + inlined = _; + inlining_state = _; + probe_name = _; + position = _; + relative_history = _; + region + } = + Name_occurrences.union_list + [ Result_continuation.free_names continuation; Exn_continuation.free_names exn_continuation; Simple.List.free_names args; Call_kind.free_names call_kind; Name_occurrences.singleton_variable region Name_mode.normal ] +let free_names t = + Name_occurrences.union + (Simple.free_names t.callee) + (free_names_except_callee t) + let apply_renaming ({ callee; continuation; @@ -315,11 +340,6 @@ let with_call_kind t call_kind = let with_args t args = { t with args } -let with_continuation_callee_and_args t continuation ~callee ~args ~region = - let t = { t with continuation; callee; args; region } in - invariant t; - t - let inlining_arguments t = inlining_state t |> Inlining_state.arguments let probe_name t = t.probe_name diff --git a/middle_end/flambda2/terms/apply_expr.mli b/middle_end/flambda2/terms/apply_expr.mli index 96e452c5468..0d57199cb72 100644 --- a/middle_end/flambda2/terms/apply_expr.mli +++ b/middle_end/flambda2/terms/apply_expr.mli @@ -19,8 +19,12 @@ type t +val free_names_except_callee : t -> Name_occurrences.t + include Expr_std.S with type t := t +val free_names_without_exn_continuation : t -> Name_occurrences.t + include Contains_ids.S with type t := t module Result_continuation : sig @@ -103,15 +107,6 @@ val with_args : t -> Simple.t list -> t (** Change the call kind of an application. *) val with_call_kind : t -> Call_kind.t -> t -(** Change the continuation, callee and arguments of an application. *) -val with_continuation_callee_and_args : - t -> - Result_continuation.t -> - callee:Simple.t -> - args:Simple.t list -> - region:Variable.t -> - t - val inlining_state : t -> Inlining_state.t val inlining_arguments : t -> Inlining_arguments.t diff --git a/middle_end/flambda2/terms/code.ml b/middle_end/flambda2/terms/code.ml index 2ca7edd909c..e2e5d13cabf 100644 --- a/middle_end/flambda2/terms/code.ml +++ b/middle_end/flambda2/terms/code.ml @@ -61,3 +61,5 @@ let ids_for_export = Flambda.Function_params_and_body.ids_for_export let map_result_types = Code0.map_result_types + +let free_names_of_params_and_body = Code0.free_names_of_params_and_body diff --git a/middle_end/flambda2/terms/code.mli b/middle_end/flambda2/terms/code.mli index 389e64fd198..75d86b34c98 100644 --- a/middle_end/flambda2/terms/code.mli +++ b/middle_end/flambda2/terms/code.mli @@ -55,3 +55,5 @@ include Contains_names.S with type t := t val ids_for_export : t -> Ids_for_export.t val map_result_types : t -> f:(Flambda2_types.t -> Flambda2_types.t) -> t + +val free_names_of_params_and_body : t -> Name_occurrences.t diff --git a/middle_end/flambda2/terms/code0.ml b/middle_end/flambda2/terms/code0.ml index 09a4caca263..be47244d2d7 100644 --- a/middle_end/flambda2/terms/code0.ml +++ b/middle_end/flambda2/terms/code0.ml @@ -126,3 +126,5 @@ let ids_for_export ~ids_for_export_function_params_and_body let map_result_types ({ code_metadata; _ } as t) ~f = { t with code_metadata = Code_metadata.map_result_types code_metadata ~f } + +let free_names_of_params_and_body t = t.free_names_of_params_and_body diff --git a/middle_end/flambda2/terms/code0.mli b/middle_end/flambda2/terms/code0.mli index 9da53dea9be..169604bfffc 100644 --- a/middle_end/flambda2/terms/code0.mli +++ b/middle_end/flambda2/terms/code0.mli @@ -82,3 +82,6 @@ val map_result_types : 'function_params_and_body t -> f:(Flambda2_types.t -> Flambda2_types.t) -> 'function_params_and_body t + +val free_names_of_params_and_body : + 'function_params_and_body t -> Name_occurrences.t diff --git a/middle_end/flambda2/terms/code_metadata.ml b/middle_end/flambda2/terms/code_metadata.ml index b7e7cc01795..aa7df379384 100644 --- a/middle_end/flambda2/terms/code_metadata.ml +++ b/middle_end/flambda2/terms/code_metadata.ml @@ -25,6 +25,7 @@ type t = stub : bool; inline : Inline_attribute.t; check : Check_attribute.t; + poll_attribute : Poll_attribute.t; is_a_functor : bool; recursive : Recursive.t; cost_metrics : Cost_metrics.t; @@ -34,7 +35,8 @@ type t = is_my_closure_used : bool; inlining_decision : Function_decl_inlining_decision_type.t; absolute_history : Inlining_history.Absolute.t; - relative_history : Inlining_history.Relative.t + relative_history : Inlining_history.Relative.t; + loopify : Loopify_attribute.t } type code_metadata = t @@ -76,6 +78,8 @@ module Code_metadata_accessors (X : Metadata_view_type) = struct let check t = (metadata t).check + let poll_attribute t = (metadata t).poll_attribute + let is_a_functor t = (metadata t).is_a_functor let recursive t = (metadata t).recursive @@ -98,6 +102,8 @@ module Code_metadata_accessors (X : Metadata_view_type) = struct let absolute_history t = (metadata t).absolute_history let relative_history t = (metadata t).relative_history + + let loopify t = (metadata t).loopify end module type Code_metadata_accessors_result_type = sig @@ -129,6 +135,7 @@ type 'a create_type = stub:bool -> inline:Inline_attribute.t -> check:Check_attribute.t -> + poll_attribute:Poll_attribute.t -> is_a_functor:bool -> recursive:Recursive.t -> cost_metrics:Cost_metrics.t -> @@ -139,13 +146,15 @@ type 'a create_type = inlining_decision:Function_decl_inlining_decision_type.t -> absolute_history:Inlining_history.Absolute.t -> relative_history:Inlining_history.Relative.t -> + loopify:Loopify_attribute.t -> 'a let createk k code_id ~newer_version_of ~params_arity ~num_trailing_local_params ~result_arity ~result_types ~contains_no_escaping_local_allocs ~stub - ~(inline : Inline_attribute.t) ~check ~is_a_functor ~recursive ~cost_metrics - ~inlining_arguments ~dbg ~is_tupled ~is_my_closure_used ~inlining_decision - ~absolute_history ~relative_history = + ~(inline : Inline_attribute.t) ~check ~poll_attribute ~is_a_functor + ~recursive ~cost_metrics ~inlining_arguments ~dbg ~is_tupled + ~is_my_closure_used ~inlining_decision ~absolute_history ~relative_history + ~loopify = (match stub, inline with | true, (Available_inline | Never_inline | Default_inline) | ( false, @@ -172,6 +181,7 @@ let createk k code_id ~newer_version_of ~params_arity ~num_trailing_local_params stub; inline; check; + poll_attribute; is_a_functor; recursive; cost_metrics; @@ -181,7 +191,8 @@ let createk k code_id ~newer_version_of ~params_arity ~num_trailing_local_params is_my_closure_used; inlining_decision; absolute_history; - relative_history + relative_history; + loopify } let create = createk (fun t -> t) @@ -211,18 +222,19 @@ let [@ocamlformat "disable"] print_inlining_paths ppf Inlining_history.Absolute.print absolute_history let [@ocamlformat "disable"] print ppf - { code_id = _; newer_version_of; stub; inline; check; is_a_functor; - params_arity; num_trailing_local_params; result_arity; - result_types; contains_no_escaping_local_allocs; - recursive; cost_metrics; inlining_arguments; - dbg; is_tupled; is_my_closure_used; inlining_decision; - absolute_history; relative_history} = + { code_id = _; newer_version_of; stub; inline; check; poll_attribute; + is_a_functor; params_arity; num_trailing_local_params; result_arity; + result_types; contains_no_escaping_local_allocs; + recursive; cost_metrics; inlining_arguments; + dbg; is_tupled; is_my_closure_used; inlining_decision; + absolute_history; relative_history; loopify } = let module C = Flambda_colours in Format.fprintf ppf "@[(\ @[%t(newer_version_of@ %a)%t@]@ \ @[%t(stub@ %b)%t@]@ \ @[%t(inline@ %a)%t@]@ \ @[%t(%a)%t@]@ \ + @[%t(poll_attribute@ %a)%t@]@ \ @[%t(is_a_functor@ %b)%t@]@ \ @[%t(params_arity@ %t%a%t)%t@]@ \ @[(num_trailing_local_params@ %d)@]@ \ @@ -236,7 +248,8 @@ let [@ocamlformat "disable"] print ppf @[%t(is_tupled@ %b)%t@]@ \ @[(is_my_closure_used@ %b)@]@ \ %a\ - @[(inlining_decision@ %a)@]\ + @[(inlining_decision@ %a)@]@ \ + @[(loopify@ %a)@]\ )@]" (if Option.is_none newer_version_of then Flambda_colours.elide else Flambda_colours.none) @@ -254,6 +267,10 @@ let [@ocamlformat "disable"] print ppf then Flambda_colours.elide else C.none) Check_attribute.print check Flambda_colours.pop + (if Poll_attribute.is_default poll_attribute + then Flambda_colours.elide else C.none) + Poll_attribute.print poll_attribute + Flambda_colours.pop (if not is_a_functor then Flambda_colours.elide else C.none) is_a_functor Flambda_colours.pop @@ -296,6 +313,7 @@ let [@ocamlformat "disable"] print ppf is_my_closure_used print_inlining_paths (relative_history, absolute_history) Function_decl_inlining_decision_type.print inlining_decision + Loopify_attribute.print loopify let free_names { code_id = _; @@ -308,6 +326,7 @@ let free_names stub = _; inline = _; check = _; + poll_attribute = _; is_a_functor = _; recursive = _; cost_metrics = _; @@ -317,7 +336,8 @@ let free_names is_my_closure_used = _; inlining_decision = _; absolute_history = _; - relative_history = _ + relative_history = _; + loopify = _ } = (* [code_id] is only in [t.code_metadata] for the use of [compare]; it doesn't count as a free name. *) @@ -346,6 +366,7 @@ let apply_renaming stub = _; inline = _; check = _; + poll_attribute = _; is_a_functor = _; recursive = _; cost_metrics = _; @@ -355,7 +376,8 @@ let apply_renaming is_my_closure_used = _; inlining_decision = _; absolute_history = _; - relative_history = _ + relative_history = _; + loopify = _ } as t) renaming = (* inlined and modified version of Option.map to preserve sharing *) let newer_version_of' = @@ -395,6 +417,7 @@ let ids_for_export stub = _; inline = _; check = _; + poll_attribute = _; is_a_functor = _; recursive = _; cost_metrics = _; @@ -404,7 +427,8 @@ let ids_for_export is_my_closure_used = _; inlining_decision = _; absolute_history = _; - relative_history = _ + relative_history = _; + loopify = _ } = let ids = let newer_version_of_ids = @@ -430,6 +454,7 @@ let approx_equal stub = stub1; inline = inline1; check = check1; + poll_attribute = poll_attribute1; is_a_functor = is_a_functor1; recursive = recursive1; cost_metrics = cost_metrics1; @@ -439,7 +464,8 @@ let approx_equal is_my_closure_used = is_my_closure_used1; inlining_decision = inlining_decision1; absolute_history = absolute_history1; - relative_history = relative_history1 + relative_history = relative_history1; + loopify = loopify1 } { code_id = code_id2; newer_version_of = newer_version_of2; @@ -451,6 +477,7 @@ let approx_equal stub = stub2; inline = inline2; check = check2; + poll_attribute = poll_attribute2; is_a_functor = is_a_functor2; recursive = recursive2; cost_metrics = cost_metrics2; @@ -460,7 +487,8 @@ let approx_equal is_my_closure_used = is_my_closure_used2; inlining_decision = inlining_decision2; absolute_history = absolute_history2; - relative_history = relative_history2 + relative_history = relative_history2; + loopify = loopify2 } = Code_id.equal code_id1 code_id2 && (Option.equal Code_id.equal) newer_version_of1 newer_version_of2 @@ -472,6 +500,7 @@ let approx_equal && Bool.equal stub1 stub2 && Inline_attribute.equal inline1 inline2 && Check_attribute.equal check1 check2 + && Poll_attribute.equal poll_attribute1 poll_attribute2 && Bool.equal is_a_functor1 is_a_functor2 && Recursive.equal recursive1 recursive2 && Cost_metrics.equal cost_metrics1 cost_metrics2 @@ -483,6 +512,7 @@ let approx_equal inlining_decision2 && Inlining_history.Absolute.compare absolute_history1 absolute_history2 = 0 && Inlining_history.Relative.compare relative_history1 relative_history2 = 0 + && Loopify_attribute.equal loopify1 loopify2 let map_result_types ({ result_types; _ } as t) ~f = { t with diff --git a/middle_end/flambda2/terms/code_metadata.mli b/middle_end/flambda2/terms/code_metadata.mli index d9399951ab5..104614a39c0 100644 --- a/middle_end/flambda2/terms/code_metadata.mli +++ b/middle_end/flambda2/terms/code_metadata.mli @@ -47,6 +47,8 @@ module type Code_metadata_accessors_result_type = sig val check : 'a t -> Check_attribute.t + val poll_attribute : 'a t -> Poll_attribute.t + val is_a_functor : 'a t -> bool val recursive : 'a t -> Recursive.t @@ -68,6 +70,8 @@ module type Code_metadata_accessors_result_type = sig val absolute_history : 'a t -> Inlining_history.Absolute.t val relative_history : 'a t -> Inlining_history.Relative.t + + val loopify : 'a t -> Loopify_attribute.t end module Code_metadata_accessors : functor (X : Metadata_view_type) -> @@ -86,6 +90,7 @@ type 'a create_type = stub:bool -> inline:Inline_attribute.t -> check:Check_attribute.t -> + poll_attribute:Poll_attribute.t -> is_a_functor:bool -> recursive:Recursive.t -> cost_metrics:Cost_metrics.t -> @@ -96,6 +101,7 @@ type 'a create_type = inlining_decision:Function_decl_inlining_decision_type.t -> absolute_history:Inlining_history.Absolute.t -> relative_history:Inlining_history.Relative.t -> + loopify:Loopify_attribute.t -> 'a val createk : (t -> 'a) -> 'a create_type diff --git a/middle_end/flambda2/terms/code_or_metadata.ml b/middle_end/flambda2/terms/code_or_metadata.ml index b8a3bf6d6d7..aff789ca5fb 100644 --- a/middle_end/flambda2/terms/code_or_metadata.ml +++ b/middle_end/flambda2/terms/code_or_metadata.ml @@ -13,20 +13,115 @@ (* *) (**************************************************************************) +module File_sections = Flambda_backend_utils.File_sections + +type code_status = + | Loaded of Code.t + | Not_loaded of + { sections : File_sections.t; + index : int; + metadata : Code_metadata.t; + delayed_renaming : Renaming.t + } + type t = - | Code_present of Code.t + | Code_present of { mutable code_status : code_status } | Metadata_only of Code_metadata.t +type code_present = + | Present of { index : int } + | Absent + +type raw = + { metadata : Code_metadata.t; + code_present : code_present + } + +module View = struct + type t = + | Code_present of Code.t + | Metadata_only of Code_metadata.t +end + +let view t = + match t with + | Code_present { code_status = Loaded code } -> View.Code_present code + | Code_present ({ code_status = Not_loaded not_loaded } as c) -> + let params_and_body, free_names_of_params_and_body = + Obj.obj (File_sections.get not_loaded.sections not_loaded.index) + in + let params_and_body = + Flambda.Function_params_and_body.apply_renaming params_and_body + not_loaded.delayed_renaming + in + let free_names_of_params_and_body = + Name_occurrences.apply_renaming free_names_of_params_and_body + not_loaded.delayed_renaming + in + let code = + Code.create_with_metadata ~params_and_body ~free_names_of_params_and_body + ~code_metadata:not_loaded.metadata + in + c.code_status <- Loaded code; + View.Code_present code + | Metadata_only metadata -> View.Metadata_only metadata + +let get_code t = + match view t with + | Code_present code -> code + | Metadata_only metadata -> + Misc.fatal_errorf + "Code_or_metadata.get_code called but only metadata is available:@ %a" + Code_metadata.print metadata + let print ppf t = match t with - | Code_present code -> + | Code_present { code_status = Loaded code } -> Format.fprintf ppf "@[(Code_present@ (@[(code@ %a)@]))@]" Code.print code + | Code_present { code_status = Not_loaded not_loaded } -> + Format.fprintf ppf + "@[(Present@ (@[(code@ Not_loaded)@]@[(metadata@ \ + %a)@]))@]" + Code_metadata.print not_loaded.metadata | Metadata_only code_metadata -> Format.fprintf ppf "@[(Metadata_only@ (code_metadata@ %a))@]" Code_metadata.print code_metadata -let create code = Code_present code +let code_status_metadata = function + | Loaded code -> Code.code_metadata code + | Not_loaded not_loaded -> not_loaded.metadata + +let create code = Code_present { code_status = Loaded code } + +let from_raw ~sections raw = + match raw.code_present with + | Absent -> Metadata_only raw.metadata + | Present { index } -> + Code_present + { code_status = + Not_loaded + { sections; + index; + metadata = raw.metadata; + delayed_renaming = Renaming.empty + } + } + +let to_raw ~add_section t : raw = + match view t with + | Code_present code -> + { metadata = Code.code_metadata code; + code_present = + Present + { index = + add_section + (Obj.repr + ( Code.params_and_body code, + Code.free_names_of_params_and_body code )) + } + } + | Metadata_only metadata -> { metadata; code_present = Absent } let create_metadata_only metadata = Metadata_only metadata @@ -42,9 +137,9 @@ let merge code_id t1 t2 = | Code_present _, Code_present _ -> Misc.fatal_errorf "Cannot merge two definitions for code id %a" Code_id.print code_id - | Metadata_only cm_imported, (Code_present code_present as t) - | (Code_present code_present as t), Metadata_only cm_imported -> - let cm_present = Code.code_metadata code_present in + | Metadata_only cm_imported, (Code_present { code_status } as t) + | (Code_present { code_status } as t), Metadata_only cm_imported -> + let cm_present = code_status_metadata code_status in if Code_metadata.approx_equal cm_present cm_imported then Some t else @@ -55,42 +150,70 @@ let merge code_id t1 t2 = cm_imported let free_names t = - match t with + match view t with | Code_present code -> Code.free_names code | Metadata_only code_metadata -> Code_metadata.free_names code_metadata let apply_renaming t renaming = match t with - | Code_present code -> - let code' = Code.apply_renaming code renaming in - if code == code' then t else Code_present code' | Metadata_only code_metadata -> let code_metadata' = Code_metadata.apply_renaming code_metadata renaming in if code_metadata == code_metadata' then t else Metadata_only code_metadata' + | Code_present { code_status = Loaded code } -> + let code' = Code.apply_renaming code renaming in + if code == code' then t else Code_present { code_status = Loaded code' } + | Code_present { code_status = Not_loaded not_loaded } -> + let metadata' = Code_metadata.apply_renaming not_loaded.metadata renaming in + let delayed_renaming' = + Renaming.compose ~second:renaming ~first:not_loaded.delayed_renaming + in + if metadata' == not_loaded.metadata + && delayed_renaming' == not_loaded.delayed_renaming + then t + else + Code_present + { code_status = + Not_loaded + { not_loaded with + metadata = metadata'; + delayed_renaming = delayed_renaming' + } + } let ids_for_export t = - match t with + match view t with | Code_present code -> Code.ids_for_export code | Metadata_only code_metadata -> Code_metadata.ids_for_export code_metadata let remember_only_metadata t = match t with - | Code_present code -> Metadata_only (Code.code_metadata code) + | Code_present { code_status } -> + Metadata_only (code_status_metadata code_status) | Metadata_only _ -> t let code_metadata t = match t with - | Code_present code -> Code.code_metadata code + | Code_present { code_status } -> code_status_metadata code_status | Metadata_only code_metadata -> code_metadata let iter_code t ~f = - match t with Code_present code -> f code | Metadata_only _ -> () + match view t with Code_present code -> f code | Metadata_only _ -> () let map_result_types t ~f = - match t with - | Code_present code -> Code_present (Code.map_result_types code ~f) + (* CR ncourant: we could probably do this without loading the code if it is + not needed, but it doesn't seem necessary as this function seems to only be + called before output *) + match view t with + | Code_present code -> + Code_present { code_status = Loaded (Code.map_result_types code ~f) } | Metadata_only code_metadata -> Metadata_only (Code_metadata.map_result_types code_metadata ~f) let code_present t = match t with Code_present _ -> true | Metadata_only _ -> false + +let map_raw_index map_index t = + match t.code_present with + | Absent -> t + | Present { index } -> + { t with code_present = Present { index = map_index index } } diff --git a/middle_end/flambda2/terms/code_or_metadata.mli b/middle_end/flambda2/terms/code_or_metadata.mli index 89c860ae995..9bbb39ca35c 100644 --- a/middle_end/flambda2/terms/code_or_metadata.mli +++ b/middle_end/flambda2/terms/code_or_metadata.mli @@ -13,9 +13,20 @@ (* *) (**************************************************************************) -type t = private - | Code_present of Code.t - | Metadata_only of Code_metadata.t +type t + +type raw + +module View : sig + type t = private + | Code_present of Code.t + | Metadata_only of Code_metadata.t +end + +val view : t -> View.t + +(** Will return the code or cause a fatal error. *) +val get_code : t -> Code.t val print : Format.formatter -> t -> unit @@ -25,6 +36,10 @@ val create : Code.t -> t val create_metadata_only : Code_metadata.t -> t +val from_raw : sections:Flambda_backend_utils.File_sections.t -> raw -> t + +val to_raw : add_section:(Obj.t -> int) -> t -> raw + val remember_only_metadata : t -> t val iter_code : t -> f:(Code.t -> unit) -> unit @@ -35,6 +50,8 @@ val code_metadata : t -> Code_metadata.t val code_present : t -> bool +val map_raw_index : (int -> int) -> raw -> raw + (** As for [Code_metadata], the free names of a value of type [t] do not include the code ID, which is only kept for convenience. *) include Contains_names.S with type t := t diff --git a/middle_end/flambda2/terms/code_size.ml b/middle_end/flambda2/terms/code_size.ml index 9fc7648c73b..7a894b2054b 100644 --- a/middle_end/flambda2/terms/code_size.ml +++ b/middle_end/flambda2/terms/code_size.ml @@ -304,6 +304,8 @@ let binary_float_comp_primitive _op = 2 let nullary_prim_size prim = match (prim : Flambda_primitive.nullary_primitive) with + (* CR gbury: check this *) + | Invalid _ -> 0 | Optimised_out _ -> 0 | Probe_is_enabled { name = _ } -> 4 | Begin_region -> 1 @@ -331,6 +333,7 @@ let unary_prim_size prim = | Project_value_slot _ -> 1 (* load *) | Is_boxed_float -> 4 (* tag load + comparison *) | Is_flat_float_array -> 4 (* tag load + comparison *) + | Begin_try_region -> 1 | End_region -> 1 | Obj_dup -> alloc_extcall_size + 1 diff --git a/middle_end/flambda2/terms/coeffects.ml b/middle_end/flambda2/terms/coeffects.ml index 9cbbdeb9435..885291db8b3 100644 --- a/middle_end/flambda2/terms/coeffects.ml +++ b/middle_end/flambda2/terms/coeffects.ml @@ -22,8 +22,8 @@ type t = let [@ocamlformat "disable"] print ppf co = match co with - | No_coeffects -> Format.fprintf ppf "no coeffects" - | Has_coeffects -> Format.fprintf ppf "has coeffects" + | No_coeffects -> Format.fprintf ppf "No_coeffects" + | Has_coeffects -> Format.fprintf ppf "Has_coeffects" let compare co1 co2 = match co1, co2 with diff --git a/middle_end/flambda2/terms/dune b/middle_end/flambda2/terms/dune index 3555fb90371..a2f31461948 100644 --- a/middle_end/flambda2/terms/dune +++ b/middle_end/flambda2/terms/dune @@ -31,6 +31,7 @@ (:standard -O3)) (libraries ocamlcommon + flambda_backend_utils flambda2_algorithms flambda2_bound_identifiers flambda2_identifiers diff --git a/middle_end/flambda2/terms/effects.ml b/middle_end/flambda2/terms/effects.ml index c157104993e..07d288ef9de 100644 --- a/middle_end/flambda2/terms/effects.ml +++ b/middle_end/flambda2/terms/effects.ml @@ -24,12 +24,12 @@ type t = let [@ocamlformat "disable"] print ppf eff = match eff with | No_effects -> - Format.fprintf ppf "no effects" + Format.fprintf ppf "No_effects" | Only_generative_effects mut -> - Format.fprintf ppf "only generative effects %a" + Format.fprintf ppf "Only_generative_effects(%a)" Mutability.print mut | Arbitrary_effects -> - Format.fprintf ppf "Arbitrary effects" + Format.fprintf ppf "Arbitrary_effects" let compare eff1 eff2 = match eff1, eff2 with diff --git a/middle_end/flambda2/terms/effects_and_coeffects.ml b/middle_end/flambda2/terms/effects_and_coeffects.ml index fb6b5f5d77e..ce56cb0b055 100644 --- a/middle_end/flambda2/terms/effects_and_coeffects.ml +++ b/middle_end/flambda2/terms/effects_and_coeffects.ml @@ -12,21 +12,29 @@ (* *) (**************************************************************************) -type t = Effects.t * Coeffects.t +type t = Effects.t * Coeffects.t * Placement.t -let [@ocamlformat "disable"] print fmt (eff, coeff) = - Format.fprintf fmt "%a * %a" Effects.print eff Coeffects.print coeff +let print fmt (eff, coeff, dup) = + Format.fprintf fmt "%a * %a * %a" Effects.print eff Coeffects.print coeff + Placement.print dup -let compare (e1, c1) (e2, c2) = - match Effects.compare e1 e2 with 0 -> Coeffects.compare c1 c2 | res -> res +let compare (e1, c1, d1) (e2, c2, d2) = + match Effects.compare e1 e2 with + | 0 -> ( + match Coeffects.compare c1 c2 with + | 0 -> Placement.compare d1 d2 + | res -> res) + | res -> res (* Some useful constants *) -let pure : t = No_effects, No_coeffects +let pure : t = No_effects, No_coeffects, Strict -let all : t = Arbitrary_effects, Has_coeffects +let pure_can_be_duplicated : t = No_effects, No_coeffects, Delay -let read : t = No_effects, Has_coeffects +let all : t = Arbitrary_effects, Has_coeffects, Strict -(* Joining effects and coeffects *) -let join (eff1, coeff1) (eff2, coeff2) = - Effects.join eff1 eff2, Coeffects.join coeff1 coeff2 +let read : t = No_effects, Has_coeffects, Strict + +(* Joining effects, coeffects and placement *) +let join (eff1, coeff1, dup1) (eff2, coeff2, dup2) = + Effects.join eff1 eff2, Coeffects.join coeff1 coeff2, Placement.join dup1 dup2 diff --git a/middle_end/flambda2/terms/effects_and_coeffects.mli b/middle_end/flambda2/terms/effects_and_coeffects.mli index 8089102829e..787c6b7bb79 100644 --- a/middle_end/flambda2/terms/effects_and_coeffects.mli +++ b/middle_end/flambda2/terms/effects_and_coeffects.mli @@ -12,10 +12,10 @@ (* *) (**************************************************************************) -(* Effects and coeffects *) +(* Effects, coeffects and placements *) -(** A pair of an effect and a coeffect. *) -type t = Effects.t * Coeffects.t +(** A triple of an effect, a coeffect, and a placement. *) +type t = Effects.t * Coeffects.t * Placement.t (** Print *) val print : Format.formatter -> t -> unit @@ -23,17 +23,23 @@ val print : Format.formatter -> t -> unit (** Comparison. *) val compare : t -> t -> int -(** The value stating that no effects of coeffects take place. This is exactly - [No_effects, No_coeffects]. *) +(** The value stating that no effects or coeffects take place, with a strict + placement. This is exactly [No_effects, No_coeffects, Strict]. *) val pure : t -(** The value stating that any effects and/or coeffects may take place. This is - exactly [Arbitrary_effects, Has_coeffects]. *) +(** The value stating that no effects of coeffects take place, and that the + expression can be moved and duplicated if needed. This is exactly + [No_effects, No_coeffects, Delay]. *) +val pure_can_be_duplicated : t + +(** The value stating that any effects and/or coeffects may take place (with + strict placement). This is exactly [Arbitrary_effects, Has_coeffects, + Strict]. *) val all : t -(** The value stating that a read (i.e only a coeffect) takes place. This is - [No_effects, Has_coeffects]. *) +(** The value stating that a read (i.e only a coeffect) takes place (with strict + placement). This is [No_effects, Has_coeffects, Strict]. *) val read : t -(** Join two effects and coeffects. *) +(** Join two effects, coeffects and placements. *) val join : t -> t -> t diff --git a/middle_end/flambda2/terms/flambda.ml b/middle_end/flambda2/terms/flambda.ml index 54f73989bfa..2bc31aa1ed2 100644 --- a/middle_end/flambda2/terms/flambda.ml +++ b/middle_end/flambda2/terms/flambda.ml @@ -910,6 +910,10 @@ module Continuation_handler = struct Error Pattern_match_pair_error.Parameter_lists_have_different_lengths)) + let print ~cont ~recursive ppf ch : unit = + print_continuation_handler ~first:true recursive ppf cont ch + Or_unknown.Unknown + let is_exn_handler t = t.is_exn_handler let apply_renaming = apply_renaming_continuation_handler diff --git a/middle_end/flambda2/terms/flambda.mli b/middle_end/flambda2/terms/flambda.mli index 9c6c0eb8667..3076caab9c2 100644 --- a/middle_end/flambda2/terms/flambda.mli +++ b/middle_end/flambda2/terms/flambda.mli @@ -14,47 +14,58 @@ (* *) (**************************************************************************) -(** The grammar of the Flambda 2 term language, represented up to - alpha-conversion of bound variables and continuations. +(** The grammar of the Flambda 2 term language. - The basic structure of the language ensures that: - every intermediate value - (and in particular every potential constant that we may want to lift) has a - name; + The language is in double-barrelled continuation-passing style (CPS). + Continuations, used for normal and exceptional control flow, are second + class. Unlike some CPS-based representations there is a conventional + "let"-binding construct; this is structured in A-normal form (ANF). Terms + are represented up to alpha-conversion of bound variables and continuations. + + The basic structure of the language ensures that: + + - every intermediate value (and in particular every potential value that we + may want to statically allocate) has a name; - every point to which we might wish to jump has a name; - there are no nested "let"s or subexpressions; - no re-normalisation of terms is required when substituting an application - for an inlined body (unlike in ANF form). *) - -module Apply = Apply_expr -module Apply_cont = Apply_cont_expr -module Switch = Switch_expr + for an inlined body (unlike in conventional ANF forms). *) (** Modules may be found further down the file giving operations on the abstract - types that follow. *) + types that follow. The types for some parts of terms (e.g. Apply_expr) are + defined in their own files. *) type expr -and expr_descr = private +type let_expr + +type non_recursive_let_cont_handler + +type recursive_let_cont_handlers + +type function_params_and_body + +type static_const_group + +type expr_descr = private | Let of let_expr - (** Bind variable(s) or symbol(s). There can be no effect on control flow - (save for asynchronous operations such as the invocation of finalisers - or signal handlers as a result of reaching a safe point). *) + (** Bind variable(s), symbol(s) and/or code ID(s). The defining expression + (the part after the "=", as in "let x = defining_expr in body") + never has any effect on control flow. *) | Let_cont of let_cont_expr (** Define one or more continuations. *) - | Apply of Apply.t + | Apply of Apply_expr.t (** Call an OCaml function, external function or method. *) - | Apply_cont of Apply_cont.t + | Apply_cont of Apply_cont_expr.t (** Call a continuation, optionally adding or removing exception trap frames from the stack, which thus allows for the raising of exceptions. *) - | Switch of Switch.t (** Conditional control flow. *) + | Switch of Switch_expr.t (** Conditional control flow. *) | Invalid of { message : string } (** Code proved type-incorrect and therefore unreachable. *) -and let_expr - (** The defining expressions of [Let]-bindings. *) and named = private | Simple of Simple.t @@ -84,30 +95,22 @@ and let_cont_expr = private } | Recursive of recursive_let_cont_handlers -and non_recursive_let_cont_handler - -and recursive_let_cont_handlers - -and function_params_and_body - and static_const_or_code = private | Code of function_params_and_body Code0.t | Deleted_code | Static_const of Static_const.t -and static_const_group - module Invalid : sig type t = | Body_of_unreachable_continuation of Continuation.t | Apply_cont_of_unreachable_continuation of Continuation.t | Defining_expr_of_let of Bound_pattern.t * named - | Closure_type_was_invalid of Apply.t + | Closure_type_was_invalid of Apply_expr.t | Zero_switch_arms | Code_not_rebuilt | To_cmm_dummy_body - | Application_never_returns of Apply.t - | Over_application_never_returns of Apply.t + | Application_never_returns of Apply_expr.t + | Over_application_never_returns of Apply_expr.t | Message of string end @@ -128,10 +131,10 @@ module Expr : sig val create_let : let_expr -> t (** Create an application expression. *) - val create_apply : Apply.t -> t + val create_apply : Apply_expr.t -> t (** Create a continuation application (in the zero-arity case, "goto"). *) - val create_apply_cont : Apply_cont.t -> t + val create_apply_cont : Apply_cont_expr.t -> t val create_switch : Switch_expr.t -> t @@ -189,8 +192,14 @@ end module Let_expr : sig (** The alpha-equivalence classes of expressions that bind variables; and the - expressions that bind symbols (which are not treated up to alpha - equivalence). *) + expressions that bind symbols and code IDs (which are not treated up to + alpha equivalence). + + Variables have normal syntactic scoping. Symbols and code IDs are + treated as in scope in all parts of the term dominated by the + corresponding [Let]-binding. + *) + type t = let_expr include Expr_std.S_no_free_names with type t := t @@ -249,6 +258,13 @@ module Continuation_handler : sig information about such handler. *) type t + val print : + cont:Continuation.t -> + recursive:Recursive.t -> + Format.formatter -> + t -> + unit + val apply_renaming : t -> Renaming.t -> t (** Create the representation of a single continuation handler. *) @@ -327,6 +343,9 @@ module Let_cont_expr : sig [body] where [name] [args] = [handler] + (In the -drawflambda / -dflambda output, "where" is omitted, in + favour of a simple label syntax e.g. "k42:") + - Continuations are second-class. - Continuations do not capture variables. @@ -567,10 +586,13 @@ module Static_const_group : sig val is_fully_static : t -> bool end +module Apply = Apply_expr +module Apply_cont = Apply_cont_expr module Function_declarations = Function_declarations module Let = Let_expr module Let_cont = Let_cont_expr module Set_of_closures = Set_of_closures +module Switch = Switch_expr (** The idea is that you should typically do "open! Flambda" at the top of files, thus bringing in the following standard set of module aliases. *) diff --git a/middle_end/flambda2/terms/flambda_primitive.ml b/middle_end/flambda2/terms/flambda_primitive.ml index d32c729d47f..e3c65354a0a 100644 --- a/middle_end/flambda2/terms/flambda_primitive.ml +++ b/middle_end/flambda2/terms/flambda_primitive.ml @@ -282,7 +282,7 @@ let reading_from_a_block mutable_or_immutable = | Immutable | Immutable_unique -> Coeffects.No_coeffects | Mutable -> Coeffects.Has_coeffects in - effects, coeffects + effects, coeffects, Placement.Strict let reading_from_an_array (array_kind : Array_kind.t) (mutable_or_immutable : Mutability.t) = @@ -294,14 +294,14 @@ let reading_from_an_array (array_kind : Array_kind.t) | Immutable | Immutable_unique -> Coeffects.No_coeffects | Mutable -> Coeffects.Has_coeffects in - effects, coeffects + effects, coeffects, Placement.Strict let reading_from_a_string_or_bigstring mutable_or_immutable = reading_from_a_block mutable_or_immutable let writing_to_a_block = let effects = effects_of_operation Writing in - effects, Coeffects.No_coeffects + effects, Coeffects.No_coeffects, Placement.Strict let writing_to_an_array = writing_to_a_block @@ -470,10 +470,12 @@ end let reading_from_a_bigarray kind = match (kind : Bigarray_kind.t) with | Complex32 | Complex64 -> - Effects.Only_generative_effects Immutable, Coeffects.Has_coeffects + ( Effects.Only_generative_effects Immutable, + Coeffects.Has_coeffects, + Placement.Strict ) | Float32 | Float64 | Sint8 | Uint8 | Sint16 | Uint16 | Int32 | Int64 | Int_width_int | Targetint_width_int -> - Effects.No_effects, Coeffects.Has_coeffects + Effects.No_effects, Coeffects.Has_coeffects, Placement.Strict (* The bound checks are taken care of outside the array primitive (using an explicit test and switch in the flambda code, see @@ -486,7 +488,7 @@ let writing_to_a_bigarray kind = (* Technically, the write of a complex generates read of fields from the given complex, but since those reads are immutable, there is no observable coeffect. *) -> - Effects.Arbitrary_effects, Coeffects.No_coeffects + Effects.Arbitrary_effects, Coeffects.No_coeffects, Placement.Strict let bigarray_index_kind = K.value @@ -568,28 +570,35 @@ type result_kind = | Unit type nullary_primitive = + | Invalid of K.t | Optimised_out of K.t | Probe_is_enabled of { name : string } | Begin_region let nullary_primitive_eligible_for_cse = function - | Optimised_out _ | Probe_is_enabled _ | Begin_region -> false + | Invalid _ | Optimised_out _ | Probe_is_enabled _ | Begin_region -> false let compare_nullary_primitive p1 p2 = match p1, p2 with + | Invalid k1, Invalid k2 -> K.compare k1 k2 | Optimised_out k1, Optimised_out k2 -> K.compare k1 k2 | Probe_is_enabled { name = name1 }, Probe_is_enabled { name = name2 } -> String.compare name1 name2 | Begin_region, Begin_region -> 0 + | Invalid _, (Optimised_out _ | Probe_is_enabled _ | Begin_region) -> -1 | Optimised_out _, (Probe_is_enabled _ | Begin_region) -> -1 + | Optimised_out _, Invalid _ -> 1 | Probe_is_enabled _, Begin_region -> -1 - | Probe_is_enabled _, Optimised_out _ -> 1 - | Begin_region, (Optimised_out _ | Probe_is_enabled _) -> 1 + | Probe_is_enabled _, (Invalid _ | Optimised_out _) -> 1 + | Begin_region, (Invalid _ | Optimised_out _ | Probe_is_enabled _) -> 1 let equal_nullary_primitive p1 p2 = compare_nullary_primitive p1 p2 = 0 let print_nullary_primitive ppf p = match p with + | Invalid _ -> + Format.fprintf ppf "%tInvalid%t" Flambda_colours.invalid_keyword + Flambda_colours.pop | Optimised_out _ -> Format.fprintf ppf "%tOptimised_out%t" Flambda_colours.elide Flambda_colours.pop @@ -599,23 +608,28 @@ let print_nullary_primitive ppf p = let result_kind_of_nullary_primitive p : result_kind = match p with + | Invalid k -> Singleton k | Optimised_out k -> Singleton k | Probe_is_enabled _ -> Singleton K.naked_immediate | Begin_region -> Singleton K.region -let effects_and_coeffects_of_nullary_primitive p = +let effects_and_coeffects_of_begin_region : Effects_and_coeffects.t = + (* Ensure these don't get moved, but allow them to be deleted. *) + Only_generative_effects Mutable, Has_coeffects, Strict + +let effects_and_coeffects_of_nullary_primitive p : Effects_and_coeffects.t = match p with - | Optimised_out _ -> Effects.No_effects, Coeffects.No_coeffects + | Invalid _ -> Arbitrary_effects, Has_coeffects, Strict + | Optimised_out _ -> No_effects, No_coeffects, Strict | Probe_is_enabled _ -> (* This doesn't really have effects, but we want to make sure it never gets moved around. *) - Effects.Arbitrary_effects, Coeffects.Has_coeffects - | Begin_region -> - (* Ensure these don't get moved, but allow them to be deleted. *) - Effects.Only_generative_effects Mutable, Coeffects.Has_coeffects + Arbitrary_effects, Has_coeffects, Strict + | Begin_region -> effects_and_coeffects_of_begin_region let nullary_classify_for_printing p = - match p with Optimised_out _ | Probe_is_enabled _ | Begin_region -> Neither + match p with + | Invalid _ | Optimised_out _ | Probe_is_enabled _ | Begin_region -> Neither type unary_primitive = | Duplicate_block of { kind : Duplicate_block_kind.t } @@ -649,10 +663,12 @@ type unary_primitive = } | Project_value_slot of { project_from : Function_slot.t; - value_slot : Value_slot.t + value_slot : Value_slot.t; + kind : Flambda_kind.With_subkind.t } | Is_boxed_float | Is_flat_float_array + | Begin_try_region | End_region | Obj_dup @@ -685,7 +701,7 @@ let unary_primitive_eligible_for_cse p ~arg = Simple.is_var arg | Project_function_slot _ | Project_value_slot _ -> false | Is_boxed_float | Is_flat_float_array -> true - | End_region | Obj_dup -> false + | Begin_try_region | End_region | Obj_dup -> false let compare_unary_primitive p1 p2 = let unary_primitive_numbering p = @@ -712,8 +728,9 @@ let compare_unary_primitive p1 p2 = | Project_value_slot _ -> 19 | Is_boxed_float -> 20 | Is_flat_float_array -> 21 - | End_region -> 22 - | Obj_dup -> 23 + | Begin_try_region -> 22 + | End_region -> 23 + | Obj_dup -> 24 in match p1, p2 with | ( Duplicate_array @@ -766,11 +783,21 @@ let compare_unary_primitive p1 p2 = let c = Function_slot.compare move_from1 move_from2 in if c <> 0 then c else Function_slot.compare move_to1 move_to2 | ( Project_value_slot - { project_from = function_slot1; value_slot = value_slot1 }, + { project_from = function_slot1; + value_slot = value_slot1; + kind = kind1 + }, Project_value_slot - { project_from = function_slot2; value_slot = value_slot2 } ) -> + { project_from = function_slot2; + value_slot = value_slot2; + kind = kind2 + } ) -> let c = Function_slot.compare function_slot1 function_slot2 in - if c <> 0 then c else Value_slot.compare value_slot1 value_slot2 + if c <> 0 + then c + else + let c = Value_slot.compare value_slot1 value_slot2 in + if c <> 0 then c else K.With_subkind.compare kind1 kind2 | ( Opaque_identity { middle_end_only = middle_end_only1 }, Opaque_identity { middle_end_only = middle_end_only2 } ) -> Bool.compare middle_end_only1 middle_end_only2 @@ -779,8 +806,8 @@ let compare_unary_primitive p1 p2 = | Num_conv _ | Boolean_not | Reinterpret_int64_as_float | Float_arith _ | Array_length | Bigarray_length _ | Unbox_number _ | Box_number _ | Untag_immediate | Tag_immediate | Project_function_slot _ - | Project_value_slot _ | Is_boxed_float | Is_flat_float_array | End_region - | Obj_dup ), + | Project_value_slot _ | Is_boxed_float | Is_flat_float_array + | Begin_try_region | End_region | Obj_dup ), _ ) -> Stdlib.compare (unary_primitive_numbering p1) (unary_primitive_numbering p2) @@ -824,11 +851,13 @@ let print_unary_primitive ppf p = | Project_function_slot { move_from; move_to } -> Format.fprintf ppf "@[(Project_function_slot@ (%a \u{2192} %a))@]" Function_slot.print move_from Function_slot.print move_to - | Project_value_slot { project_from; value_slot } -> - Format.fprintf ppf "@[(Project_value_slot@ (%a@ %a))@]" Function_slot.print - project_from Value_slot.print value_slot + | Project_value_slot { project_from; value_slot; kind } -> + Format.fprintf ppf "@[(Project_value_slot@ (%a@ %a@ %a))@]" + Function_slot.print project_from Value_slot.print value_slot + K.With_subkind.print kind | Is_boxed_float -> fprintf ppf "Is_boxed_float" | Is_flat_float_array -> fprintf ppf "Is_flat_float_array" + | Begin_try_region -> Format.pp_print_string ppf "Begin_try_region" | End_region -> Format.pp_print_string ppf "End_region" | Obj_dup -> Format.pp_print_string ppf "Obj_dup" @@ -852,6 +881,7 @@ let arg_kind_of_unary_primitive p = | Project_function_slot _ | Project_value_slot _ | Is_boxed_float | Is_flat_float_array -> K.value + | Begin_try_region -> K.region | End_region -> K.region | Obj_dup -> K.value @@ -878,18 +908,18 @@ let result_kind_of_unary_primitive p : result_kind = | Project_value_slot _ -> Singleton K.value | Is_boxed_float | Is_flat_float_array -> Singleton K.naked_immediate + | Begin_try_region -> Singleton K.region | End_region -> Singleton K.value | Obj_dup -> Singleton K.value -let effects_and_coeffects_of_unary_primitive p = +let effects_and_coeffects_of_unary_primitive p : Effects_and_coeffects.t = match p with | Duplicate_array { kind = _; source_mutability; destination_mutability; _ } -> ( match source_mutability with | Immutable -> (* [Obj.truncate] has now been removed. *) - ( Effects.Only_generative_effects destination_mutability, - Coeffects.No_coeffects ) + Only_generative_effects destination_mutability, No_coeffects, Strict | Immutable_unique -> (* CR vlaviron: this should never occur, but it's hard to express it without duplicating the mutability type @@ -897,25 +927,23 @@ let effects_and_coeffects_of_unary_primitive p = mshinwell: Adding a second mutability type seems like a good thing to avoid confusion in the future. It could maybe be a submodule of [Mutability]. *) - ( Effects.Only_generative_effects destination_mutability, - Coeffects.No_coeffects ) + Only_generative_effects destination_mutability, No_coeffects, Strict | Mutable -> - ( Effects.Only_generative_effects destination_mutability, - Coeffects.Has_coeffects )) + Only_generative_effects destination_mutability, Has_coeffects, Strict) | Duplicate_block { kind = _ } -> (* We have to assume that the fields might be mutable. (This information isn't currently propagated from [Lambda].) *) - Effects.Only_generative_effects Mutable, Coeffects.Has_coeffects - | Is_int _ -> Effects.No_effects, Coeffects.No_coeffects + Only_generative_effects Mutable, Has_coeffects, Strict + | Is_int _ -> No_effects, No_coeffects, Strict | Get_tag -> (* [Obj.truncate] has now been removed. *) - Effects.No_effects, Coeffects.No_coeffects - | String_length _ -> Effects.No_effects, Coeffects.No_coeffects - | Int_as_pointer -> Effects.No_effects, Coeffects.No_coeffects - | Opaque_identity _ -> Effects.Arbitrary_effects, Coeffects.Has_coeffects + No_effects, No_coeffects, Strict + | String_length _ -> No_effects, No_coeffects, Strict + | Int_as_pointer -> No_effects, No_coeffects, Strict + | Opaque_identity _ -> Arbitrary_effects, Has_coeffects, Strict | Int_arith (_, (Neg | Swap_byte_endianness)) | Num_conv _ | Boolean_not | Reinterpret_int64_as_float -> - Effects.No_effects, Coeffects.No_coeffects + No_effects, No_coeffects, Strict | Float_arith (Abs | Neg) -> (* Float operations are not really pure since they actually access the globally mutable rounding mode, which can be changed (but only from C @@ -928,41 +956,50 @@ let effects_and_coeffects_of_unary_primitive p = (e.g. a call to a c stub that changes the rounding mode). See also the comment in binary_primitive_eligible_for_cse. *) if Flambda_features.float_const_prop () - then Effects.No_effects, Coeffects.No_coeffects - else Effects.No_effects, Coeffects.Has_coeffects + then No_effects, No_coeffects, Strict + else No_effects, Has_coeffects, Strict (* Since Obj.truncate has been deprecated, array_length should have no observable effect *) - | Array_length -> Effects.No_effects, Coeffects.No_coeffects + | Array_length -> No_effects, No_coeffects, Strict | Bigarray_length { dimension = _ } -> (* This is pretty much a direct access to a field of the bigarray, different from reading one of the values actually stored inside the array, hence [reading_from_a_block] (i.e. this has the same behaviour as a regular Block_load). *) reading_from_a_block Mutable - | Unbox_number _ | Untag_immediate -> - Effects.No_effects, Coeffects.No_coeffects - | Tag_immediate -> Effects.No_effects, Coeffects.No_coeffects + | Unbox_number _ | Untag_immediate -> No_effects, No_coeffects, Strict + | Tag_immediate -> No_effects, No_coeffects, Strict | Box_number (_, alloc_mode) -> + (* Ensure boxing operations for numbers are inlined/substituted in to_cmm *) + let placement : Placement.t = + if Flambda_features.classic_mode () + then + (* Local allocations have coeffects, to avoid them being moved past a + begin/end region. Hence, it is not safe to force the allocation to be + moved, so we cannot use the `Delay` mode for those. *) + match alloc_mode with Heap -> Delay | Local _ -> Strict + else Strict + in let coeffects : Coeffects.t = - match alloc_mode with - | Heap -> Coeffects.No_coeffects - | Local _ -> Coeffects.Has_coeffects + match alloc_mode with Heap -> No_coeffects | Local _ -> Has_coeffects in - Effects.Only_generative_effects Immutable, coeffects + Only_generative_effects Immutable, coeffects, placement | Project_function_slot _ | Project_value_slot _ -> - Effects.No_effects, Coeffects.No_coeffects + No_effects, No_coeffects, Delay | Is_boxed_float | Is_flat_float_array -> (* Tags on heap blocks are immutable. *) - Effects.No_effects, Coeffects.No_coeffects + No_effects, No_coeffects, Strict + | Begin_try_region -> effects_and_coeffects_of_begin_region | End_region -> (* These can't be [Only_generative_effects] or the primitives would get deleted without regard to prior uses of the region. Instead there are special cases in [Simplify_let_expr] and [Expr_builder] for this primitive. *) - Effects.Arbitrary_effects, Coeffects.Has_coeffects + Arbitrary_effects, Has_coeffects, Strict | Obj_dup -> - ( Effects.Only_generative_effects Mutable (* Mutable is conservative *), - Coeffects.Has_coeffects ) + ( Only_generative_effects Mutable (* Mutable is conservative *), + Has_coeffects, + Strict ) let unary_classify_for_printing p = match p with @@ -976,7 +1013,7 @@ let unary_classify_for_printing p = | Box_number _ | Tag_immediate -> Constructive | Project_function_slot _ | Project_value_slot _ -> Destructive | Is_boxed_float | Is_flat_float_array -> Neither - | End_region -> Neither + | Begin_try_region | End_region -> Neither let free_names_unary_primitive p = match p with @@ -987,7 +1024,7 @@ let free_names_unary_primitive p = (Name_occurrences.add_function_slot_in_projection Name_occurrences.empty move_to Name_mode.normal) move_from Name_mode.normal - | Project_value_slot { value_slot; project_from } -> + | Project_value_slot { value_slot; project_from; kind = _ } -> Name_occurrences.add_function_slot_in_projection (Name_occurrences.add_value_slot_in_projection Name_occurrences.empty value_slot Name_mode.normal) @@ -996,7 +1033,8 @@ let free_names_unary_primitive p = | Int_as_pointer | Opaque_identity _ | Int_arith _ | Num_conv _ | Boolean_not | Reinterpret_int64_as_float | Float_arith _ | Array_length | Bigarray_length _ | Unbox_number _ | Untag_immediate | Tag_immediate - | Is_boxed_float | Is_flat_float_array | End_region | Obj_dup -> + | Is_boxed_float | Is_flat_float_array | Begin_try_region | End_region + | Obj_dup -> Name_occurrences.empty let apply_renaming_unary_primitive p renaming = @@ -1010,8 +1048,8 @@ let apply_renaming_unary_primitive p renaming = | Int_as_pointer | Opaque_identity _ | Int_arith _ | Num_conv _ | Boolean_not | Reinterpret_int64_as_float | Float_arith _ | Array_length | Bigarray_length _ | Unbox_number _ | Untag_immediate | Tag_immediate - | Is_boxed_float | Is_flat_float_array | End_region | Project_function_slot _ - | Project_value_slot _ | Obj_dup -> + | Is_boxed_float | Is_flat_float_array | Begin_try_region | End_region + | Project_function_slot _ | Project_value_slot _ | Obj_dup -> p let ids_for_export_unary_primitive p = @@ -1022,8 +1060,8 @@ let ids_for_export_unary_primitive p = | Int_as_pointer | Opaque_identity _ | Int_arith _ | Num_conv _ | Boolean_not | Reinterpret_int64_as_float | Float_arith _ | Array_length | Bigarray_length _ | Unbox_number _ | Untag_immediate | Tag_immediate - | Is_boxed_float | Is_flat_float_array | End_region | Project_function_slot _ - | Project_value_slot _ | Obj_dup -> + | Is_boxed_float | Is_flat_float_array | Begin_try_region | End_region + | Project_function_slot _ | Project_value_slot _ | Obj_dup -> Ids_for_export.empty type binary_int_arith_op = @@ -1219,7 +1257,7 @@ let result_kind_of_binary_primitive p : result_kind = | Float_arith _ -> Singleton K.naked_float | Phys_equal _ | Int_comp _ | Float_comp _ -> Singleton K.naked_immediate -let effects_and_coeffects_of_binary_primitive p = +let effects_and_coeffects_of_binary_primitive p : Effects_and_coeffects.t = match p with | Block_load (_, mut) -> reading_from_a_block mut | Array_load (kind, mut) -> reading_from_an_array kind mut @@ -1228,21 +1266,21 @@ let effects_and_coeffects_of_binary_primitive p = reading_from_a_string_or_bigstring Immutable | String_or_bigstring_load ((Bytes | Bigstring), _) -> reading_from_a_string_or_bigstring Mutable - | Phys_equal _ -> Effects.No_effects, Coeffects.No_coeffects + | Phys_equal _ -> No_effects, No_coeffects, Strict | Int_arith (_kind, (Add | Sub | Mul | Div | Mod | And | Or | Xor)) -> - Effects.No_effects, Coeffects.No_coeffects - | Int_shift _ -> Effects.No_effects, Coeffects.No_coeffects - | Int_comp _ -> Effects.No_effects, Coeffects.No_coeffects + No_effects, No_coeffects, Strict + | Int_shift _ -> No_effects, No_coeffects, Strict + | Int_comp _ -> No_effects, No_coeffects, Strict | Float_arith (Add | Sub | Mul | Div) -> (* See comments for Unary Float_arith *) if Flambda_features.float_const_prop () - then Effects.No_effects, Coeffects.No_coeffects - else Effects.No_effects, Coeffects.Has_coeffects + then No_effects, No_coeffects, Strict + else No_effects, Has_coeffects, Strict | Float_comp _ -> (* See comments for Unary Float_arith *) if Flambda_features.float_const_prop () - then Effects.No_effects, Coeffects.No_coeffects - else Effects.No_effects, Coeffects.Has_coeffects + then No_effects, No_coeffects, Strict + else No_effects, Has_coeffects, Strict let binary_classify_for_printing p = match p with @@ -1471,7 +1509,7 @@ let args_kind_of_variadic_primitive p : arg_kinds = let result_kind_of_variadic_primitive p : result_kind = match p with Make_block _ | Make_array _ -> Singleton K.value -let effects_and_coeffects_of_variadic_primitive p ~args = +let effects_and_coeffects_of_variadic_primitive p = match p with | Make_block (_, mut, alloc_mode) | Make_array (_, mut, alloc_mode) -> let coeffects : Coeffects.t = @@ -1479,13 +1517,7 @@ let effects_and_coeffects_of_variadic_primitive p ~args = | Heap -> Coeffects.No_coeffects | Local _ -> Coeffects.Has_coeffects in - if List.length args >= 1 - then Effects.Only_generative_effects mut, coeffects - else - (* Zero-sized blocks and arrays are immutable and statically allocated, - However, we currently only lift primitives that have *exactly* - generative effects. *) - Effects.Only_generative_effects Immutable, coeffects + Effects.Only_generative_effects mut, coeffects, Placement.Strict let variadic_classify_for_printing p = match p with Make_block _ | Make_array _ -> Constructive @@ -1628,7 +1660,7 @@ let equal t1 t2 = compare t1 t2 = 0 let free_names t = match t with - | Nullary (Optimised_out _ | Probe_is_enabled _ | Begin_region) -> + | Nullary (Invalid _ | Optimised_out _ | Probe_is_enabled _ | Begin_region) -> Name_occurrences.empty | Unary (prim, x0) -> Name_occurrences.union @@ -1653,7 +1685,8 @@ let free_names t = let apply_renaming t renaming = let apply simple = Simple.apply_renaming simple renaming in match t with - | Nullary (Optimised_out _ | Probe_is_enabled _ | Begin_region) -> t + | Nullary (Invalid _ | Optimised_out _ | Probe_is_enabled _ | Begin_region) -> + t | Unary (prim, x0) -> let prim' = apply_renaming_unary_primitive prim renaming in let x0' = apply x0 in @@ -1680,7 +1713,7 @@ let apply_renaming t renaming = let ids_for_export t = match t with - | Nullary (Optimised_out _ | Probe_is_enabled _ | Begin_region) -> + | Nullary (Invalid _ | Optimised_out _ | Probe_is_enabled _ | Begin_region) -> Ids_for_export.empty | Unary (prim, x0) -> Ids_for_export.union @@ -1751,25 +1784,25 @@ let effects_and_coeffects (t : t) = | Unary (prim, _) -> effects_and_coeffects_of_unary_primitive prim | Binary (prim, _, _) -> effects_and_coeffects_of_binary_primitive prim | Ternary (prim, _, _, _) -> effects_and_coeffects_of_ternary_primitive prim - | Variadic (prim, args) -> - effects_and_coeffects_of_variadic_primitive prim ~args + | Variadic (prim, _) -> effects_and_coeffects_of_variadic_primitive prim let no_effects_or_coeffects t = match effects_and_coeffects t with - | No_effects, No_coeffects -> true + | No_effects, No_coeffects, _ -> true | ( (No_effects | Only_generative_effects _ | Arbitrary_effects), - (No_coeffects | Has_coeffects) ) -> + (No_coeffects | Has_coeffects), + _ ) -> false let at_most_generative_effects t = match effects_and_coeffects t with - | (No_effects | Only_generative_effects _), _ -> true - | Arbitrary_effects, _ -> false + | (No_effects | Only_generative_effects _), _, _ -> true + | Arbitrary_effects, _, _ -> false let only_generative_effects t = match effects_and_coeffects t with - | Only_generative_effects _, _ -> true - | (No_effects | Arbitrary_effects), _ -> false + | Only_generative_effects _, _, _ -> true + | (No_effects | Arbitrary_effects), _, _ -> false module Eligible_for_cse = struct type t = primitive_application @@ -1788,14 +1821,15 @@ module Eligible_for_cse = struct let eligible = prim_eligible && List.exists Simple.is_var (args t) in let effects_and_coeffects_ok = match effects_and_coeffects t with - | No_effects, No_coeffects -> true - | Only_generative_effects Immutable, No_coeffects -> + | No_effects, No_coeffects, _ -> true + | Only_generative_effects Immutable, No_coeffects, _ -> (* Allow constructions of immutable blocks to be shared. *) true | ( ( No_effects | Only_generative_effects (Immutable | Immutable_unique | Mutable) | Arbitrary_effects ), - (No_coeffects | Has_coeffects) ) -> + (No_coeffects | Has_coeffects), + _ ) -> false in if not ((not eligible) || effects_and_coeffects_ok) @@ -1942,11 +1976,19 @@ module Without_args = struct | Binary prim -> print_binary_primitive ppf prim | Ternary prim -> print_ternary_primitive ppf prim | Variadic prim -> print_variadic_primitive ppf prim + + let effects_and_coeffects (t : t) = + match t with + | Nullary prim -> effects_and_coeffects_of_nullary_primitive prim + | Unary prim -> effects_and_coeffects_of_unary_primitive prim + | Binary prim -> effects_and_coeffects_of_binary_primitive prim + | Ternary prim -> effects_and_coeffects_of_ternary_primitive prim + | Variadic prim -> effects_and_coeffects_of_variadic_primitive prim end let is_begin_or_end_region t = match t with - | Nullary Begin_region | Unary (End_region, _) -> true + | Nullary Begin_region | Unary ((Begin_try_region | End_region), _) -> true | _ -> false [@@ocaml.warning "-fragile-match"] diff --git a/middle_end/flambda2/terms/flambda_primitive.mli b/middle_end/flambda2/terms/flambda_primitive.mli index 29ff01733a3..85b0c3c9d97 100644 --- a/middle_end/flambda2/terms/flambda_primitive.mli +++ b/middle_end/flambda2/terms/flambda_primitive.mli @@ -100,6 +100,8 @@ module Block_access_kind : sig val print : Format.formatter -> t -> unit val compare : t -> t -> int + + val element_kind_for_load : t -> Flambda_kind.t end (* CR-someday mshinwell: We should have unboxed arrays of int32, int64 and @@ -191,6 +193,11 @@ type signed_or_unsigned = (** Primitives taking exactly zero arguments. *) type nullary_primitive = + | Invalid of Flambda_kind.t + (** Used when rebuilding a primitive that turns out to be invalid. This is + easier to use than turning a whole let-binding into Invalid (which + might end up deleting code on the way up, resulting in a typing env + out-of-sync with the generated code). *) | Optimised_out of Flambda_kind.t (** Used for phantom bindings for which there is not enough information remaining to build a meaningful value. Can only be used in a phantom @@ -199,7 +206,8 @@ type nullary_primitive = (** Returns a boolean saying whether the given tracing probe is enabled. *) | Begin_region (** Starting delimiter of local allocation region, returning a region - name. *) + name. For regions for the "try" part of a "try...with", use + [Begin_try_region] (below) instead. *) (** Untagged binary integer arithmetic operations. @@ -273,7 +281,8 @@ type unary_primitive = closures. *) | Project_value_slot of { project_from : Function_slot.t; - value_slot : Value_slot.t + value_slot : Value_slot.t; + kind : Flambda_kind.With_subkind.t } (** Project a value slot from a set of closures -- in other words, read an entry from the closure environment (the captured variables). *) @@ -281,6 +290,9 @@ type unary_primitive = (** Only valid when the float array optimisation is enabled. *) | Is_flat_float_array (** Only valid when the float array optimisation is enabled. *) + | Begin_try_region + (** Starting delimiter of local allocation region, when used for a "try" + body, accepting the parent region as argument. *) | End_region (** Ending delimiter of local allocation region, accepting a region name. *) | Obj_dup (** Corresponds to [Obj.dup]; see the documentation in obj.mli. *) @@ -372,6 +384,10 @@ module Without_args : sig | Variadic of variadic_primitive val print : Format.formatter -> t -> unit + + (** Describe the effects and coeffects that the application of the given + primitive may have. *) + val effects_and_coeffects : t -> Effects_and_coeffects.t end (** A description of the kind of values which a unary primitive expects as its @@ -425,7 +441,7 @@ val result_kind' : t -> Flambda_kind.t (** Describe the effects and coeffects that the application of the given primitive may have. *) -val effects_and_coeffects : t -> Effects.t * Coeffects.t +val effects_and_coeffects : t -> Effects_and_coeffects.t (** Returns [true] iff the given primitive has neither effects nor coeffects. *) val no_effects_or_coeffects : t -> bool diff --git a/middle_end/flambda2/terms/loopify_attribute.ml b/middle_end/flambda2/terms/loopify_attribute.ml new file mode 100644 index 00000000000..f882fcb3438 --- /dev/null +++ b/middle_end/flambda2/terms/loopify_attribute.ml @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nathanaëlle Courant, OCamlPro *) +(* *) +(* Copyright 2022 OCamlPro SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type t = + | Always_loopify + | Never_loopify + | Already_loopified + | Default_loopify_and_tailrec + | Default_loopify_and_not_tailrec + +let print ppf = function + | Always_loopify -> Format.fprintf ppf "Always_loopify" + | Never_loopify -> Format.fprintf ppf "Never_loopify" + | Already_loopified -> Format.fprintf ppf "Already_loopified" + | Default_loopify_and_tailrec -> + Format.fprintf ppf "Default_loopify_and_tailrec" + | Default_loopify_and_not_tailrec -> + Format.fprintf ppf "Default_loopify_and_not_tailrec" + +let should_loopify = function + | Always_loopify | Default_loopify_and_tailrec -> true + | Never_loopify | Already_loopified | Default_loopify_and_not_tailrec -> false + +let was_loopified = function + | Always_loopify | Already_loopified | Default_loopify_and_tailrec -> true + | Never_loopify | Default_loopify_and_not_tailrec -> false + +let equal t1 t2 = + match t1, t2 with + | Always_loopify, Always_loopify + | Never_loopify, Never_loopify + | Already_loopified, Already_loopified + | Default_loopify_and_tailrec, Default_loopify_and_tailrec + | Default_loopify_and_not_tailrec, Default_loopify_and_not_tailrec -> + true + | ( ( Always_loopify | Never_loopify | Already_loopified + | Default_loopify_and_tailrec | Default_loopify_and_not_tailrec ), + _ ) -> + false diff --git a/middle_end/flambda2/terms/loopify_attribute.mli b/middle_end/flambda2/terms/loopify_attribute.mli new file mode 100644 index 00000000000..458ffcf87ec --- /dev/null +++ b/middle_end/flambda2/terms/loopify_attribute.mli @@ -0,0 +1,28 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nathanaëlle Courant, OCamlPro *) +(* *) +(* Copyright 2022 OCamlPro SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type t = + | Always_loopify + | Never_loopify + | Already_loopified + | Default_loopify_and_tailrec + | Default_loopify_and_not_tailrec + +val print : Format.formatter -> t -> unit + +val should_loopify : t -> bool + +val was_loopified : t -> bool + +val equal : t -> t -> bool diff --git a/middle_end/flambda2/terms/placement.ml b/middle_end/flambda2/terms/placement.ml new file mode 100644 index 00000000000..02bb310f7e9 --- /dev/null +++ b/middle_end/flambda2/terms/placement.ml @@ -0,0 +1,33 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Vincent Laviron, OCamlPro *) +(* *) +(* Copyright 2022 OCamlPro SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type t = + | Delay + | Strict + +let print ppf = function + | Delay -> Format.fprintf ppf "Delay" + | Strict -> Format.fprintf ppf "Strict" + +let compare placement1 placement2 = + match placement1, placement2 with + | Delay, Delay -> 0 + | Delay, Strict -> -1 + | Strict, Strict -> 0 + | Strict, Delay -> 1 + +let join placement1 placement2 = + match placement1, placement2 with + | Delay, Delay -> Delay + | Delay, Strict | Strict, Strict | Strict, Delay -> Strict diff --git a/middle_end/flambda2/terms/placement.mli b/middle_end/flambda2/terms/placement.mli new file mode 100644 index 00000000000..c0f8cc8e693 --- /dev/null +++ b/middle_end/flambda2/terms/placement.mli @@ -0,0 +1,36 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Mark Shinwell and Xavier Clerc, Jane Street Europe *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* Copyright 2017--2019 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Whether an expression can be moved around, including whether it can be + duplicated *) +type t = + | Delay + (** The expression should be placed as late as possible, even if it is + duplicated *) + | Strict + (** The expression must not be moved around (it has non-generative + effects, or coeffects, or doesn't benefit from being bound later). *) + +(** Print function. *) +val print : Format.formatter -> t -> unit + +(** Comparison function. *) +val compare : t -> t -> int + +(** Join *) +val join : t -> t -> t diff --git a/middle_end/flambda2/terms/poll_attribute.ml b/middle_end/flambda2/terms/poll_attribute.ml new file mode 100644 index 00000000000..4e099987495 --- /dev/null +++ b/middle_end/flambda2/terms/poll_attribute.ml @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2022 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type t = + | Default + | Error + +let print ppf t = + match t with + | Default -> Format.pp_print_string ppf "Default" + | Error -> Format.pp_print_string ppf "Error" + +let equal t1 t2 = + match t1, t2 with + | Default, Default | Error, Error -> true + | Default, Error | Error, Default -> false + +let is_default t = match t with Default -> true | Error -> false + +let from_lambda (attr : Lambda.poll_attribute) = + match attr with Default_poll -> Default | Error_poll -> Error + +let to_lambda t : Lambda.poll_attribute = + match t with Default -> Default_poll | Error -> Error_poll diff --git a/ocaml/asmcomp/debug/reg_availability_set.mli b/middle_end/flambda2/terms/poll_attribute.mli similarity index 57% rename from ocaml/asmcomp/debug/reg_availability_set.mli rename to middle_end/flambda2/terms/poll_attribute.mli index ba24a02f004..c6a9aef3d5e 100644 --- a/ocaml/asmcomp/debug/reg_availability_set.mli +++ b/middle_end/flambda2/terms/poll_attribute.mli @@ -2,9 +2,9 @@ (* *) (* OCaml *) (* *) -(* Mark Shinwell, Jane Street Europe *) +(* Mark Shinwell, Jane Street Europe *) (* *) -(* Copyright 2016--2017 Jane Street Group LLC *) +(* Copyright 2022 Jane Street Group LLC *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) @@ -12,26 +12,16 @@ (* *) (**************************************************************************) -(** Register availability sets. *) - type t = - | Ok of Reg_with_debug_info.Set.t - | Unreachable - -val inter : t -> t -> t -(** Intersection of availabilities. *) + | Default + | Error -val canonicalise : t -> t -(** Return a subset of the given availability set which contains no registers - that are not associated with debug info (and holding values of - non-persistent identifiers); and where no two registers share the same - location. *) +val print : Format.formatter -> t -> unit val equal : t -> t -> bool -val print - : print_reg:(Format.formatter -> Reg.t -> unit) - -> Format.formatter - -> t - -> unit -(** For debugging purposes only. *) +val is_default : t -> bool + +val from_lambda : Lambda.poll_attribute -> t + +val to_lambda : t -> Lambda.poll_attribute diff --git a/middle_end/flambda2/terms/set_of_closures.ml b/middle_end/flambda2/terms/set_of_closures.ml index ccfb77d376a..a21f330920c 100644 --- a/middle_end/flambda2/terms/set_of_closures.ml +++ b/middle_end/flambda2/terms/set_of_closures.ml @@ -16,13 +16,18 @@ type t = { function_decls : Function_declarations.t; - value_slots : Simple.t Value_slot.Map.t; + value_slots : (Simple.t * Flambda_kind.With_subkind.t) Value_slot.Map.t; alloc_mode : Alloc_mode.For_allocations.t } +let print_value_slot ppf (simple, kind) = + Format.fprintf ppf "@[(%a @<1>\u{2237} %a)@]" Simple.print simple + Flambda_kind.With_subkind.print kind + let [@ocamlformat "disable"] print ppf { function_decls; - value_slots;alloc_mode; + value_slots; + alloc_mode; } = Format.fprintf ppf "@[(%tset_of_closures%t@ \ @[(function_decls@ %a)@]@ \ @@ -32,7 +37,7 @@ let [@ocamlformat "disable"] print ppf Flambda_colours.prim_constructive Flambda_colours.pop (Function_declarations.print) function_decls - (Value_slot.Map.print Simple.print) value_slots + (Value_slot.Map.print print_value_slot) value_slots Alloc_mode.For_allocations.print alloc_mode include Container_types.Make (struct @@ -55,7 +60,13 @@ include Container_types.Make (struct if c <> 0 then c else - let c = Value_slot.Map.compare Simple.compare value_slots1 value_slots2 in + let compare_value_slot (simple1, kind1) (simple2, kind2) = + let c = Simple.compare simple1 simple2 in + if c <> 0 then c else Flambda_kind.With_subkind.compare kind1 kind2 + in + let c = + Value_slot.Map.compare compare_value_slot value_slots1 value_slots2 + in if c <> 0 then c else Alloc_mode.For_allocations.compare alloc_mode1 alloc_mode2 @@ -100,12 +111,12 @@ let [@ocamlformat "disable"] print ppf Flambda_colours.pop Alloc_mode.For_allocations.print alloc_mode Function_declarations.print function_decls - (Value_slot.Map.print Simple.print) value_slots + (Value_slot.Map.print print_value_slot) value_slots let free_names { function_decls; value_slots; alloc_mode = _ } = let free_names_of_value_slots = Value_slot.Map.fold - (fun value_slot simple free_names -> + (fun value_slot (simple, _kind) free_names -> Name_occurrences.union free_names (Name_occurrences.add_value_slot_in_declaration (Simple.free_names simple) value_slot Name_mode.normal)) @@ -124,12 +135,12 @@ let apply_renaming ({ function_decls; value_slots; alloc_mode } as t) renaming = let changed = ref false in let value_slots' = Value_slot.Map.filter_map - (fun var simple -> + (fun var (simple, kind) -> if Renaming.value_slot_is_used renaming var then ( let simple' = Simple.apply_renaming simple renaming in if not (simple == simple') then changed := true; - Some simple') + Some (simple', kind)) else ( changed := true; None)) @@ -151,7 +162,8 @@ let ids_for_export { function_decls; value_slots; alloc_mode } = in Ids_for_export.union (Value_slot.Map.fold - (fun _value_slot simple ids -> Ids_for_export.add_simple ids simple) + (fun _value_slot (simple, _kind) ids -> + Ids_for_export.add_simple ids simple) value_slots function_decls_ids) (Alloc_mode.For_allocations.ids_for_export alloc_mode) diff --git a/middle_end/flambda2/terms/set_of_closures.mli b/middle_end/flambda2/terms/set_of_closures.mli index 82ec53e221a..8ba9da8ea73 100644 --- a/middle_end/flambda2/terms/set_of_closures.mli +++ b/middle_end/flambda2/terms/set_of_closures.mli @@ -25,7 +25,7 @@ val is_empty : t -> bool (** Create a set of closures given the code for its functions and the closure variables. *) val create : - value_slots:Simple.t Value_slot.Map.t -> + value_slots:(Simple.t * Flambda_kind.With_subkind.t) Value_slot.Map.t -> Alloc_mode.For_allocations.t -> Function_declarations.t -> t @@ -34,7 +34,7 @@ val create : val function_decls : t -> Function_declarations.t (** The values of each value slot (the environment, or captured variables). *) -val value_slots : t -> Simple.t Value_slot.Map.t +val value_slots : t -> (Simple.t * Flambda_kind.With_subkind.t) Value_slot.Map.t (** Returns true iff the given set of closures has no value slots. *) val is_closed : t -> bool diff --git a/middle_end/flambda2/tests/meet_test.ml b/middle_end/flambda2/tests/meet_test.ml index 02ffa33c1f9..be768c2c1d9 100644 --- a/middle_end/flambda2/tests/meet_test.ml +++ b/middle_end/flambda2/tests/meet_test.ml @@ -184,11 +184,8 @@ let test_meet_two_blocks () = f block2 block1 let () = - let comp_unit = - Compilation_unit.create Compilation_unit.Prefix.empty - ("Meet_test" |> Compilation_unit.Name.of_string) - in - Compilation_unit.set_current comp_unit; + let comp_unit = "Meet_test" |> Compilation_unit.of_string in + Compilation_unit.set_current (Some comp_unit); Format.eprintf "MEET CHAINS WITH TWO VARS@\n@."; test_meet_chains_two_vars (); Format.eprintf "@.MEET CHAINS WITH THREE VARS@\n@."; diff --git a/middle_end/flambda2/tests/mlexamples/tests0.flt b/middle_end/flambda2/tests/mlexamples/tests0.flt index 4cad07e8f78..4085ac29e49 100644 --- a/middle_end/flambda2/tests/mlexamples/tests0.flt +++ b/middle_end/flambda2/tests/mlexamples/tests0.flt @@ -1,6 +1,9 @@ let $camlTests0__first_const18 = Block 0 () in let code size(31) - f_0 (param : imm tagged) my_closure my_region my_depth -> k * k1 : imm tagged = + f_0 (param : imm tagged) + my_closure my_region my_depth + -> k * k1 + : imm tagged = let next_depth = rec_info (succ my_depth) in (let prim = %is_int 0 in let is_scrutinee_int = %Tag_imm prim in @@ -29,7 +32,10 @@ in ===> let code f_0 deleted in let code size(1) newer_version_of(f_0) - f_0_1 (param : imm tagged) my_closure my_region my_depth -> k * k1 : imm tagged = + f_0_1 (param : imm tagged) + my_closure my_region my_depth + -> k * k1 + : imm tagged = cont k (0) in let $camlTests0__f_1 = closure f_0_1 @f in diff --git a/middle_end/flambda2/tests/ref_to_var/alias.ml b/middle_end/flambda2/tests/ref_to_var/alias.ml new file mode 100644 index 00000000000..3637cff23fd --- /dev/null +++ b/middle_end/flambda2/tests/ref_to_var/alias.ml @@ -0,0 +1,9 @@ +let id = Sys.opaque_identity + +let f x = + let r = ref x in + while id false do + let _ = id !r in + () + done; + !r + 1 diff --git a/middle_end/flambda2/tests/ref_to_var/alias_my_closure.ml b/middle_end/flambda2/tests/ref_to_var/alias_my_closure.ml new file mode 100644 index 00000000000..67c3853cce8 --- /dev/null +++ b/middle_end/flambda2/tests/ref_to_var/alias_my_closure.ml @@ -0,0 +1,8 @@ +external magic : 'a -> 'b = "%opaque" + +let g y = + let rec spl () = + let relist f ps = magic f in + if magic y then relist spl 0 else relist spl 1 + in + spl y diff --git a/middle_end/flambda2/tests/ref_to_var/dont_unbox_exn.ml b/middle_end/flambda2/tests/ref_to_var/dont_unbox_exn.ml new file mode 100644 index 00000000000..74a4d5af5ee --- /dev/null +++ b/middle_end/flambda2/tests/ref_to_var/dont_unbox_exn.ml @@ -0,0 +1,11 @@ +exception FoundAt of int + +external opaque : 'a -> 'a = "%opaque" + +external raise : exn -> 'a = "%raise" + +let test () = + try + if opaque false then raise (FoundAt (if opaque false then 1 else 2)); + 0 + with FoundAt i -> i diff --git a/middle_end/flambda2/tests/ref_to_var/exn.ml b/middle_end/flambda2/tests/ref_to_var/exn.ml new file mode 100644 index 00000000000..641dfcd665c --- /dev/null +++ b/middle_end/flambda2/tests/ref_to_var/exn.ml @@ -0,0 +1,20 @@ +exception Saucisse + +let id = Sys.opaque_identity + +let g () = () [@@inline never] + +let f x = + let r = ref x in + let v = + try + while id false do + let _ = id !r in + (* if id false then raise Saucisse; *) + g (); + () + done; + !r + with Saucisse -> !r + 1 + in + v * !r diff --git a/middle_end/flambda2/tests/ref_to_var/exn_2.ml b/middle_end/flambda2/tests/ref_to_var/exn_2.ml new file mode 100644 index 00000000000..59609840643 --- /dev/null +++ b/middle_end/flambda2/tests/ref_to_var/exn_2.ml @@ -0,0 +1,35 @@ +exception Saucisse + +let id = Sys.opaque_identity + +let g () = () [@@inline never] + +let f x tt = + let r = ref x in + let v = + try + while id false do + let _ = id !r in + (* if id false then raise Saucisse; *) + g (); + () + done; + !r + with Saucisse -> !r + 1 + in + v * !r + [@@inlined always] + +let zozo z = + let uu w pp = (f [@inlined always]) w pp in + let a, b = if Sys.opaque_identity false then 1, 1 else 2, 2 in + let ouou x = Sys.opaque_identity x in + let a = ouou a in + let o = Sys.opaque_identity z in + if Sys.opaque_identity false + then + let koko = Sys.opaque_identity a in + uu o koko + else + let kuku = Sys.opaque_identity b in + uu o kuku diff --git a/middle_end/flambda2/tests/ref_to_var/exn_3.ml b/middle_end/flambda2/tests/ref_to_var/exn_3.ml new file mode 100644 index 00000000000..d8bcfb3413a --- /dev/null +++ b/middle_end/flambda2/tests/ref_to_var/exn_3.ml @@ -0,0 +1,44 @@ +exception Saucisse + +let id = Sys.opaque_identity + +let g () = () [@@inline never] + +let f x tt b = + let r = ref x in + let v = + try + while id false do + () + done; + while id false do + let _ = id !r in + (* if id false then raise Saucisse; *) + g (); + if b then r := 12; + () + done; + !r + with Saucisse -> !r + 1 + in + v * !r + [@@inlined always] + +let zozo z b = + let uu w pp = f w pp b in + let a, b = if Sys.opaque_identity false then 1, 1 else 2, 2 in + let ouou x = Sys.opaque_identity x in + let a = ouou a in + let o = Sys.opaque_identity z in + if Sys.opaque_identity false + then + let koko = Sys.opaque_identity a in + uu o koko + else + let kuku = Sys.opaque_identity b in + uu o kuku + [@@inlined always] + +let chose z = + ignore z; + zozo z false diff --git a/middle_end/flambda2/tests/ref_to_var/field_out_of_bounds.ml b/middle_end/flambda2/tests/ref_to_var/field_out_of_bounds.ml new file mode 100644 index 00000000000..828dfbb411c --- /dev/null +++ b/middle_end/flambda2/tests/ref_to_var/field_out_of_bounds.ml @@ -0,0 +1,20 @@ +external id : 'a -> 'a = "%opaque" + +type foo = { x : int } + +type bar = + { x : int; + mutable y : int + } + +type 'a kind = + | Foo : foo kind + | Bar : bar kind + +let rightmost_field (type a) (k : a kind) (t : a) : int = + match k, t with Foo, { x } -> x | Bar, { x; y } -> y + +let foobar x = + let k = id Foo in + let t = { x } in + (rightmost_field [@inlined]) k t diff --git a/middle_end/flambda2/tests/ref_to_var/recursive_cont_with_handler.ml b/middle_end/flambda2/tests/ref_to_var/recursive_cont_with_handler.ml new file mode 100644 index 00000000000..190004b4632 --- /dev/null +++ b/middle_end/flambda2/tests/ref_to_var/recursive_cont_with_handler.ml @@ -0,0 +1,91 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, OCamlPro *) +(* Mark Shinwell and Leo White, Jane Street Europe *) +(* *) +(* Copyright 2013--2020 OCamlPro SAS *) +(* Copyright 2014--2020 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@ocaml.warning "-21-27-32"] + +module Id = struct + type t = int + + let flags_size_in_bits = 3 + + let create t flags = t [@@inline never] + + let mask_selecting_top_bits = -1 lsl flags_size_in_bits + + let mask_selecting_bottom_bits = lnot mask_selecting_top_bits + + let flags t = t land mask_selecting_bottom_bits [@@inline never] + + let next t = t + 665577 +end + +module Data = struct + type t = + { compilation_unit : unit; + previous_compilation_units : unit list; + name : string; + name_stamp : int + } + + let flags = 0 + + let hash + { compilation_unit; previous_compilation_units; name = _; name_stamp } = + Sys.opaque_identity 33 + + let equal t1 t2 = Sys.opaque_identity true +end + +let plop s = failwith s [@@inline never] + +module Table = struct + module E = Data + + module HT = struct + type _ t = unit + + let create _ = assert false [@@inline never] + + let add _ _ _ = assert false [@@inline never] + + let find _ _ = assert false [@@inline never] + end + + type t = E.t HT.t + + let add t elt = + let id = Id.create (E.hash elt) E.flags in + match HT.find t id with + | existing_elt -> ( + try + let starting_id = id in + (* XXXXXXXXXXX Id.next starting_id is added as an extra_arg_for_aliases + to the recursive continuation of the while. It shouldn't: WHY ? *) + let id = ref (Id.next starting_id) in + (* If there is a collision, we search for another slot, but take care + not to alter the flags bits. *) + while !id <> starting_id do + assert (Id.flags !id = E.flags); + match HT.find t !id with + | exception Not_found -> raise Exit + | existing_elt -> + if E.equal elt existing_elt then raise Exit else id := Id.next !id + done; + plop "No hash values left for@" + with Exit -> ()) + + let add' t elt = (add [@inlined]) t elt +end diff --git a/middle_end/flambda2/tests/ref_to_var/ref/machin.ml b/middle_end/flambda2/tests/ref_to_var/ref/machin.ml new file mode 100644 index 00000000000..79d1aacdfe7 --- /dev/null +++ b/middle_end/flambda2/tests/ref_to_var/ref/machin.ml @@ -0,0 +1,43 @@ +type 'a ref = { mutable contents : 'a } + +external ref : 'a -> ('a ref[@local_opt]) = "%makemutable" + +external ( ! ) : ('a ref[@local_opt]) -> 'a = "%field0" + +external ( := ) : ('a ref[@local_opt]) -> 'a -> unit = "%setfield0" +(* external incr : (int ref[@local_opt]) -> unit = "%incr" + * external decr : (int ref[@local_opt]) -> unit = "%decr" *) + +external ( +. ) : + (float[@local_opt]) -> (float[@local_opt]) -> (float[@local_opt]) + = "%addfloat" + +external ( + ) : (int[@local_opt]) -> (int[@local_opt]) -> int = "%addint" + +let incr x = x := !x + 1 + +(* let f x = + * let a = ref x in + * incr a; + * !a *) + +let f b x = + let a = ref x in + let y, z = + if b + then ( + incr a; + a, a) + else a, a + in + incr y; + incr z; + z := !z + !y; + !a + +(* let f b x = + * let a = ref x in + * while b do + * incr a; + * done; + * !a *) diff --git a/middle_end/flambda2/tests/ref_to_var/string.ml b/middle_end/flambda2/tests/ref_to_var/string.ml new file mode 100644 index 00000000000..836ca5de872 --- /dev/null +++ b/middle_end/flambda2/tests/ref_to_var/string.ml @@ -0,0 +1,50 @@ +type 'a ref = { mutable contents : 'a } + +external ref : 'a -> ('a ref[@local_opt]) = "%makemutable" + +external ( ! ) : ('a ref[@local_opt]) -> 'a = "%field0" + +external ( := ) : ('a ref[@local_opt]) -> 'a -> unit = "%setfield0" + +external incr : (int ref[@local_opt]) -> unit = "%incr" + +external decr : (int ref[@local_opt]) -> unit = "%decr" + +external ( && ) : (bool[@local_opt]) -> (bool[@local_opt]) -> bool = "%sequand" + +external ( / ) : (int[@local_opt]) -> (int[@local_opt]) -> int = "%divint" + +external ( - ) : (int[@local_opt]) -> (int[@local_opt]) -> int = "%subint" + +external ( + ) : (int[@local_opt]) -> (int[@local_opt]) -> int = "%addint" + +external ( = ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%equal" + +external ( <> ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%notequal" + +external ( < ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%lessthan" + +external ( > ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%greaterthan" + +external ( <= ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%lessequal" + +external ( >= ) : ('a[@local_opt]) -> ('a[@local_opt]) -> bool = "%greaterequal" + +external compare : ('a[@local_opt]) -> ('a[@local_opt]) -> int = "%compare" + +external length : string -> int = "%string_length" + +external unsafe_get : string -> int -> char = "%string_unsafe_get" + +let[@inline never] sub s ofs len = assert false + +let split_on_char sep s = + let r = ref [] in + let j = ref (length s) in + for i = length s - 1 downto 0 do + if unsafe_get s i = sep + then ( + r := sub s (i + 1) (!j - i - 1) :: !r; + j := i) + done; + sub s 0 !j :: !r diff --git a/middle_end/flambda2/tests/ref_to_var/unbox_while.ml b/middle_end/flambda2/tests/ref_to_var/unbox_while.ml new file mode 100644 index 00000000000..f8ffa62994b --- /dev/null +++ b/middle_end/flambda2/tests/ref_to_var/unbox_while.ml @@ -0,0 +1,23 @@ +type 'a ref = { mutable contents : 'a } + +external ref : 'a -> ('a ref[@local_opt]) = "%makemutable" + +external ( ! ) : ('a ref[@local_opt]) -> 'a = "%field0" + +external ( := ) : ('a ref[@local_opt]) -> 'a -> unit = "%setfield0" + +external incr : (int ref[@local_opt]) -> unit = "%incr" + +external decr : (int ref[@local_opt]) -> unit = "%decr" + +external ( +. ) : + (float[@local_opt]) -> (float[@local_opt]) -> (float[@local_opt]) + = "%addfloat" + +let f x = + let r = ref x in + let g = ref 0. in + for i = 0 to 10 do + g := !g +. !r + done; + !g diff --git a/middle_end/flambda2/tests/ref_to_var/unboxed_invariant_ref.ml b/middle_end/flambda2/tests/ref_to_var/unboxed_invariant_ref.ml new file mode 100644 index 00000000000..3843e2599c0 --- /dev/null +++ b/middle_end/flambda2/tests/ref_to_var/unboxed_invariant_ref.ml @@ -0,0 +1,8 @@ +type t = { mutable x : int } + +let[@inline] f l = + let t = { x = 0 } in + List.iter (fun () -> t.x <- 1 + t.x) l; + t + +let test l = (f l).x diff --git a/middle_end/flambda2/tests/ref_to_var/unboxed_invariant_ref_2.ml b/middle_end/flambda2/tests/ref_to_var/unboxed_invariant_ref_2.ml new file mode 100644 index 00000000000..ccd1193fca7 --- /dev/null +++ b/middle_end/flambda2/tests/ref_to_var/unboxed_invariant_ref_2.ml @@ -0,0 +1,12 @@ +type t = { mutable x : int } + +let rec go b r = + if Sys.opaque_identity false + then r + else if b + then go b { x = 0 } + else ( + r.x <- r.x + 1; + go b r) + +let f () = ((go [@inlined]) false { x = 0 }).x diff --git a/middle_end/flambda2/tests/ref_to_var/unboxing_cse.ml b/middle_end/flambda2/tests/ref_to_var/unboxing_cse.ml new file mode 100644 index 00000000000..0a9f04cda56 --- /dev/null +++ b/middle_end/flambda2/tests/ref_to_var/unboxing_cse.ml @@ -0,0 +1,9 @@ +external ( < ) : int -> int -> bool = "%lessthan" + +external opaque : 'a -> 'a = "%opaque" + +let f x z = + let[@inline] test (_, y) = if y < z then opaque 0 else opaque 0 in + let _ = test (0, x) in + (* will correctly be unboxed if you delete the above line *) + test (if opaque true then 0, x else 1, x) diff --git a/middle_end/flambda2/tests/ref_to_var/unused_fun_return.ml b/middle_end/flambda2/tests/ref_to_var/unused_fun_return.ml new file mode 100644 index 00000000000..62a23396331 --- /dev/null +++ b/middle_end/flambda2/tests/ref_to_var/unused_fun_return.ml @@ -0,0 +1,57 @@ +[@@@ocaml.warning "-27"] + +let f x = x [@@inline never] + +let g x y = + let r = ref 0 in + let o = ref y in + while Sys.opaque_identity true do + let _v = f x in + let _w = f x in + r := y + !o + done; + !r + +let mouf x y = + let r = ref 0 in + (* This is not marked as invariant because not a variable. Would be the same + thing with a const : TODO improve this *) + let o = ref (1, 2) in + while Sys.opaque_identity true do + let _v = f x in + let _w = f x in + r := y + fst (Sys.opaque_identity !o) + done; + !r + +(* let g b x y z = + * let kont r o = + * while Sys.opaque_identity true do + * let _v = f x in + * let _w = f x in + * r := y + !o + * done; + * !r + * in + * let r = ref 0 in + * let o = ref 0 in + * let mortadelle = Sys.opaque_identity y in + * let () = + * if b then + * o := mortadelle + * else + * o := y + * in + * if Sys.opaque_identity false then + * kont r o + * else + * begin + * incr r; + * kont r o + * end + * + * let plop b_plop x_plop y_plop z_plop = + * (g[@inlined]) b_plop x_plop y_plop z_plop + * + * let mouarf x_mouarf y_mouarf z_mouarf = + * (plop[@inlined]) true x_mouarf y_mouarf z_mouarf *) diff --git a/middle_end/flambda2/tests/tools/fldiff.ml b/middle_end/flambda2/tests/tools/fldiff.ml index 68d5066eaa6..acec0f54366 100644 --- a/middle_end/flambda2/tests/tools/fldiff.ml +++ b/middle_end/flambda2/tests/tools/fldiff.ml @@ -1,9 +1,7 @@ open Import let parse_flambda file = - match - Parse_flambda.parse ~symbol_for_global:Flambda2.symbol_for_global file - with + match Parse_flambda.parse file with | Ok unit -> unit | Error e -> (match e with diff --git a/middle_end/flambda2/tests/tools/flexpect.ml b/middle_end/flambda2/tests/tools/flexpect.ml index b6dbef79dbe..0a085a193cc 100644 --- a/middle_end/flambda2/tests/tools/flexpect.ml +++ b/middle_end/flambda2/tests/tools/flexpect.ml @@ -4,9 +4,7 @@ open Import (* CR lmaurer: Make this an argument. *) let exit_normally_on_failure = true -let symbol_for_global = Flambda2.symbol_for_global - -let get_global_info = Flambda2.get_global_info +let get_module_info = Flambda2.get_module_info let check_invariants program = try () (* Flambda_unit.invariant program *) @@ -42,27 +40,17 @@ let dump_error (e : Parse_flambda.error) = Format.eprintf "%a:@.Lex error: %a@." Location.print_loc loc Flambda_lex.pp_error error -let run_expect_test ~symbol_for_global ~get_global_info ~extension ~filename +let run_expect_test ~get_module_info ~extension ~filename ({ before; after = expected } : Fexpr.expect_test_spec) : Test_outcome.t = let comp_unit = Parse_flambda.make_compilation_unit ~extension ~filename () in - Compilation_unit.set_current comp_unit; - let module_ident = - comp_unit |> Symbol0.for_compilation_unit |> Symbol0.linkage_name - |> Linkage_name.to_string |> Ident.create_persistent - in - let before_fl = - Fexpr_to_flambda.conv ~symbol_for_global ~module_ident before - in + Compilation_unit.set_current (Some comp_unit); + let before_fl = Fexpr_to_flambda.conv comp_unit before in check_invariants before_fl; - let cmx_loader = - Flambda_cmx.create_loader ~symbol_for_global ~get_global_info - in + let cmx_loader = Flambda_cmx.create_loader ~get_module_info in let { Simplify.unit = actual_fl; _ } = Simplify.run ~cmx_loader ~round:0 before_fl in - let expected_fl = - Fexpr_to_flambda.conv ~symbol_for_global ~module_ident expected - in + let expected_fl = Fexpr_to_flambda.conv comp_unit expected in match Compare.flambda_units actual_fl expected_fl with | Equivalent -> Pass | Different { approximant = actual' } -> @@ -90,8 +78,7 @@ let run_flt_file filename : Outcome.t = match Parse_flambda.parse_expect_test_spec filename with | Ok test_spec -> ( match - run_expect_test ~symbol_for_global ~get_global_info ~extension:".flt" - ~filename test_spec + run_expect_test ~get_module_info ~extension:".flt" ~filename test_spec with | Pass -> Format.eprintf "PASS@."; @@ -116,8 +103,8 @@ let run_mdflx_file filename : Outcome.t = | Text _ -> node | Expect test_spec -> ( match - run_expect_test test_spec ~symbol_for_global ~get_global_info - ~extension:".mdflx" ~filename + run_expect_test test_spec ~get_module_info ~extension:".mdflx" + ~filename with | Pass -> Format.eprintf "PASS@."; diff --git a/middle_end/flambda2/tests/tools/parseflambda.ml b/middle_end/flambda2/tests/tools/parseflambda.ml index 60ac96536c4..7d8646c6120 100644 --- a/middle_end/flambda2/tests/tools/parseflambda.ml +++ b/middle_end/flambda2/tests/tools/parseflambda.ml @@ -1,7 +1,5 @@ open Import -let symbol_for_global = Flambda2.symbol_for_global - let get_global_info = Flambda2.get_global_info let check_invariants program = @@ -19,13 +17,11 @@ let parse_flambda filename = in Compilation_unit.set_current comp_unit; Format.printf "%a@.@." Print_fexpr.flambda_unit unit; - let module_ident = Compilation_unit.get_persistent_ident comp_unit in - let fl2 = Fexpr_to_flambda.conv ~symbol_for_global ~module_ident unit in + let fl2 = Fexpr_to_flambda.conv comp_unit unit in Format.printf "flambda:@.%a@.@." Flambda_unit.print fl2; check_invariants fl2; - let { Simplify.unit = fl2'; _ } = - Simplify.run ~symbol_for_global ~get_global_info ~round:1 fl2 - in + let cmx_loader = Flambda_cmx.create_loader ~get_global_info in + let { Simplify.unit = fl2'; _ } = Simplify.run ~cmx_loader ~round:1 fl2 in Format.printf "simplify:@.%a@." Flambda_unit.print fl2'; let fl3 = Flambda_to_fexpr.conv fl2' in Format.printf "back to fexpr:@.%a@." Print_fexpr.flambda_unit fl3; diff --git a/middle_end/flambda2/to_cmm/to_cmm.ml b/middle_end/flambda2/to_cmm/to_cmm.ml index 7213b84388b..4a3c497441c 100644 --- a/middle_end/flambda2/to_cmm/to_cmm.ml +++ b/middle_end/flambda2/to_cmm/to_cmm.ml @@ -77,6 +77,7 @@ let unit0 ~offsets flambda_unit ~all_code = return the unit value). *) let env = Env.create offsets all_code ~return_continuation:dummy_k + ~trans_prim:To_cmm_primitive.trans_prim ~exn_continuation:(Flambda_unit.exn_continuation flambda_unit) in let _env, return_cont_params = @@ -92,6 +93,11 @@ let unit0 ~offsets flambda_unit ~all_code = (Flambda_unit.return_continuation flambda_unit) ~param_types:(List.map snd return_cont_params) in + (* See comment in [To_cmm_set_of_closures] about binding [my_region] *) + let env, _bound_var = + Env.create_bound_parameter env + (Flambda_unit.toplevel_my_region flambda_unit) + in let r = R.create ~module_symbol:(Flambda_unit.module_symbol flambda_unit) in let body, res = To_cmm_expr.expr env r (Flambda_unit.body flambda_unit) in let body = @@ -110,7 +116,7 @@ let unit0 ~offsets flambda_unit ~all_code = then fun_codegen else Cmm.No_CSE :: fun_codegen in - C.cfunction (C.fundecl fun_name [] body fun_codegen dbg) + C.cfunction (C.fundecl fun_name [] body fun_codegen dbg Default_poll) in let { R.data_items; gc_roots; functions } = R.to_cmm res in let cmm_helpers_data = flush_cmm_helpers_state () in diff --git a/middle_end/flambda2/to_cmm/to_cmm_effects.ml b/middle_end/flambda2/to_cmm/to_cmm_effects.ml index d107e8d4f1c..61d8cb9732f 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_effects.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_effects.ml @@ -19,20 +19,26 @@ type effects_and_coeffects_classification = | Pure | Effect | Coeffect_only + | Generative_immutable let classify_by_effects_and_coeffects effs = (* See the comments on type [classification] in the .mli. *) match (effs : Effects_and_coeffects.t) with - | Arbitrary_effects, (Has_coeffects | No_coeffects) - | Only_generative_effects _, (Has_coeffects | No_coeffects) -> + | Only_generative_effects Immutable, No_coeffects, _ -> Generative_immutable + | Arbitrary_effects, (Has_coeffects | No_coeffects), _ + | ( Only_generative_effects (Mutable | Immutable | Immutable_unique), + (Has_coeffects | No_coeffects), + _ ) -> Effect - | No_effects, Has_coeffects -> Coeffect_only - | No_effects, No_coeffects -> Pure + | No_effects, Has_coeffects, _ -> Coeffect_only + | No_effects, No_coeffects, _ -> Pure type let_binding_classification = - | Regular | Drop_defining_expr - | May_inline + | Regular + | May_inline_once + | Must_inline_once + | Must_inline_and_duplicate let classify_let_binding var ~(effects_and_coeffects_of_defining_expr : Effects_and_coeffects.t) @@ -43,13 +49,16 @@ let classify_let_binding var match classify_by_effects_and_coeffects effects_and_coeffects_of_defining_expr with - | Coeffect_only | Pure -> Drop_defining_expr + | Coeffect_only | Generative_immutable | Pure -> Drop_defining_expr | Effect -> Regular (* Could be May_inline technically, but it doesn't matter since it can only be flushed by the env. *)) - | One -> - (* Any defining expression used exactly once is considered for inlining at + | One -> ( + (* This case represents expressions that are guaranteed to be evaluated at + most once at runtime (and thus do not include expressions inside loops). + + Any defining expression used exactly once is considered for inlining at this stage. The environment is going to handle the details of preserving the effects and coeffects ordering (if inlining without reordering is impossible then the expressions will be bound at some safe place @@ -58,8 +67,15 @@ let classify_let_binding var Whether inlining of _effectful_ expressions _actually occurs_ depends on the context. Currently this is very restricted, see comments in [To_cmm_primitive]. *) - May_inline - | More_than_one -> Regular + match effects_and_coeffects_of_defining_expr with + | _, _, Delay -> Must_inline_once + | _, _, Strict -> May_inline_once) + | More_than_one -> ( + (* Note: expressions in loops are counted as having two occurrences to + ensure that they fall into this case *) + match effects_and_coeffects_of_defining_expr with + | _, _, Delay -> Must_inline_and_duplicate + | _, _, Strict -> Regular) type continuation_handler_classification = | Regular diff --git a/middle_end/flambda2/to_cmm/to_cmm_effects.mli b/middle_end/flambda2/to_cmm/to_cmm_effects.mli index 07d44d67709..72ef927f2a2 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_effects.mli +++ b/middle_end/flambda2/to_cmm/to_cmm_effects.mli @@ -16,7 +16,7 @@ open! Flambda.Import (** Classification of expressions based on their effects and coeffects. *) -type effects_and_coeffects_classification = private +type effects_and_coeffects_classification = | Pure (** Pure expressions can be commuted with *everything*, including effectful expressions such as function calls. *) @@ -31,6 +31,11 @@ type effects_and_coeffects_classification = private (** Coeffects without any effect. These expression can commute with other coeffectful expressions (and pure expressions), but cannot commute with an effectful expression. *) + | Generative_immutable + (** Only immutable generative effects. These are technically effects + (since functions in the `Gc` module can read counters related to + allocations), but we are interested in moving allocation (e.g. for + unboxing of numbers in classic mode). *) (** Return the classification of an expression with the given effects and coeffects. *) @@ -40,9 +45,17 @@ val classify_by_effects_and_coeffects : (** Classification of [Let]-expressions, identifying what may be done with the defining expression. *) type let_binding_classification = private - | Regular (** Proceed as normal, do not inline the defining expression. *) | Drop_defining_expr (** The defining expression may be deleted. *) - | May_inline (** The defining expression may be inlined at the use site. *) + | Regular (** Proceed as normal, do not inline the defining expression. *) + | May_inline_once + (** The defining expression is guaranteed to be used once, and may be + inlined at the use site. *) + | Must_inline_once + (** The defining expression is guaranteed to be used once, and must + inlined at the use site. *) + | Must_inline_and_duplicate + (** The defining expression must be inlined at all use sites, and it is + used multiple times (or inside a loop). *) val classify_let_binding : Variable.t -> diff --git a/middle_end/flambda2/to_cmm/to_cmm_env.ml b/middle_end/flambda2/to_cmm/to_cmm_env.ml index 96c002f44f6..ecac1627acd 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_env.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_env.ml @@ -14,6 +14,8 @@ (**************************************************************************) module C = Cmm_helpers +module R = To_cmm_result +module P = Flambda_primitive module Ece = Effects_and_coeffects type cont = @@ -27,29 +29,82 @@ type cont = handler_body : Flambda.Expr.t } -type extra_info = - | Untag of Cmm.expression - | Boxed_number +type extra_info = Untag of Cmm.expression + +(* Since to_cmm_primitive.ml depends on this file, and in this file, we need to + translate delayed/split primitives, we need to have access to the translation + primitive from to_cmm_primitive.ml, and we'll get them through this + record. *) + +type prim_res = extra_info option * R.t * Cmm.expression + +type ('env, 'prim, 'arity) prim_helper = + 'env -> R.t -> Debuginfo.t -> 'prim -> 'arity + +type 'env trans_prim = + { nullary : ('env, P.nullary_primitive, prim_res) prim_helper; + unary : ('env, P.unary_primitive, Cmm.expression -> prim_res) prim_helper; + binary : + ( 'env, + P.binary_primitive, + Cmm.expression -> Cmm.expression -> prim_res ) + prim_helper; + ternary : + ( 'env, + P.ternary_primitive, + Cmm.expression -> Cmm.expression -> Cmm.expression -> prim_res ) + prim_helper; + variadic : + ('env, P.variadic_primitive, Cmm.expression list -> prim_res) prim_helper + } (* Delayed let-bindings (see the .mli) *) -type binding = +(* the binding kinds *) +type simple = Simple + +type complex = Complex + +type _ inline = + | Do_not_inline : simple inline + | May_inline_once : simple inline + | Must_inline_once : complex inline + | Must_inline_and_duplicate : complex inline + +(* Note on the effects of splittable bindings: + + The arguments are stored with their effects. This means that if we need to + split the binding, we can re-bind each argument with its correct effects. *) +type _ bound_expr = + | Simple : { cmm_expr : Cmm.expression } -> simple bound_expr + | Split : { cmm_expr : Cmm.expression } -> complex bound_expr + | Splittable_prim : + { dbg : Debuginfo.t; + prim : Flambda_primitive.Without_args.t; + args : (Cmm.expression * Ece.t) list + } + -> complex bound_expr + +type 'kind binding = { order : int; - may_inline : bool; - (* [may_inline] means that the defining expression of the binding is safe to - inline, but it doesn't necessarily _have_ to be inlined. *) effs : Ece.t; - cmm_var : Backend_var.With_provenance.t; - cmm_expr : Cmm.expression + inline : 'kind inline; + bound_expr : 'kind bound_expr; + cmm_var : Backend_var.With_provenance.t } +type any_binding = Binding : _ binding -> any_binding [@@unboxed] + type stage = - | Effect of Variable.t * binding - | Coeffect_only of binding Variable.Map.t + | Effect of Variable.t + | Coeffect_only of Variable.Set.t type t = - { (* Global information. This is computed once and remains valid for a whole - compilation unit. *) + { (* Global information. + + This is computed once and remains valid for a whole compilation unit. *) + trans_prim : t trans_prim; + (* Primitive translation functions. *) offsets : Exported_offsets.t; (* Offsets for function and value slots. *) functions_info : Exported_code.t; @@ -65,11 +120,6 @@ type t = exn_continuation : Continuation.t; (* The exception continuation of the current context (used to determine where to insert try-with blocks). *) - vars : Cmm.expression Variable.Map.t; - (* Cmm expressions (of the form [Cvar ...]) describing all Flambda variables - in scope. *) - vars_extra : extra_info Variable.Map.t; - (* Extra information (see above) associated with Flambda variables. *) conts : cont Continuation.Map.t; (* Information about whether each continuation in scope should have its handler inlined, or else reached via a jump. *) @@ -78,32 +128,96 @@ type t = exn_conts_extra_args : Backend_var.t list Continuation.Map.t; (* Mutable variables used for compiling the "extra arguments" to exception handlers. *) - pures : binding Variable.Map.t; - (* Pure let-bindings that can be inlined across _stages_ (see the .mli). *) + vars_extra : extra_info Variable.Map.t; + (* Extra information associated with Flambda variables. *) + vars : Cmm.expression Variable.Map.t; + (* Cmm expressions (of the form [Cvar ...]) for all bound variables in + scope. *) + bindings : any_binding Variable.Map.t; + (* All bindings currently in env. *) stages : stage list (* Stages of let-bindings, most recent at the head. *) } -let create offsets functions_info ~return_continuation ~exn_continuation = +let create offsets functions_info ~trans_prim ~return_continuation + ~exn_continuation = { return_continuation; exn_continuation; offsets; functions_info; + trans_prim; stages = []; - pures = Variable.Map.empty; - vars = Variable.Map.empty; + bindings = Variable.Map.empty; vars_extra = Variable.Map.empty; + vars = Variable.Map.empty; conts = Continuation.Map.empty; exn_handlers = Continuation.Set.singleton exn_continuation; exn_conts_extra_args = Continuation.Map.empty } let enter_function_body env ~return_continuation ~exn_continuation = - create env.offsets env.functions_info ~return_continuation ~exn_continuation + create env.offsets env.functions_info ~trans_prim:env.trans_prim + ~return_continuation ~exn_continuation let return_continuation env = env.return_continuation let exn_continuation env = env.exn_continuation +let print_extra_info ppf = function + | Untag e -> Format.fprintf ppf "Untag(%a)" Printcmm.expression e + +let [@ocamlformat "disable"] print_inline (type a) ppf (inline : a inline) = + match inline with + | Do_not_inline -> Format.fprintf ppf "do_not_inline" + | May_inline_once -> Format.fprintf ppf "may_inline_once" + | Must_inline_once -> Format.fprintf ppf "must_inline_once" + | Must_inline_and_duplicate -> Format.fprintf ppf "must_inline_and_duplicate" + +let [@ocamlformat "disable"] print_bound_expr (type a) ppf (b : a bound_expr) = + match b with + | Simple { cmm_expr; } | Split { cmm_expr; } -> + Printcmm.expression ppf cmm_expr + | Splittable_prim { prim; args; dbg; } -> + Format.fprintf ppf "@[(\ + @[(dbg@ %a)@]@ \ + @[(prim@ %a)@]@ \ + @[(args@ @[(%a)@])@]\ + )@]" + Debuginfo.print_compact dbg + Flambda_primitive.Without_args.print prim + (Format.pp_print_list (fun ppf (cmm, _) -> Printcmm.expression ppf cmm)) args + +let [@ocamlformat "disable"] print_binding (type a) ppf + ({ order; inline; effs; cmm_var; bound_expr; } : a binding) = + Format.fprintf ppf "@[(\ + @[(order@ %d)@]@ \ + @[(inline@ %a)@]@ \ + @[(effs@ %a)@]@ \ + @[(var@ %a)@]@ \ + @[(expr@ %a)@]\ + )@]" + order + print_inline inline + Ece.print effs + Backend_var.With_provenance.print cmm_var + print_bound_expr bound_expr + +let _print_any_binding ppf (Binding binding) = print_binding ppf binding + +let print_stage ppf = function + | Effect v -> Format.fprintf ppf "(Effect %a)" Variable.print v + | Coeffect_only s -> + Format.fprintf ppf "(Coeffect_only %a)" Variable.Set.print s + +let print_stages ppf stages = + let pp_sep ppf () = Format.fprintf ppf "@," in + Format.fprintf ppf "(@[%a@])" + (Format.pp_print_list ~pp_sep print_stage) + stages + +let print ppf t = + Format.fprintf ppf "@[(@[(stages %a)@]@ )@]" print_stages + t.stages + (* Code and closures *) let get_code_metadata env code_id = @@ -123,21 +237,22 @@ let gen_variable v = (* CR mshinwell: Fix [provenance] *) Backend_var.With_provenance.create ?provenance:None v -let add_variable env v v' = +let add_bound_param env v v' = let v'' = Backend_var.With_provenance.var v' in let vars = Variable.Map.add v (C.var v'') env.vars in { env with vars } -let create_variable env v = +let create_bound_parameter env v = if Variable.Map.mem v env.vars then Misc.fatal_errorf "Cannot rebind variable %a in To_cmm environment" Variable.print v; let v' = gen_variable v in - let env = add_variable env v v' in + let env = add_bound_param env v v' in env, v' -let create_variables env vs = List.fold_left_map create_variable env vs +let create_bound_parameters env vs = + List.fold_left_map create_bound_parameter env vs let extra_info env simple = match Simple.must_be_var simple with @@ -208,150 +323,465 @@ let get_exn_extra_args env k = (* Variable binding (for potential inlining). Also see [To_cmm_effects]. *) -let is_inlinable_box effs ~extra = - (* [effs] is the effects and coeffects of some primitive operation, arising - either from the primitive itself or its arguments. If this is a boxing - operation (as indicated by [extra]) then we want to inline the box. However - this involves moving the arguments, so they must be pure (or at most have - generative effects, with no coeffects). *) - match (effs : Ece.t), (extra : extra_info option) with - | ((No_effects | Only_generative_effects _), No_coeffects), Some Boxed_number +let next_order = ref (-1) + +let simple cmm_expr = Simple { cmm_expr } + +let complex_no_split cmm_expr = Split { cmm_expr } + +let splittable_primitive dbg prim args = Splittable_prim { dbg; prim; args } + +let is_cmm_simple cmm = + match (cmm : Cmm.expression) with + | Cconst_int _ | Cconst_natint _ | Cconst_float _ | Cconst_symbol _ | Cvar _ -> true - | ( ( (No_effects | Only_generative_effects _ | Arbitrary_effects), - (No_coeffects | Has_coeffects) ), - (None | Some Boxed_number | Some (Untag _)) ) -> + | Clet _ | Clet_mut _ | Cphantom_let _ | Cassign _ | Ctuple _ | Cop _ + | Csequence _ | Cifthenelse _ | Cswitch _ | Ccatch _ | Cexit _ | Ctrywith _ + | Cregion _ | Ctail _ -> false -let create_binding = - let next_order = ref (-1) in - fun ?extra env ~may_inline effs var cmm_expr -> - let order = - incr next_order; - !next_order +(* Helper function to create bindings *) + +let create_binding_aux (type a) effs var ~(inline : a inline) + (bound_expr : a bound_expr) = + let order = + let incr = + match bound_expr with + | Simple _ | Split _ -> 1 + | Splittable_prim { args; _ } -> List.length args + 1 in - let cmm_var = gen_variable var in - let binding = { order; may_inline; effs; cmm_var; cmm_expr } in - let cmm_expr = C.var (Backend_var.With_provenance.var cmm_var) in - let env = { env with vars = Variable.Map.add var cmm_expr env.vars } in - let env = - match extra with - | None -> env - | Some info -> - { env with vars_extra = Variable.Map.add var info env.vars_extra } + next_order := !next_order + incr; + !next_order + in + let cmm_var = gen_variable var in + let binding = Binding { order; inline; effs; cmm_var; bound_expr } in + binding + +let create_binding (type a) effs var ~(inline : a inline) + (bound_expr : a bound_expr) = + (* In order to avoid generating binding of the form: "let x = y in ...", when + 'y' is trivial i.e. is a value that fits in a register, we mark 'x' as a + must_inline_and_duplicate (since it basically replaces a variable by either + another variable, a constant, or a symbol). *) + match bound_expr with + | (Split { cmm_expr } | Simple { cmm_expr }) when is_cmm_simple cmm_expr -> + (* trivial/simple cmm expression (as decided by [is_cmm_simple]) do not have + effects and coeffects *) + let effs = Ece.pure_can_be_duplicated in + create_binding_aux effs var ~inline:Must_inline_and_duplicate + (Split { cmm_expr }) + | Simple _ | Split _ | Splittable_prim _ -> + create_binding_aux effs var ~inline bound_expr + +(* Binding splitting *) +(* CR gbury: we actually need to "lie" about the effects and coeffects of + allocations that we must inline, or else we end up with expressions with + effects that will not be inlined (see [to_cmm_primitive.ml] and in particular + ~consider_inlining_effectful_expressions). For instance, consider: *) +(* + * let x = box_number 1. in + * let y = unbox_number x in + * let z = y +. 1. in + * ... + *) +(* because we only ever join effects when translating primitives, and that we + only use the effects and coeffects from the flambda code, we generate: + + - a binding "x -> box_number 1." with generative effects (as expected) + + - a binding "y -> 1." (because we inlined "x", and cmm_helper functions + eliminated the unbox-of-box), but this binding has generative effects, + because it effects are computed as : ece(prim:unbox_number) ∪ ece(x), and + since "x" has generative effects, we end up with a binding for "y" that has + generative effects. + + - when we translate the addition, we explicitly do not consider inlining + effectful expressions, and thus we do not inline "y", since it has effects. + + To counteract that, we instead consider that generative effects arising from + Delay/"must inline" primitives do not count, and that we consider the binding + to be pure. + + CR gbury: this allows to move allocations marked as `Must_inline_once` past + function calls (and other effectful expressions), which can break some + allocation-counting tests (the same also applies to allocations marked as + `Must_inline_and_duplicate` but that is more expected). *) + +let remove_binding env var = + { env with bindings = Variable.Map.remove var env.bindings } + +type split_result = + | Already_split + | Split of + { new_bindings : any_binding list; + split_binding : complex binding + } + +let new_bindings_for_splitting order args = + let (new_bindings, _), new_cmm_args = + List.fold_left_map + (fun (new_bindings, order) (cmm_arg, arg_effs) -> + (* CR gbury: here, instead of using [is_cmm_simple], we could instead + look at [arg_effs] and not create a new binding if it has + `pure_can_be_duplicated` effects (or any ece that allows + duplication). *) + if is_cmm_simple cmm_arg + then (new_bindings, order), cmm_arg + else + (* we need to rebind the argument *) + (* CR gbury: we should try and store the flambda/cmm variable + initially associated to this expression when it was built (and + before it was inlined during the to_cmm translation), instead of + using a fresh one here. *) + let new_cmm_var = + Backend_var.With_provenance.create ?provenance:None + (Backend_var.create_local + (Format.asprintf "to_cmm_split_%d" order)) + in + let binding = + Binding + { order; + effs = arg_effs; + inline = Do_not_inline; + bound_expr = Simple { cmm_expr = cmm_arg }; + cmm_var = new_cmm_var + } + in + ( (binding :: new_bindings, order - 1), + C.var (Backend_var.With_provenance.var new_cmm_var) )) + ([], order - 1) + args + in + new_bindings, new_cmm_args + +let rebuild_prim ~dbg ~env ~res prim args = + let extra_info, res, cmm = + match (prim, args : Flambda_primitive.Without_args.t * _) with + | Nullary nullary, [] -> env.trans_prim.nullary env res dbg nullary + | Unary unary, [x] -> env.trans_prim.unary env res dbg unary x + | Binary binary, [x; y] -> env.trans_prim.binary env res dbg binary x y + | Ternary ternary, [x; y; z] -> + env.trans_prim.ternary env res dbg ternary x y z + | Variadic variadic, args -> + env.trans_prim.variadic env res dbg variadic args + | (Nullary _ | Unary _ | Binary _ | Ternary _), _ -> + Misc.fatal_errorf + "Mismatched arity when splitting a binding in to_cmm_env:@\n%a@\n%a" + Flambda_primitive.Without_args.print prim + (Format.pp_print_list Printcmm.expression) + args + in + (* CR gbury: this assert should currently hold, as 1) very few primitives + actually generate an [extra_info], 2) very few primitives are marked as + must_inline, and 3) these two do not overlap. However, we could relax that + restriction in the future, and record the extra_info adequately. *) + (match extra_info with + | None -> () + | Some extra_info -> + Misc.fatal_errorf + "Unexpected extra_info in to_cmm_env during prim_rebuild:@\n\ + %a@ in@\n\ + %a(%a)[%a]" + print_extra_info extra_info P.Without_args.print prim + (Format.pp_print_list Printcmm.expression) + args Debuginfo.print_compact dbg); + cmm, res + +let split_complex_binding ~env ~res (binding : complex binding) = + match binding.bound_expr with + | Split _ -> res, Already_split + | Splittable_prim { dbg; prim; args } -> + let new_bindings, new_cmm_args = + new_bindings_for_splitting binding.order args + in + let new_cmm_expr, res = rebuild_prim ~dbg ~env ~res prim new_cmm_args in + let prim_effects = + Flambda_primitive.Without_args.effects_and_coeffects prim + in + (* See CR above about effects and coeffets of 'must_inline' primitives *) + let effs = + match To_cmm_effects.classify_by_effects_and_coeffects prim_effects with + | Pure | Generative_immutable -> Ece.pure_can_be_duplicated + | Effect | Coeffect_only -> + Misc.fatal_errorf + "Primitive %a was marked as `must_inline`, but is has the following \ + effects and coeffects: %a. This would lead to errors when moving \ + the primitive application to substitute it." + Flambda_primitive.Without_args.print prim Ece.print prim_effects + in + let split_binding = + { order = binding.order; + effs; + inline = binding.inline; + bound_expr = Split { cmm_expr = new_cmm_expr }; + cmm_var = binding.cmm_var + } in - env, binding + res, Split { new_bindings; split_binding } + +(* Adding binding to the env and split them *) -let bind_variable0 ?extra env var ~effects_and_coeffects_of_defining_expr:effs - ~may_inline ~defining_expr = - let env, binding = - create_binding ?extra env ~may_inline effs var defining_expr +let rec add_binding_to_env ?extra env res var (Binding binding as b) = + let env = + let bindings = Variable.Map.add var b env.bindings in + let cmm_expr = C.var (Backend_var.With_provenance.var binding.cmm_var) in + let vars = Variable.Map.add var cmm_expr env.vars in + let vars_extra = + match extra with + | None -> env.vars_extra + | Some info -> Variable.Map.add var info env.vars_extra + in + { env with bindings; vars; vars_extra } in - if may_inline && is_inlinable_box effs ~extra - then - (* CR-someday lmaurer: This violates our rule about not moving allocations - past function calls. We should either fix it (not clear how) or be rid of - that rule. *) - { env with pures = Variable.Map.add var binding env.pures } - else - match To_cmm_effects.classify_by_effects_and_coeffects effs with - | Pure -> { env with pures = Variable.Map.add var binding env.pures } - | Effect -> { env with stages = Effect (var, binding) :: env.stages } + let classification = + To_cmm_effects.classify_by_effects_and_coeffects binding.effs + in + let inline : _ inline = binding.inline in + match inline with + | Must_inline_and_duplicate -> ( + (* Bindings containing expressions that have effects/coeffects must be split + at creation time, to ensure that the effectful/coeffectful expressions go + on the stage stack (whereas the `must_inline_and_duplicate` bindings are + *not* on the stage stack). + + Note that it would be correct to split all `must_inline_and_duplicate` + bindings, regardless of its effects. However, we will always need to + split some bindings late (particularly `must_inline_once` bindings), so + always splitting `must_inline_and_duplicate` would not simplify the rest + of the code much. *) + match classification with + | Pure | Generative_immutable -> env, res + | Coeffect_only | Effect -> + let env, res, _ = split_in_env env res var (binding : complex binding) in + env, res) + | May_inline_once | Must_inline_once | Do_not_inline -> ( + match classification with + | Pure -> env, res + | Generative_immutable -> ( + match inline with + | Must_inline_once -> env, res + | May_inline_once | Do_not_inline -> + (* Generative expressions not marked as `must_inline` are treated as + having effects, since function from the `Gc` module can read counters + that are increased by allocations. *) + { env with stages = Effect var :: env.stages }, res + | Must_inline_and_duplicate -> assert false (* impossible to reach *)) + | Effect -> { env with stages = Effect var :: env.stages }, res | Coeffect_only -> let stages = match env.stages with - | Coeffect_only bindings :: stages -> + | Coeffect_only vars :: stages -> (* Multiple coeffect-only bindings may be accumulated in the same stage. *) - Coeffect_only (Variable.Map.add var binding bindings) :: stages + Coeffect_only (Variable.Set.add var vars) :: stages | [] | Effect _ :: _ -> - Coeffect_only (Variable.Map.singleton var binding) :: env.stages + Coeffect_only (Variable.Set.singleton var) :: env.stages in - { env with stages } - -let bind_variable ?extra env v - ~(num_normal_occurrences_of_bound_vars : _ Or_unknown.t) - ~effects_and_coeffects_of_defining_expr ~defining_expr = - let[@inline] bind_variable0 ~may_inline = - bind_variable0 env v ?extra ~effects_and_coeffects_of_defining_expr - ~may_inline ~defining_expr + { env with stages }, res) + +(* CR gbury: find a better name for this function *) +and split_in_env env res var binding = + let res, split_result = split_complex_binding ~env ~res binding in + match split_result with + | Already_split -> env, res, binding + | Split { new_bindings; split_binding } -> + let env = + (* for duplicated bindings, we need to replace the original splittable + binding with the new split binding in the bindings map of the env *) + match split_binding.inline with + | Must_inline_once -> env + | Must_inline_and_duplicate -> + { env with + bindings = Variable.Map.add var (Binding split_binding) env.bindings + } + in + let env, res = + List.fold_left + (fun (env, res) new_binding -> + let flambda_var = Variable.create "to_cmm_tmp" in + add_binding_to_env env res flambda_var new_binding) + (env, res) new_bindings + in + env, res, split_binding + +let bind_variable_with_decision (type a) ?extra env res var ~inline + ~(defining_expr : a bound_expr) ~effects_and_coeffects_of_defining_expr:effs + = + let effs = + let classification = + To_cmm_effects.classify_by_effects_and_coeffects effs + in + match[@ocaml.warning "-4"] (inline : a inline), classification with + | (Must_inline_once | Must_inline_and_duplicate), Generative_immutable -> ( + (* Effects (including generative immutbale effects) can severly limit the + inlining of bindings (due to the + [~consider_inlining_effectful_expressions]). See CR above for a more + lengthy explanation. + + Therefore, we try and "forget" generative effects here. This is + reasonable since the only reason that `Generative_immutable' effects + are considered effects is to prevent allocations from being moved + across a `Gc` function call (and the main point of that is to not + invalidate allocation tests). We consider that the Delay placement on a + allocating primitive explicitly allows re-ordering past `Gc` function + calls, and therefore it is correct to ignore the generative effects; we + also do that when computing the effects after splitting a binding (see + [split_complex_binding]). + + Note that in some cases, there might be situations where an allocation + with Strict placement might be inlined inside a Delay allocation, and + end up moved across a `Gc` function call beause of this. Such cases are + currently impossible since only [Box_number] and [Project_value_slot] + have a Delay placement, but may appear in the future if/when some more + primitives are marked as `Delay`. But even then, the only issue would + be that some allocations would be accidentally re-ordered across `Gc` + function calls. + + Lastly, even if the primitive/top of the cmm expr being bound, must be + duplicated (as specified by [inline]), that doesn't mean that its + arguments (some of which may have been inlined) are also duplicatable, + so we must take care of only downgrading the effects and coeffects to + pure, and not the placement, which must be kept. *) + match (effs : Ece.t) with + | _, _, Delay -> Ece.pure_can_be_duplicated + | _, _, Strict -> Ece.pure) + | _, _ -> effs + in + let binding = create_binding ~inline effs var defining_expr in + add_binding_to_env ?extra env res var binding + +let bind_variable ?extra env res var ~defining_expr + ~num_normal_occurrences_of_bound_vars + ~effects_and_coeffects_of_defining_expr = + let inline = + To_cmm_effects.classify_let_binding var + ~effects_and_coeffects_of_defining_expr + ~num_normal_occurrences_of_bound_vars in - match num_normal_occurrences_of_bound_vars with - | Unknown -> bind_variable0 ~may_inline:false - | Known num_normal_occurrences_of_bound_vars -> ( - match - To_cmm_effects.classify_let_binding v - ~effects_and_coeffects_of_defining_expr - ~num_normal_occurrences_of_bound_vars - with - | Drop_defining_expr -> env - | May_inline -> bind_variable0 ~may_inline:true - | Regular -> bind_variable0 ~may_inline:false) + match inline with + | Drop_defining_expr -> env, res + | Regular -> + let defining_expr = simple defining_expr in + bind_variable_with_decision ?extra env res var + ~effects_and_coeffects_of_defining_expr ~defining_expr + ~inline:Do_not_inline + | May_inline_once -> + let defining_expr = simple defining_expr in + bind_variable_with_decision ?extra env res var + ~effects_and_coeffects_of_defining_expr ~defining_expr + ~inline:May_inline_once + | Must_inline_once -> + let defining_expr = complex_no_split defining_expr in + bind_variable_with_decision ?extra env res var + ~effects_and_coeffects_of_defining_expr ~defining_expr + ~inline:Must_inline_once + | Must_inline_and_duplicate -> + let defining_expr = complex_no_split defining_expr in + bind_variable_with_decision ?extra env res var + ~effects_and_coeffects_of_defining_expr ~defining_expr + ~inline:Must_inline_and_duplicate + +let bind_variable_to_primitive = bind_variable_with_decision (* Variable lookup (for potential inlining) *) -let will_inline env binding = binding.cmm_expr, env, binding.effs - -let will_not_inline env binding = - C.var (Backend_var.With_provenance.var binding.cmm_var), env, Ece.pure +let will_inline_simple env res { effs; bound_expr = Simple { cmm_expr }; _ } = + cmm_expr, env, res, effs + +let will_inline_complex env res { effs; bound_expr; _ } = + match bound_expr with + | Split { cmm_expr } -> cmm_expr, env, res, effs + | Splittable_prim { dbg; prim; args } -> + let cmm_expr, res = rebuild_prim ~dbg ~env ~res prim (List.map fst args) in + cmm_expr, env, res, effs + +let will_not_inline_simple env res { cmm_var; bound_expr = Simple _; _ } = + ( C.var (Backend_var.With_provenance.var cmm_var), + env, + res, + Ece.pure_can_be_duplicated ) + +let split_and_inline env res var binding = + let env, res, split_binding = split_in_env env res var binding in + will_inline_complex env res split_binding + +let pop_if_in_top_stage ?consider_inlining_effectful_expressions env var = + match env.stages with + | [] -> None + | Effect var_from_stage :: prev_stages -> + (* In this case [var_from_stage] corresponds to an effectful binding forming + the most recent stage. We also know that [var] doesn't have an available + pure defining expression (either because that expression isn't pure, or + because the corresponding binding has already been flushed). As such, we + can't move the defining expression for [var] past that of + [var_from_stage], in the case where these variables are different. + However if these two variables are in fact the same, we can consider + inlining the defining expression. *) + let consider_inlining_effectful_expressions = + match consider_inlining_effectful_expressions with + | Some consider -> consider + | None -> Flambda_features.Expert.inline_effects_in_cmm () + in + if Variable.equal var var_from_stage + && consider_inlining_effectful_expressions + then Some { env with stages = prev_stages } + else None + | Coeffect_only vars_from_stage :: prev_stages -> + (* Here we see if [var] has a coeffect-only defining expression on the most + recent stage. If so, then we can commute it with any other expression on + the stage, since they all only have coeffects. The defining expression + for [var] may then be considered for inlining. *) + if Variable.Set.mem var vars_from_stage + then + let new_vars_in_stage = Variable.Set.remove var vars_from_stage in + let stages = + if Variable.Set.is_empty new_vars_in_stage + then prev_stages + else Coeffect_only new_vars_in_stage :: prev_stages + in + Some { env with stages } + else None -let will_not_inline_var env v = - (* This is like [will_not_inline] but is used in the case where no delayed - [binding] is available. A preallocated [Cvar] expression will be used. *) - match Variable.Map.find v env.vars with - | exception Not_found -> - Misc.fatal_errorf "Variable %a not found in env" Variable.print v - | e -> e, env, Ece.pure - -let inline_variable ?consider_inlining_effectful_expressions env var = - match Variable.Map.find var env.pures with - | binding -> - if not binding.may_inline - then will_not_inline env binding - else - (* Pure bindings may be inlined at most once. *) - let pures = Variable.Map.remove var env.pures in - will_inline { env with pures } binding +let inline_variable ?consider_inlining_effectful_expressions env res var = + match Variable.Map.find var env.bindings with | exception Not_found -> ( - match env.stages with - | [] -> will_not_inline_var env var - | Effect (var_from_stage, binding) :: prev_stages -> - (* In this case [var_from_stage] corresponds to an effectful binding - forming the most recent stage. We also know that [var] doesn't have an - available pure defining expression (either because that expression - isn't pure, or because the corresponding binding has already been - flushed). As such, we can't move the defining expression for [var] past - that of [var_from_stage], in the case where these variables are - different. However if these two variables are in fact the same, we can - consider inlining the defining expression. *) - let consider_inlining_effectful_expressions = - match consider_inlining_effectful_expressions with - | Some consider -> consider - | None -> Flambda_features.Expert.inline_effects_in_cmm () - in - if not (Variable.equal var var_from_stage) - then will_not_inline_var env var - else if binding.may_inline && consider_inlining_effectful_expressions - then will_inline { env with stages = prev_stages } binding - else will_not_inline env binding - | Coeffect_only coeffects :: prev_stages -> ( - (* Here we see if [var] has a coeffect-only defining expression on the - most recent stage. If so, then we can commute it with any other - expression on the stage, since they all only have coeffects. The - defining expression for [var] may then be considered for inlining. *) - match Variable.Map.find var coeffects with - | exception Not_found -> will_not_inline_var env var - | binding -> - if not binding.may_inline - then will_not_inline env binding - else - let coeffects = Variable.Map.remove var coeffects in - let env = - if Variable.Map.is_empty coeffects - then { env with stages = prev_stages } - else { env with stages = Coeffect_only coeffects :: prev_stages } - in - will_inline env binding)) + (* this happens for continuation parameters and bindings that have been + flushed *) + match Variable.Map.find var env.vars with + | exception Not_found -> + Misc.fatal_errorf "Variable %a not found in env" Variable.print var + | e -> + (* the env.vars map only contain bindings to expressions of the form + [Cmm.Cvar _], hence the effects. *) + e, env, res, Ece.pure_can_be_duplicated) + | Binding binding -> ( + match binding.inline with + | Do_not_inline -> will_not_inline_simple env res binding + | Must_inline_and_duplicate -> split_and_inline env res var binding + | Must_inline_once -> ( + let env = remove_binding env var in + match To_cmm_effects.classify_by_effects_and_coeffects binding.effs with + | Pure | Generative_immutable -> will_inline_complex env res binding + | Effect | Coeffect_only -> ( + match + pop_if_in_top_stage ?consider_inlining_effectful_expressions env var + with + | None -> split_and_inline env res var binding + | Some env -> will_inline_complex env res binding)) + | May_inline_once -> ( + match To_cmm_effects.classify_by_effects_and_coeffects binding.effs with + | Pure -> + let env = remove_binding env var in + will_inline_simple env res binding + | Generative_immutable | Effect | Coeffect_only -> ( + match + pop_if_in_top_stage ?consider_inlining_effectful_expressions env var + with + | None -> will_not_inline_simple env res binding + | Some env -> + let env = remove_binding env var in + will_inline_simple env res binding))) (* Flushing delayed bindings *) @@ -362,36 +792,99 @@ module M = Map.Make (struct let compare x y = compare y x end) -let order_add b acc = M.add b.order b acc +type flush_mode = + | Entering_loop + | Branching_point + | Flush_everything -let order_add_map m acc = - Variable.Map.fold (fun _ b acc -> order_add b acc) m acc - -let flush_delayed_lets ?(entering_loop = false) env = +let flush_delayed_lets ~mode env res = (* Generate a wrapper function to introduce the delayed let-bindings. *) - let flush pures stages e = - let order_map = order_add_map pures M.empty in - let order_map = - List.fold_left - (fun acc -> function - | Effect (_, b) -> order_add b acc - | Coeffect_only m -> order_add_map m acc) - order_map stages - in + let wrap_flush order_map e = M.fold - (fun _ b acc -> - Cmm_helpers.letin b.cmm_var ~defining_expr:b.cmm_expr ~body:acc) + (fun _ (Binding b) acc -> + match b.bound_expr with + | Splittable_prim _ -> + Misc.fatal_errorf + "Complex bindings should have been split prior to being flushed." + | Split { cmm_expr } | Simple { cmm_expr } -> + Cmm_helpers.letin b.cmm_var ~defining_expr:cmm_expr ~body:acc) order_map e in - (* Unless entering a loop, only pure bindings that definitely cannot be - inlined are flushed now. The remainder are preserved, ensuring that the - corresponding expressions are sunk down as far as possible. *) (* CR-someday mshinwell: work out a criterion for allowing substitutions into - loops. *) - let pures_to_keep, pures_to_flush = - if entering_loop - then Variable.Map.empty, env.pures - else Variable.Map.partition (fun _ binding -> binding.may_inline) env.pures + loops. CR gbury: this is now done by creating a binding with the inline + status `Must_inline_and_duplicate`, so the caller of `to_cmm_env` has to + make that decision of whether to substitute inside loops. *) + let res = ref res in + let bindings_to_flush = ref M.empty in + let flush (Binding b as binding) = + if M.mem b.order !bindings_to_flush + then Misc.fatal_errorf "Duplicate order for bindings when flushing"; + bindings_to_flush := M.add b.order binding !bindings_to_flush + in + let bindings_to_keep = + Variable.Map.filter_map + (fun _ (Binding b as binding) -> + match b.inline with + | Do_not_inline -> + flush binding; + None + | Must_inline_and_duplicate -> ( + let r, split_res = split_complex_binding ~env ~res:!res b in + res := r; + let split_binding = + match split_res with + | Already_split -> binding + | Split { new_bindings; split_binding } -> + List.iter flush new_bindings; + Binding split_binding + in + match mode with + | Flush_everything -> + flush split_binding; + None + | Branching_point | Entering_loop -> Some split_binding) + | Must_inline_once -> ( + match + mode, To_cmm_effects.classify_by_effects_and_coeffects b.effs + with + (* when not entering a loop, and with pure/generative effects at most, + we can wait to split the binding, so that we can have a chance to + try and push the arguments down the branch (otherwise, when we + split, the arguments of the splittable binding would be flushed + before the branch in control flow). *) + | Branching_point, (Pure | Generative_immutable) -> Some binding + | ( (Branching_point | Entering_loop | Flush_everything), + (Pure | Generative_immutable | Coeffect_only | Effect) ) -> ( + let r, split_res = split_complex_binding ~env ~res:!res b in + res := r; + let split_binding = + match split_res with + | Already_split -> binding + | Split { new_bindings; split_binding } -> + List.iter flush new_bindings; + Binding split_binding + in + match mode with + | Flush_everything -> + flush split_binding; + None + | Branching_point | Entering_loop -> Some split_binding)) + | May_inline_once -> ( + match To_cmm_effects.classify_by_effects_and_coeffects b.effs with + (* Unless entering a loop, we do not flush pure bindings that can be + inlined, ensuring that the corresponding expressions are sunk down + as far as possible, including past control flow branching + points. *) + | Pure -> ( + match mode with + | Flush_everything | Entering_loop -> + flush binding; + None + | Branching_point -> Some binding) + | Generative_immutable | Coeffect_only | Effect -> + flush binding; + None)) + env.bindings in - let flush e = flush pures_to_flush env.stages e in - flush, { env with stages = []; pures = pures_to_keep } + let flush e = wrap_flush !bindings_to_flush e in + flush, { env with stages = []; bindings = bindings_to_keep }, !res diff --git a/middle_end/flambda2/to_cmm/to_cmm_env.mli b/middle_end/flambda2/to_cmm/to_cmm_env.mli index 482cf56411f..f75cb9d43ad 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_env.mli +++ b/middle_end/flambda2/to_cmm/to_cmm_env.mli @@ -18,10 +18,52 @@ (** Environment for Flambda to Cmm translation *) type t +(** Printing function *) +val print : Format.formatter -> t -> unit + +(** Extra information about bound variables, used for optimisation. *) +type extra_info = + | Untag of Cmm.expression + (** The variable is bound to the result of untagging the given Cmm + expression. This allows to obtain the Cmm expression as it was before + untagging. *) + +(** Record of all primitive translation functions, to avoid a cyclic + dependency. *) +type prim_res = extra_info option * To_cmm_result.t * Cmm.expression + +type ('env, 'prim, 'arity) prim_helper = + 'env -> To_cmm_result.t -> Debuginfo.t -> 'prim -> 'arity + +type 'env trans_prim = + { nullary : ('env, Flambda_primitive.nullary_primitive, prim_res) prim_helper; + unary : + ( 'env, + Flambda_primitive.unary_primitive, + Cmm.expression -> prim_res ) + prim_helper; + binary : + ( 'env, + Flambda_primitive.binary_primitive, + Cmm.expression -> Cmm.expression -> prim_res ) + prim_helper; + ternary : + ( 'env, + Flambda_primitive.ternary_primitive, + Cmm.expression -> Cmm.expression -> Cmm.expression -> prim_res ) + prim_helper; + variadic : + ( 'env, + Flambda_primitive.variadic_primitive, + Cmm.expression list -> prim_res ) + prim_helper + } + (** Create an environment for translating a toplevel expression. *) val create : Exported_offsets.t -> Exported_code.t -> + trans_prim:t trans_prim -> return_continuation:Continuation.t -> exn_continuation:Continuation.t -> t @@ -57,24 +99,17 @@ val exported_offsets : t -> Exported_offsets.t (** {2 Variable bindings} *) -(** Extra information about bound variables, used for optimisation. *) -type extra_info = - | Untag of Cmm.expression - (** The variable is bound to the result of untagging the given Cmm - expression. This allows to obtain the Cmm expression as it was before - untagging. *) - | Boxed_number (** The variable is bound to a boxed number. *) - (** Create (and bind) a Cmm variable for the given Flambda variable, returning the new environment and the created variable. Will produce a fatal error if the given variable is already bound. *) -val create_variable : t -> Variable.t -> t * Backend_var.With_provenance.t +val create_bound_parameter : + t -> Variable.t -> t * Backend_var.With_provenance.t (** Same as {!create_variable} but for a list of variables. *) -val create_variables : +val create_bound_parameters : t -> Variable.t list -> t * Backend_var.With_provenance.t list -(** Delayed let-bindings +(** {2 Delayed let-bindings} Let-bindings are delayed in a certain way to allow for potential reordering and inlining of the defining expressions of bound variables that are used @@ -120,31 +155,92 @@ val create_variables : Other bindings are delayed until they are explicitly flushed. Exactly which bindings get flushed at different points, for example prior to function calls or branching control flow, depends on decisions outside of this module - (e.g. in [To_cmm_expr]). *) + (e.g. in [To_cmm_expr]). + + Additionally, bindings that must be inlined must be treated with special + care. Most notably, most of the time, we are in the case of a binding "let x + = prim(args)" where the primitive 'prim' is marked as `Delay`, which we + translate as Must_inline. In such cases, we want to inline the primitive + itself, but not necessarily its arguments. To correctly handle such cases, + we have a notion of "complex" bound argument that, in addition to a cmm + expression, also contains the arguments and a way to re-build the + expression. *) + +(** Some uniques and different types *) +type simple = Simple + +type complex = Complex + +(** Inlining decision of bound expressions *) +type _ inline = + | Do_not_inline : simple inline + | May_inline_once : simple inline + | Must_inline_once : complex inline + | Must_inline_and_duplicate : complex inline + (** Akin to systematic substitutions, it should not be used for + (co)effectful expressions *) + +(** The type of expression that can be bound. *) +type _ bound_expr + +(** A simple cmm bound expression *) +val simple : Cmm.expression -> simple bound_expr + +(** A bound expr that can be split if needed. This is used for primitives that + must be inlined, but whose arguments may not be inlinable or duplicable, so + that we can split the expression to be inlined from its arguments if/when + needed. The effects that are passed must correspond respectively to each + individual argument and to the primitive itself. *) +val splittable_primitive : + Debuginfo.t -> + Flambda_primitive.Without_args.t -> + (Cmm.expression * Effects_and_coeffects.t) list -> + complex bound_expr + +(** Bind a variable, with support for splitting duplicatable primitives with + non-duplicatable arguments. *) +val bind_variable_to_primitive : + ?extra:extra_info -> + t -> + To_cmm_result.t -> + Variable.t -> + inline:'a inline -> + defining_expr:'a bound_expr -> + effects_and_coeffects_of_defining_expr:Effects_and_coeffects.t -> + t * To_cmm_result.t (** Bind a variable to the given Cmm expression, to allow for delaying the let-binding. *) val bind_variable : ?extra:extra_info -> t -> + To_cmm_result.t -> Variable.t -> - num_normal_occurrences_of_bound_vars: - Num_occurrences.t Variable.Map.t Or_unknown.t -> - effects_and_coeffects_of_defining_expr:Effects_and_coeffects.t -> defining_expr:Cmm.expression -> - t + num_normal_occurrences_of_bound_vars:Num_occurrences.t Variable.Map.t -> + effects_and_coeffects_of_defining_expr:Effects_and_coeffects.t -> + t * To_cmm_result.t (** Try and inline an Flambda variable using the delayed let-bindings. *) val inline_variable : ?consider_inlining_effectful_expressions:bool -> t -> + To_cmm_result.t -> Variable.t -> - Cmm.expression * t * Effects_and_coeffects.t + Cmm.expression * t * To_cmm_result.t * Effects_and_coeffects.t + +type flush_mode = + | Entering_loop + | Branching_point + | Flush_everything (** Wrap the given Cmm expression with all the delayed let bindings accumulated in the environment. *) val flush_delayed_lets : - ?entering_loop:bool -> t -> (Cmm.expression -> Cmm.expression) * t + mode:flush_mode -> + t -> + To_cmm_result.t -> + (Cmm.expression -> Cmm.expression) * t * To_cmm_result.t (** Fetch the extra info for a Flambda variable (if any), specified as a [Simple]. *) diff --git a/middle_end/flambda2/to_cmm/to_cmm_expr.ml b/middle_end/flambda2/to_cmm/to_cmm_expr.ml index e0b79fde0c9..890f8fa6d8d 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_expr.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_expr.ml @@ -21,6 +21,7 @@ module K = Flambda_kind module C = struct include Cmm_helpers + include Cmm_builtins include To_cmm_shared end @@ -32,18 +33,19 @@ end (* Bind a Cmm variable to the result of translating a [Simple] into Cmm. *) -let bind_var_to_simple ~dbg env v ~num_normal_occurrences_of_bound_vars s = - let defining_expr, env, effects_and_coeffects_of_defining_expr = - C.simple ~dbg env s +let bind_var_to_simple ~dbg env res v ~num_normal_occurrences_of_bound_vars s = + let defining_expr, env, res, effects_and_coeffects_of_defining_expr = + C.simple ~dbg env res s in - Env.bind_variable env v - ~num_normal_occurrences_of_bound_vars: - (Known num_normal_occurrences_of_bound_vars) - ~effects_and_coeffects_of_defining_expr ~defining_expr + let env, res = + Env.bind_variable env res v ~effects_and_coeffects_of_defining_expr + ~defining_expr ~num_normal_occurrences_of_bound_vars + in + env, res (* Helpers for the translation of [Apply] expressions. *) -let translate_apply0 env apply = +let translate_apply0 env res apply = let callee_simple = Apply.callee apply in let args = Apply.args apply in let dbg = Apply.dbg apply in @@ -52,8 +54,8 @@ let translate_apply0 env apply = effects/coeffects values currently ignored on the following two lines. At the moment they can be ignored as we always deem all calls to have arbitrary effects and coeffects. *) - let callee, env, _ = C.simple ~dbg env callee_simple in - let args, env, _ = C.simple_list ~dbg env args in + let callee, env, res, _ = C.simple ~dbg env res callee_simple in + let args, env, res, _ = C.simple_list ~dbg env res args in let fail_if_probe apply = match Apply.probe_name apply with | None -> () @@ -94,6 +96,7 @@ let translate_apply0 env apply = (C.symbol_from_linkage_name ~dbg code_linkage_name) args, env, + res, Ece.all ) | Some name -> ( C.probe ~dbg ~name @@ -101,6 +104,7 @@ let translate_apply0 env apply = ~args |> C.return_unit dbg, env, + res, Ece.all )) | Function { function_call = Indirect_unknown_arity; alloc_mode } -> fail_if_probe apply; @@ -108,6 +112,7 @@ let translate_apply0 env apply = (Alloc_mode.For_types.to_lambda alloc_mode) callee args, env, + res, Ece.all ) | Function { function_call = Indirect_known_arity { return_arity; param_arity }; @@ -128,6 +133,7 @@ let translate_apply0 env apply = (Alloc_mode.For_types.to_lambda alloc_mode) callee args, env, + res, Ece.all ) | Call_kind.C_call { alloc; return_arity; param_arity; is_c_builtin } -> fail_if_probe apply; @@ -165,21 +171,22 @@ let translate_apply0 env apply = ( wrap dbg (C.extcall ~dbg ~alloc ~is_c_builtin ~returns ~ty_args callee ty args), env, + res, Ece.all ) | Call_kind.Method { kind; obj; alloc_mode } -> fail_if_probe apply; - let obj, env, _ = C.simple ~dbg env obj in + let obj, env, res, _ = C.simple ~dbg env res obj in let kind = Call_kind.Method_kind.to_lambda kind in let alloc_mode = Alloc_mode.For_types.to_lambda alloc_mode in - C.send kind callee obj args (pos, alloc_mode) dbg, env, Ece.all + C.send kind callee obj args (pos, alloc_mode) dbg, env, res, Ece.all (* Function calls that have an exn continuation with extra arguments must be wrapped with assignments for the mutable variables used to pass the extra arguments. *) (* CR mshinwell: Add first-class support in Cmm for the concept of an exception handler with extra arguments. *) -let translate_apply env apply = - let call, env, effs = translate_apply0 env apply in +let translate_apply env res apply = + let call, env, res, effs = translate_apply0 env res apply in let dbg = Apply.dbg apply in let k_exn = Apply.exn_continuation apply in let mut_vars = @@ -188,12 +195,17 @@ let translate_apply env apply = let extra_args = Exn_continuation.extra_args k_exn in if List.compare_lengths extra_args mut_vars = 0 then - let aux (call, env) (arg, _k) v = - let arg, env, _ = C.simple ~dbg env arg in - C.sequence (C.assign v arg) call, env + (* Note wrt evaluation order: this is correct for the same reason as + `To_cmm_shared.simple_list`, namely the first simple translated (and + potentially inlined/substituted) is evaluted last. *) + let aux (call, env, res) (arg, _k) v = + let arg, env, res, _ = C.simple ~dbg env res arg in + C.sequence (C.assign v arg) call, env, res + in + let call, env, res = + List.fold_left2 aux (call, env, res) extra_args mut_vars in - let call, env = List.fold_left2 aux (call, env) extra_args mut_vars in - call, env, effs + call, env, res, effs else Misc.fatal_errorf "Length of [extra_args] in exception continuation %a@ does not match \ @@ -207,7 +219,7 @@ let translate_apply env apply = (* Exception continuations always receive the exception value in their first argument. Additionally, they may have extra arguments that are passed to the handler via mutable variables (expected to be spilled to the stack). *) -let translate_raise env apply exn_handler args = +let translate_raise env res apply exn_handler args = match args with | exn :: extra -> let raise_kind = @@ -220,17 +232,17 @@ let translate_raise env apply exn_handler args = Apply_cont.print apply in let dbg = Apply_cont.debuginfo apply in - let exn, env, _ = C.simple ~dbg env exn in - let extra, env, _ = C.simple_list ~dbg env extra in + let exn, env, res, _ = C.simple ~dbg env res exn in + let extra, env, res, _ = C.simple_list ~dbg env res extra in let mut_vars = Env.get_exn_extra_args env exn_handler in - let wrap, _ = Env.flush_delayed_lets env in + let wrap, _, res = Env.flush_delayed_lets ~mode:Branching_point env res in let cmm = List.fold_left2 (fun expr arg v -> C.sequence (C.assign v arg) expr) (C.raise_prim raise_kind exn dbg) extra mut_vars in - wrap cmm + wrap cmm, res | [] -> Misc.fatal_errorf "Exception continuation %a has no arguments:@ \n%a" Continuation.print exn_handler Apply_cont.print apply @@ -247,8 +259,8 @@ let translate_jump_to_continuation env res apply types cont args = [Cmm.Push cont] in let dbg = Apply_cont.debuginfo apply in - let args, env, _ = C.simple_list ~dbg env args in - let wrap, _ = Env.flush_delayed_lets env in + let args, env, res, _ = C.simple_list ~dbg env res args in + let wrap, _, res = Env.flush_delayed_lets ~mode:Branching_point env res in wrap (C.cexit cont args trap_actions), res else Misc.fatal_errorf "Types (%a) do not match arguments of@ %a" @@ -257,15 +269,15 @@ let translate_jump_to_continuation env res apply types cont args = (* A call to the return continuation of the current block simply is the return value for the current block being translated. *) -let translate_jump_to_return_continuation env apply return_cont args = +let translate_jump_to_return_continuation env res apply return_cont args = match args with | [return_value] -> ( let dbg = Apply_cont.debuginfo apply in - let return_value, env, _ = C.simple ~dbg env return_value in - let wrap, _ = Env.flush_delayed_lets env in + let return_value, env, res, _ = C.simple ~dbg env res return_value in + let wrap, _, res = Env.flush_delayed_lets ~mode:Branching_point env res in match Apply_cont.trap_action apply with - | None -> wrap return_value - | Some (Pop _) -> wrap (C.trap_return return_value [Cmm.Pop]) + | None -> wrap return_value, res + | Some (Pop _) -> wrap (C.trap_return return_value [Cmm.Pop]), res | Some (Push _) -> Misc.fatal_errorf "Return continuation %a should not be applied with a Push trap action" @@ -289,37 +301,83 @@ let rec expr env res e = | Switch e' -> switch env res e' | Invalid { message } -> C.invalid res ~message +and let_prim env res ~num_normal_occurrences_of_bound_vars v p dbg body = + let v = Bound_var.var v in + let effects_and_coeffects_of_prim = + Flambda_primitive.effects_and_coeffects p + in + let inline = + To_cmm_effects.classify_let_binding v ~num_normal_occurrences_of_bound_vars + ~effects_and_coeffects_of_defining_expr:effects_and_coeffects_of_prim + in + let simple_case (inline : Env.simple Env.inline) = + let defining_expr, extra, env, res, args_effs = + To_cmm_primitive.prim_simple env res dbg p + in + let effects_and_coeffects_of_defining_expr = + Ece.join args_effs effects_and_coeffects_of_prim + in + let env, res = + Env.bind_variable_to_primitive ?extra env res v ~inline + ~effects_and_coeffects_of_defining_expr ~defining_expr + in + expr env res body + in + let complex_case (inline : Env.complex Env.inline) = + let defining_expr, env, res, args_effs = + To_cmm_primitive.prim_complex env res dbg p + in + let effects_and_coeffects_of_defining_expr = + Ece.join args_effs effects_and_coeffects_of_prim + in + let env, res = + Env.bind_variable_to_primitive env res v ~inline + ~effects_and_coeffects_of_defining_expr ~defining_expr + in + expr env res body + in + match inline with + (* It can be useful to translate a dropped expression because it allows to + inline (and thus remove from the env) the arguments in it. *) + | Drop_defining_expr | Regular -> simple_case Do_not_inline + | May_inline_once -> simple_case May_inline_once + | Must_inline_once -> complex_case Must_inline_once + | Must_inline_and_duplicate -> complex_case Must_inline_and_duplicate + and let_expr0 env res let_expr (bound_pattern : Bound_pattern.t) ~num_normal_occurrences_of_bound_vars ~body = - match bound_pattern, Let.defining_expr let_expr with + match[@warning "-4"] bound_pattern, Let.defining_expr let_expr with | Singleton v, Simple s -> let v = Bound_var.var v in (* CR mshinwell: Try to get a proper [dbg] here (although the majority of these bindings should have been substituted out). *) let dbg = Debuginfo.none in - let env = - bind_var_to_simple ~dbg env v ~num_normal_occurrences_of_bound_vars s + let env, res = + bind_var_to_simple ~dbg env res v ~num_normal_occurrences_of_bound_vars s in expr env res body | Singleton _, Prim (p, _) when (not (Flambda_features.stack_allocation_enabled ())) && Flambda_primitive.is_begin_or_end_region p -> expr env res body - | Singleton v, Prim (p, dbg) -> - let v = Bound_var.var v in - let defining_expr, extra, env, res, effs = - To_cmm_primitive.prim env res dbg p - in - let effects_and_coeffects_of_defining_expr = - Ece.join effs (Flambda_primitive.effects_and_coeffects p) + | Singleton v, Prim ((Unary (End_region, _) as p), dbg) -> + (* CR gbury: this is a hack to prevent moving of expressions past an + End_region. We have to do this manually because we currently have effects + and coeffects that are not precise enough. Particularly, an immutable + load of a locally allocated block is considered as pure, and thus can be + moved past an end_region. Here we also need to flush everything, + including must_inline bindings, particularly projections that may project + from locally allocated closures (and that must not be moved past an + end_region). *) + let wrap, env, res = + Env.flush_delayed_lets ~mode:Flush_everything env res in - let env = - Env.bind_variable ?extra env v - ~num_normal_occurrences_of_bound_vars: - (Known num_normal_occurrences_of_bound_vars) - ~effects_and_coeffects_of_defining_expr ~defining_expr + let cmm, res = + let_prim env res ~num_normal_occurrences_of_bound_vars v p dbg body in - expr env res body + wrap cmm, res + | Singleton v, Prim (p, dbg) -> + let_prim env res ~num_normal_occurrences_of_bound_vars v p dbg body | Set_of_closures bound_vars, Set_of_closures soc -> To_cmm_set_of_closures.let_dynamic_set_of_closures env res ~body ~bound_vars ~num_normal_occurrences_of_bound_vars soc ~translate_expr:expr @@ -333,7 +391,9 @@ and let_expr0 env res let_expr (bound_pattern : Bound_pattern.t) match update_opt with | None -> expr env res body | Some update -> - let wrap, env = Env.flush_delayed_lets env in + let wrap, env, res = + Env.flush_delayed_lets ~mode:Branching_point env res + in let body, res = expr env res body in wrap (C.sequence update body), res) | Singleton _, Rec_info _ -> expr env res body @@ -393,7 +453,7 @@ and let_cont_not_inlined env res k handler body = (* CR gbury: "split" the environment according to which variables the handler and the body uses, to allow for inlining to proceed within each expression. *) - let wrap, env = Env.flush_delayed_lets env in + let wrap, env, res = Env.flush_delayed_lets ~mode:Branching_point env res in let is_exn_handler = Continuation_handler.is_exn_handler handler in let vars, arity, handler, res = continuation_handler env res handler in let catch_id, env = @@ -475,7 +535,7 @@ and let_cont_rec env res conts body = occurrence) *) (* CR-someday mshinwell: As discussed, the tradeoff here is not clear, since flushing might increase register pressure. *) - let wrap, env = Env.flush_delayed_lets ~entering_loop:true env in + let wrap, env, res = Env.flush_delayed_lets ~mode:Entering_loop env res in (* Compute the environment for Ccatch ids *) let conts_to_handlers = Continuation_handlers.to_map conts in let env = @@ -520,7 +580,7 @@ and continuation_handler env res handler = vars, arity, expr, res) and apply_expr env res apply = - let call, env, effs = translate_apply env apply in + let call, env, res, effs = translate_apply env res apply in (* With respect to flushing the environment we have three cases: 1. The call never returns or jumps to another function @@ -544,11 +604,11 @@ and apply_expr env res apply = match Apply.continuation apply with | Never_returns -> (* Case 1 *) - let wrap, _ = Env.flush_delayed_lets env in + let wrap, _, res = Env.flush_delayed_lets ~mode:Branching_point env res in wrap call, res | Return k when Continuation.equal (Env.return_continuation env) k -> (* Case 1 *) - let wrap, _ = Env.flush_delayed_lets env in + let wrap, _, res = Env.flush_delayed_lets ~mode:Branching_point env res in wrap call, res | Return k -> ( let[@inline always] unsupported () = @@ -560,42 +620,35 @@ and apply_expr env res apply = Continuation.print k Apply.print apply in match Env.get_continuation env k with - | Jump { param_types = []; cont } -> - (* Case 2 *) - let wrap, _ = Env.flush_delayed_lets env in - wrap (C.sequence call (C.cexit cont [] [])), res + | Jump { param_types = []; cont = _ } -> unsupported () | Jump { param_types = [_]; cont } -> (* Case 2 *) - let wrap, _ = Env.flush_delayed_lets env in + let wrap, _, res = Env.flush_delayed_lets ~mode:Branching_point env res in wrap (C.cexit cont [call] []), res | Inline { handler_params; handler_body = body; handler_params_occurrences } - -> + -> ( (* Case 3 *) let handler_params = Bound_parameters.to_list handler_params in - let var, num_normal_occurrences_of_bound_vars = - match handler_params with - | [] -> - let var = Variable.create "*apply_res*" in - var, Variable.Map.singleton var Num_occurrences.Zero - | [param] -> Bound_parameter.var param, handler_params_occurrences - | _ :: _ -> unsupported () - in - let env = - Env.bind_variable env var - ~num_normal_occurrences_of_bound_vars: - (Known num_normal_occurrences_of_bound_vars) - ~effects_and_coeffects_of_defining_expr:effs ~defining_expr:call - in - expr env res body + match handler_params with + | [] -> unsupported () + | [param] -> + let var = Bound_parameter.var param in + let env, res = + Env.bind_variable env res var + ~effects_and_coeffects_of_defining_expr:effs ~defining_expr:call + ~num_normal_occurrences_of_bound_vars:handler_params_occurrences + in + expr env res body + | _ :: _ -> unsupported ()) | Jump _ -> unsupported ()) and apply_cont env res apply_cont = let k = Apply_cont.continuation apply_cont in let args = Apply_cont.args apply_cont in if Env.is_exn_handler env k - then translate_raise env apply_cont k args, res + then translate_raise env res apply_cont k args else if Continuation.equal (Env.return_continuation env) k - then translate_jump_to_return_continuation env apply_cont k args, res + then translate_jump_to_return_continuation env res apply_cont k args else match Env.get_continuation env k with | Jump { param_types; cont } -> @@ -610,15 +663,15 @@ and apply_cont env res apply_cont = let handler_params = Bound_parameters.to_list handler_params in if List.compare_lengths args handler_params = 0 then - let env = + let env, res = List.fold_left2 - (fun env param -> + (fun (env, res) param -> bind_var_to_simple ~dbg:(Apply_cont.debuginfo apply_cont) - env + env res (Bound_parameter.var param) ~num_normal_occurrences_of_bound_vars:handler_params_occurrences) - env handler_params args + (env, res) handler_params args in expr env res handler_body else @@ -631,7 +684,7 @@ and apply_cont env res apply_cont = and switch env res switch = let scrutinee = Switch.scrutinee switch in let dbg = Switch.condition_dbg switch in - let untagged_scrutinee_cmm, env, _ = C.simple ~dbg env scrutinee in + let untagged_scrutinee_cmm, env, res, _ = C.simple ~dbg env res scrutinee in let arms = Switch.arms switch in (* For binary switches, which can be translated to an if-then-else, it can be interesting for the scrutinee to be tagged (particularly for switches @@ -652,7 +705,7 @@ and switch env res switch = match Targetint_31_63.Map.cardinal arms with | 2 -> ( match Env.extra_info env scrutinee with - | None | Some Boxed_number -> untagged_scrutinee_cmm, false + | None -> untagged_scrutinee_cmm, false | Some (Untag tagged_scrutinee_cmm) -> let size_untagged = Option.value @@ -667,7 +720,7 @@ and switch env res switch = else untagged_scrutinee_cmm, false) | _ -> untagged_scrutinee_cmm, false in - let wrap, env = Env.flush_delayed_lets env in + let wrap, env, res = Env.flush_delayed_lets ~mode:Branching_point env res in let prepare_discriminant ~must_tag d = let targetint_d = Targetint_31_63.to_targetint d in Targetint_32_64.to_int_checked diff --git a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml index cb50a7ca6b8..b1c8564954b 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_primitive.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_primitive.ml @@ -25,6 +25,7 @@ module P = Flambda_primitive (* Cmm helpers *) module C = struct include Cmm_helpers + include Cmm_builtins include To_cmm_shared end @@ -506,11 +507,20 @@ let binary_float_comp_primitive_yielding_int _env dbg x y = (* Primitives *) -let nullary_primitive _env dbg prim : _ * Cmm.expression = +let nullary_primitive _env res dbg prim = match (prim : P.nullary_primitive) with + | Invalid _ -> + let message = "Invalid primitive" in + let expr, res = C.invalid res ~message in + None, res, expr | Optimised_out _ -> Misc.fatal_errorf "TODO: phantom let-bindings in to_cmm" - | Probe_is_enabled { name } -> None, Cop (Cprobe_is_enabled { name }, [], dbg) - | Begin_region -> None, C.beginregion ~dbg + | Probe_is_enabled { name } -> + (* CR gbury: we should never manually build cmm expression in this file. We + should instead always use smart constructors defined in `cmm_helpers` or + `to_cmm_shared.ml` *) + let expr = Cmm.Cop (Cprobe_is_enabled { name }, [], dbg) in + None, res, expr + | Begin_region -> None, res, C.beginregion ~dbg let unary_primitive env res dbg f arg = match (f : P.unary_primitive) with @@ -550,7 +560,7 @@ let unary_primitive env res dbg f arg = | Unbox_number kind -> None, res, unbox_number ~dbg kind arg | Untag_immediate -> Some (Env.Untag arg), res, C.untag_int arg dbg | Box_number (kind, alloc_mode) -> - Some Env.Boxed_number, res, box_number ~dbg kind alloc_mode arg + None, res, box_number ~dbg kind alloc_mode arg | Tag_immediate -> (* We could return [Env.Tag] here, but probably unnecessary at the moment. *) @@ -576,11 +586,11 @@ let unary_primitive env res dbg f arg = let message = dead_slots_msg dbg [c1; c2] [] in let expr, res = C.invalid res ~message in None, res, expr) - | Project_value_slot { project_from; value_slot } -> ( + | Project_value_slot { project_from; value_slot; kind = _ } -> ( match value_slot_offset env value_slot, function_slot_offset env project_from with - | Live_value_slot { offset }, Live_function_slot { offset = base; _ } -> + | Live_value_slot { offset; _ }, Live_function_slot { offset = base; _ } -> None, res, C.get_field_gen Asttypes.Immutable arg (offset - base) dbg | Dead_value_slot, Live_function_slot _ -> let message = dead_slots_msg dbg [] [value_slot] in @@ -608,6 +618,7 @@ let unary_primitive env res dbg f arg = ~else_dbg:dbg ) | Is_flat_float_array -> None, res, C.eq ~dbg (C.get_tag arg dbg) (C.floatarray_tag dbg) + | Begin_try_region -> None, res, C.beginregion ~dbg | End_region -> None, res, C.return_unit dbg (C.endregion ~dbg arg) let binary_primitive env dbg f x y = @@ -647,27 +658,76 @@ let variadic_primitive _env dbg f args = | Make_block (kind, _mut, alloc_mode) -> make_block ~dbg kind alloc_mode args | Make_array (kind, _mut, alloc_mode) -> make_array ~dbg kind alloc_mode args -let prim env res dbg (p : P.t) = +let arg ?consider_inlining_effectful_expressions ~dbg env res simple = + C.simple ?consider_inlining_effectful_expressions ~dbg env res simple + +let arg_list ?consider_inlining_effectful_expressions ~dbg env res l = + let aux (list, env, res, effs) x = + let y, env, res, eff = + arg ?consider_inlining_effectful_expressions ~dbg env res x + in + y :: list, env, res, Ece.join eff effs + in + let args, env, res, effs = + List.fold_left aux ([], env, res, Ece.pure_can_be_duplicated) l + in + List.rev args, env, res, effs + +let arg_list' ?consider_inlining_effectful_expressions ~dbg env res l = + let aux (list, env, res, effs) x = + let y, env, res, eff = + arg ?consider_inlining_effectful_expressions ~dbg env res x + in + (y, eff) :: list, env, res, Ece.join eff effs + in + let args, env, res, effs = + List.fold_left aux ([], env, res, Ece.pure_can_be_duplicated) l + in + List.rev args, env, res, effs + +let trans_prim : To_cmm_env.t To_cmm_env.trans_prim = + { nullary = nullary_primitive; + unary = unary_primitive; + binary = + (fun env res dbg prim x y -> + let cmm = binary_primitive env dbg prim x y in + None, res, cmm); + ternary = + (fun env res dbg prim x y z -> + let cmm = ternary_primitive env dbg prim x y z in + None, res, cmm); + variadic = + (fun env res dbg prim args -> + let cmm = variadic_primitive env dbg prim args in + None, res, cmm) + } + +let consider_inlining_effectful_expressions p = + (* By default we are very conservative about the inlining of effectful + expressions into the arguments of primitives. We consider inlining in the + following cases: + + - in the case where the primitive compiles directly to an allocation. + Unlike for most primitives, inlining of the arguments gives a real benefit + for these, by keeping live ranges shorter (which could be critical for + register allocation performance in cases such as initialisation of very + large arrays). We are also confident that the code for compiling + allocations does not incorrectly reorder or duplicate arguments, whereas we + are not universally confident about that for the other Cmm translation + functions. + + This criterion should not be relaxed for any primitive until it is certain + that the Cmm translation for such primitive both respects right-to-left + evaluation order and does not duplicate any arguments. *) + match[@ocaml.warning "-4"] (p : P.t) with + | Variadic ((Make_block _ | Make_array _), _) -> Some true + | Nullary _ | Unary _ | Binary _ | Ternary _ -> None + +let prim_simple env res dbg p = let consider_inlining_effectful_expressions = - (* By default we are very conservative about the inlining of effectful - expressions into the arguments of primitives. We only consider inlining - in the case where the primitive compiles directly to an allocation. - Unlike for most primitives, inlining of the arguments gives a real - benefit for these, by keeping live ranges shorter (which could be - critical for register allocation performance in cases such as - initialisation of very large arrays). We are also confident that the code - for compiling allocations does not incorrectly reorder or duplicate - arguments, whereas we are not universally confident about that for the - other Cmm translation functions. - - This criterion should not be relaxed for any primitive until it is - certain that the Cmm translation for such primitive both respects - right-to-left evaluation order and does not duplicate any arguments. *) - match p with - | Nullary _ | Unary _ | Binary _ | Ternary _ -> None - | Variadic ((Make_block _ | Make_array _), _) -> Some true + consider_inlining_effectful_expressions p in - let simple = C.simple ?consider_inlining_effectful_expressions ~dbg in + let arg = arg ?consider_inlining_effectful_expressions ~dbg in (* Somewhat counter-intuitively, the left-to-right translation below (e.g. [x] before [y] in the [Binary] case) correctly matches right-to-left evaluation order---ensuring maximal inlining---since [C.simple_list] translates the @@ -683,30 +743,68 @@ let prim env res dbg (p : P.t) = desired output Make_block [effect-y; effect-x]. The backend will compile this to run effect-x before effect-y by virtue of right-to-left evaluation order. This therefore matches the original source code. *) - match p with + match (p : P.t) with | Nullary prim -> - let extra, expr = nullary_primitive env dbg prim in - expr, extra, env, res, Ece.pure + let extra, res, expr = nullary_primitive env res dbg prim in + Env.simple expr, extra, env, res, Ece.pure | Unary (unary, x) -> - let x, env, eff = simple env x in + let x, env, res, eff = arg env res x in let extra, res, expr = unary_primitive env res dbg unary x in - expr, extra, env, res, eff + Env.simple expr, extra, env, res, eff | Binary (binary, x, y) -> - let x, env, effx = simple env x in - let y, env, effy = simple env y in + let x, env, res, effx = arg env res x in + let y, env, res, effy = arg env res y in let effs = Ece.join effx effy in let expr = binary_primitive env dbg binary x y in - expr, None, env, res, effs + Env.simple expr, None, env, res, effs | Ternary (ternary, x, y, z) -> - let x, env, effx = simple env x in - let y, env, effy = simple env y in - let z, env, effz = simple env z in + let x, env, res, effx = arg env res x in + let y, env, res, effy = arg env res y in + let z, env, res, effz = arg env res z in let effs = Ece.join (Ece.join effx effy) effz in let expr = ternary_primitive env dbg ternary x y z in - expr, None, env, res, effs + Env.simple expr, None, env, res, effs | Variadic (((Make_block _ | Make_array _) as variadic), l) -> - let args, env, effs = - C.simple_list ?consider_inlining_effectful_expressions ~dbg env l + let args, env, res, effs = + arg_list ?consider_inlining_effectful_expressions ~dbg env res l in let expr = variadic_primitive env dbg variadic args in - expr, None, env, res, effs + Env.simple expr, None, env, res, effs + +let prim_complex env res dbg p = + let consider_inlining_effectful_expressions = + consider_inlining_effectful_expressions p + in + let arg = arg ?consider_inlining_effectful_expressions ~dbg in + (* see comment in [prim_simple] *) + let prim', args, effs, env, res = + match (p : P.t) with + | Nullary prim -> + let prim' = P.Without_args.Nullary prim in + prim', [], Ece.pure_can_be_duplicated, env, res + | Unary (unary, x) -> + let prim' = P.Without_args.Unary unary in + let x, env, res, eff = arg env res x in + prim', [x, eff], eff, env, res + | Binary (binary, x, y) -> + let prim' = P.Without_args.Binary binary in + let x, env, res, effx = arg env res x in + let y, env, res, effy = arg env res y in + let effs = Ece.join effx effy in + prim', [x, effx; y, effy], effs, env, res + | Ternary (ternary, x, y, z) -> + let prim' = P.Without_args.Ternary ternary in + let x, env, res, effx = arg env res x in + let y, env, res, effy = arg env res y in + let z, env, res, effz = arg env res z in + let effs = Ece.join (Ece.join effx effy) effz in + prim', [x, effx; y, effy; z, effz], effs, env, res + | Variadic (((Make_block _ | Make_array _) as variadic), l) -> + let prim' = P.Without_args.Variadic variadic in + let args, env, res, effs = + arg_list' ?consider_inlining_effectful_expressions ~dbg env res l + in + prim', args, effs, env, res + in + let bound_expr = Env.splittable_primitive dbg prim' args in + bound_expr, env, res, effs diff --git a/middle_end/flambda2/to_cmm/to_cmm_primitive.mli b/middle_end/flambda2/to_cmm/to_cmm_primitive.mli index 00c87953419..3e250f59680 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_primitive.mli +++ b/middle_end/flambda2/to_cmm/to_cmm_primitive.mli @@ -14,13 +14,25 @@ (** Translation of Flambda primitives to Cmm. *) -val prim : +val trans_prim : To_cmm_env.t To_cmm_env.trans_prim + +val prim_simple : To_cmm_env.t -> To_cmm_result.t -> Debuginfo.t -> Flambda_primitive.t -> - Cmm.expression + To_cmm_env.simple To_cmm_env.bound_expr * To_cmm_env.extra_info option * To_cmm_env.t * To_cmm_result.t * Effects_and_coeffects.t + +val prim_complex : + To_cmm_env.t -> + To_cmm_result.t -> + Debuginfo.t -> + Flambda_primitive.t -> + To_cmm_env.complex To_cmm_env.bound_expr + * To_cmm_env.t + * To_cmm_result.t + * Effects_and_coeffects.t diff --git a/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml b/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml index 2833f091b7d..bf6870bea8d 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.ml @@ -72,8 +72,12 @@ module Make_layout_filler (P : sig val simple : dbg:Debuginfo.t -> To_cmm_env.t -> + To_cmm_result.t -> Simple.t -> - [`Data of cmm_term list | `Var of Variable.t] * To_cmm_env.t * Ece.t + [`Data of cmm_term list | `Var of Variable.t] + * To_cmm_env.t + * To_cmm_result.t + * Ece.t val infix_header : dbg:Debuginfo.t -> function_slot_offset:int -> cmm_term @@ -86,26 +90,41 @@ end) : sig Code_id.t Function_slot.Map.t -> Debuginfo.t -> startenv:int -> - Simple.t Value_slot.Map.t -> + (Simple.t * Flambda_kind.With_subkind.t) Value_slot.Map.t -> Env.t -> + To_cmm_result.t -> Ece.t -> prev_updates:Cmm.expression option -> (int * Slot_offsets.Layout.slot) list -> - P.cmm_term list * int * Env.t * Ece.t * Cmm.expression option + P.cmm_term list + * int + * Env.t + * To_cmm_result.t + * Ece.t + * Cmm.expression option end = struct (* The [offset]s here are measured in units of words. *) - let fill_slot for_static_sets decls dbg ~startenv value_slots env acc + let fill_slot for_static_sets decls dbg ~startenv value_slots env res acc ~slot_offset updates slot = match (slot : Slot_offsets.Layout.slot) with | Infix_header -> let field = P.infix_header ~function_slot_offset:(slot_offset + 1) ~dbg in - field :: acc, slot_offset + 1, env, Ece.pure, updates - | Value_slot v -> - let simple = Value_slot.Map.find v value_slots in - let contents, env, eff = P.simple ~dbg env simple in - let env, fields, updates = + field :: acc, slot_offset + 1, env, res, Ece.pure, updates + | Value_slot { value_slot; is_scanned; size = _ } -> + let simple, kind = Value_slot.Map.find value_slot value_slots in + if (not + (Flambda_kind.equal + (Flambda_kind.With_subkind.kind kind) + Flambda_kind.value)) + && is_scanned + then + Misc.fatal_errorf + "Value slot %a not of kind Value (%a) but is visible by GC" + Simple.print simple Debuginfo.print_compact dbg; + let contents, env, res, eff = P.simple ~dbg env res simple in + let env, res, fields, updates = match contents with - | `Data fields -> env, fields, updates + | `Data fields -> env, res, fields, updates | `Var v -> ( (* We should only get here in the static allocation case. *) match for_static_sets with @@ -115,17 +134,17 @@ end = struct closure_symbol_for_updates; _ } -> - let env, updates = - C.make_update env dbg Word_val + let env, res, updates = + C.make_update env res dbg Word_val ~symbol:(C.symbol ~dbg closure_symbol_for_updates) v ~index:(slot_offset - function_slot_offset_for_updates) ~prev_updates:updates in - env, [P.int ~dbg 1n], updates) + env, res, [P.int ~dbg 1n], updates) in - List.rev_append fields acc, slot_offset + 1, env, eff, updates - | Function_slot { size; function_slot } -> ( + List.rev_append fields acc, slot_offset + 1, env, res, eff, updates + | Function_slot { size; function_slot; last_function_slot } -> ( let code_id = Function_slot.Map.find function_slot decls in let code_linkage_name = Code_id.linkage_name code_id in let arity, closure_code_pointers, dbg = @@ -133,6 +152,7 @@ end = struct in let closure_info = C.closure_info ~arity ~startenv:(startenv - slot_offset) + ~is_last:last_function_slot in let acc = match for_static_sets with @@ -161,7 +181,7 @@ end = struct :: P.symbol_from_linkage_name ~dbg code_linkage_name :: acc in - acc, slot_offset + size, env, Ece.pure, updates + acc, slot_offset + size, env, res, Ece.pure, updates | Full_and_partial_application -> if size <> 3 then @@ -177,12 +197,12 @@ end = struct (Linkage_name.of_string (C.curry_function_sym arity)) :: acc in - acc, slot_offset + size, env, Ece.pure, updates) + acc, slot_offset + size, env, res, Ece.pure, updates) - let rec fill_layout0 for_static_sets decls dbg ~startenv value_slots env effs - acc updates ~starting_offset slots = + let rec fill_layout0 for_static_sets decls dbg ~startenv value_slots env res + effs acc updates ~starting_offset slots = match slots with - | [] -> List.rev acc, starting_offset, env, effs, updates + | [] -> List.rev acc, starting_offset, env, res, effs, updates | (slot_offset, slot) :: slots -> let acc = if starting_offset > slot_offset @@ -195,17 +215,17 @@ end = struct List.init (slot_offset - starting_offset) (fun _ -> P.int ~dbg 1n) @ acc in - let acc, next_offset, env, eff, updates = - fill_slot for_static_sets decls dbg ~startenv value_slots env acc + let acc, next_offset, env, res, eff, updates = + fill_slot for_static_sets decls dbg ~startenv value_slots env res acc ~slot_offset updates slot in let effs = Ece.join eff effs in - fill_layout0 for_static_sets decls dbg ~startenv value_slots env effs acc - updates ~starting_offset:next_offset slots + fill_layout0 for_static_sets decls dbg ~startenv value_slots env res effs + acc updates ~starting_offset:next_offset slots - let fill_layout for_static_sets decls dbg ~startenv value_slots env effs + let fill_layout for_static_sets decls dbg ~startenv value_slots env res effs ~prev_updates slots = - fill_layout0 for_static_sets decls dbg ~startenv value_slots env effs [] + fill_layout0 for_static_sets decls dbg ~startenv value_slots env res effs [] prev_updates ~starting_offset:0 slots end @@ -215,9 +235,16 @@ module Dynamic = Make_layout_filler (struct let int ~dbg i = C.nativeint ~dbg i - let simple ~dbg env simple = - let term, env, eff = C.simple ~dbg env simple in - `Data [term], env, eff + (* The reason why we can inline simples here is the same as in + `To_cmm_shared.simple_list`: the first simple translated (and thus in which + an inlining/substitution can occur), is the last simple that will be + evaluated, according to the right-to-left evaluation order. This is ensured + by the fact that we build each field of the set of closures in + left-to-right order, so that the first translated field is actually + evaluated last. *) + let simple ~dbg env res simple = + let term, env, res, eff = C.simple ~dbg env res simple in + `Data [term], env, res, eff let infix_header ~dbg ~function_slot_offset = C.alloc_infix_header function_slot_offset dbg @@ -234,9 +261,9 @@ module Static = Make_layout_filler (struct let int ~dbg:_ i = C.cint i - let simple ~dbg:_ env simple = + let simple ~dbg:_ env res simple = let contents = C.simple_static simple in - contents, env, Ece.pure + contents, env, res, Ece.pure let infix_header ~dbg:_ ~function_slot_offset = C.cint (C.infix_header function_slot_offset) @@ -262,7 +289,7 @@ let transl_check_attrib : Check_attribute.t -> Cmm.codegen_option list = let params_and_body0 env res code_id ~fun_dbg ~check ~return_continuation ~exn_continuation params ~body ~my_closure - ~(is_my_closure_used : _ Or_unknown.t) ~translate_expr = + ~(is_my_closure_used : _ Or_unknown.t) ~my_region ~translate_expr = let params = let is_my_closure_used = match is_my_closure_used with @@ -283,6 +310,12 @@ let params_and_body0 env res code_id ~fun_dbg ~check ~return_continuation let env = Env.enter_function_body env ~return_continuation ~exn_continuation in + (* [my_region] can be referenced in [Begin_try_region] primitives so must be + in the environment; however it should never end up in actual generated + code, so we don't need any binder for it (this is why we can ignore + [_bound_var]). If it does end up in generated code, Selection will complain + and refuse to compile the code. *) + let env, _bound_var = Env.create_bound_parameter env my_region in (* Translate the arg list and body *) let env, fun_args = C.bound_parameters env params in let fun_body, res = translate_expr env res body in @@ -292,7 +325,11 @@ let params_and_body0 env res code_id ~fun_dbg ~check ~return_continuation if Flambda_features.optimize_for_speed () then [] else [Cmm.Reduce_code_size] in let linkage_name = Linkage_name.to_string (Code_id.linkage_name code_id) in - C.fundecl linkage_name fun_args fun_body fun_flags fun_dbg, res + let fun_poll = + Env.get_code_metadata env code_id + |> Code_metadata.poll_attribute |> Poll_attribute.to_lambda + in + C.fundecl linkage_name fun_args fun_body fun_flags fun_dbg fun_poll, res let params_and_body env res code_id p ~fun_dbg ~check ~translate_expr = Function_params_and_body.pattern_match p @@ -303,15 +340,16 @@ let params_and_body env res code_id p ~fun_dbg ~check ~translate_expr = ~body ~my_closure ~is_my_closure_used - ~my_region:_ + ~my_region ~my_depth:_ ~free_names_of_body:_ -> try params_and_body0 env res code_id ~fun_dbg ~check ~return_continuation ~exn_continuation params ~body ~my_closure ~is_my_closure_used - ~translate_expr + ~my_region ~translate_expr with Misc.Fatal_error as e -> + let bt = Printexc.get_raw_backtrace () in Format.eprintf "\n\ %tContext is:%t translating function %a to Cmm with return cont %a, \ @@ -319,7 +357,7 @@ let params_and_body env res code_id p ~fun_dbg ~check ~translate_expr = Flambda_colours.error Flambda_colours.pop Code_id.print code_id Continuation.print return_continuation Continuation.print exn_continuation Expr.print body; - raise e) + Printexc.raise_with_backtrace e bt) (* Translation of sets of closures. *) @@ -342,7 +380,7 @@ let debuginfo_for_set_of_closures env set = (* Choose the debuginfo with the earliest source location. *) match dbg with [] -> Debuginfo.none | dbg :: _ -> dbg -let let_static_set_of_closures0 env closure_symbols +let let_static_set_of_closures0 env res closure_symbols (layout : Slot_offsets.Layout.t) set ~prev_updates = let fun_decls = Set_of_closures.function_decls set in let decls = Function_declarations.funs fun_decls in @@ -374,9 +412,9 @@ let let_static_set_of_closures0 env closure_symbols closure_symbol_for_updates } in - let l, length, env, _effs, updates = + let l, length, env, res, _effs, updates = Static.fill_layout (Some for_static_sets) decls dbg - ~startenv:layout.startenv value_slots env Ece.pure ~prev_updates + ~startenv:layout.startenv value_slots env res Ece.pure ~prev_updates layout.slots in let block = @@ -387,11 +425,11 @@ let let_static_set_of_closures0 env closure_symbols | [] -> Misc.fatal_error "Cannot statically allocate an empty set of closures" in - env, block, updates + env, res, block, updates -let let_static_set_of_closures env closure_symbols set ~prev_updates = +let let_static_set_of_closures env res closure_symbols set ~prev_updates = let layout = layout_for_set_of_closures env set in - let_static_set_of_closures0 env closure_symbols layout set ~prev_updates + let_static_set_of_closures0 env res closure_symbols layout set ~prev_updates (* Sets of closures with no value slots can be statically allocated. This usually happens earlier (in Simplify, or Closure_conversion for classic mode) @@ -406,7 +444,8 @@ let let_static_set_of_closures env closure_symbols set ~prev_updates = * g *) -let lift_set_of_closures env res ~body ~bound_vars layout set ~translate_expr = +let lift_set_of_closures env res ~body ~bound_vars layout set ~translate_expr + ~num_normal_occurrences_of_bound_vars = (* Generate symbols for the set of closures, and each of the closures *) let comp_unit = Compilation_unit.get_current_exn () in let dbg = debuginfo_for_set_of_closures env set in @@ -425,8 +464,8 @@ let lift_set_of_closures env res ~body ~bound_vars layout set ~translate_expr = |> Function_slot.Map.of_list in (* Statically allocate the set of closures *) - let env, static_data, updates = - let_static_set_of_closures0 env closure_symbols layout set + let env, res, static_data, updates = + let_static_set_of_closures0 env res closure_symbols layout set ~prev_updates:None in (* There should be no updates as there are no value slots *) @@ -437,16 +476,15 @@ let lift_set_of_closures env res ~body ~bound_vars layout set ~translate_expr = (* Update the result with the new static data *) let res = R.archive_data (R.set_data res static_data) in (* Bind the variables to the symbols for function slots. *) - (* CR-someday gbury: inline the variables (requires extending To_cmm_env to - inline pure variables more than once). *) - let env = + let env, res = List.fold_left2 - (fun acc cid v -> + (fun (env, res) cid v -> let v = Bound_var.var v in let sym = C.symbol ~dbg (Function_slot.Map.find cid closure_symbols) in - Env.bind_variable acc v ~effects_and_coeffects_of_defining_expr:Ece.pure - ~num_normal_occurrences_of_bound_vars:Unknown ~defining_expr:sym) - env cids bound_vars + Env.bind_variable env res v ~defining_expr:sym + ~num_normal_occurrences_of_bound_vars + ~effects_and_coeffects_of_defining_expr:Ece.pure_can_be_duplicated) + (env, res) cids bound_vars in translate_expr env res body @@ -459,16 +497,17 @@ let let_dynamic_set_of_closures0 env res ~body ~bound_vars set let dbg = debuginfo_for_set_of_closures env set in let effs : Ece.t = ( Only_generative_effects Immutable, - match closure_alloc_mode with + (match closure_alloc_mode with | Heap -> No_coeffects - | Local _ -> Has_coeffects ) + | Local _ -> Has_coeffects), + Strict ) in let decl_map = decls |> Function_slot.Lmap.bindings |> Function_slot.Map.of_list in - let l, _offset, env, effs, updates = + let l, _offset, env, res, effs, updates = Dynamic.fill_layout None decl_map dbg ~startenv:layout.startenv value_slots - env effs ~prev_updates:None layout.slots + env res effs ~prev_updates:None layout.slots in assert (Option.is_none updates); let csoc = @@ -479,18 +518,19 @@ let let_dynamic_set_of_closures0 env res ~body ~bound_vars set dbg tag l in let soc_var = Variable.create "*set_of_closures*" in - let env = - Env.bind_variable env soc_var ~effects_and_coeffects_of_defining_expr:effs - ~num_normal_occurrences_of_bound_vars:Unknown ~defining_expr:csoc + let defining_expr = Env.simple csoc in + let env, res = + Env.bind_variable_to_primitive env res soc_var ~inline:Env.Do_not_inline + ~defining_expr ~effects_and_coeffects_of_defining_expr:effs in (* Get from the env the cmm variable that was created and bound to the compiled set of closures. *) - let soc_cmm_var, env, peff = Env.inline_variable env soc_var in + let soc_cmm_var, env, res, peff = Env.inline_variable env res soc_var in assert ( match To_cmm_effects.classify_by_effects_and_coeffects peff with | Pure -> true - | Effect | Coeffect_only -> false); - (* Add env bindings for all of the value slots. *) + | Generative_immutable | Effect | Coeffect_only -> false); + (* Helper function to get the cmm expr for a closure offset *) let get_closure_by_offset env set_cmm function_slot = match Exported_offsets.function_slot_offset (Env.exported_offsets env) @@ -504,18 +544,17 @@ let let_dynamic_set_of_closures0 env res ~body ~bound_vars set Function_slot.print function_slot in (* Add env bindings for all of the function slots. *) - let env = + let env, res = List.fold_left2 - (fun acc cid v -> + (fun (env, res) cid v -> match get_closure_by_offset env soc_cmm_var cid with - | None -> acc + | None -> env, res | Some (defining_expr, effects_and_coeffects_of_defining_expr) -> let v = Bound_var.var v in - Env.bind_variable acc v - ~num_normal_occurrences_of_bound_vars: - (Known num_normal_occurrences_of_bound_vars) - ~effects_and_coeffects_of_defining_expr ~defining_expr) - env + Env.bind_variable env res v ~defining_expr + ~num_normal_occurrences_of_bound_vars + ~effects_and_coeffects_of_defining_expr) + (env, res) (Function_slot.Lmap.keys decls) bound_vars in @@ -525,7 +564,9 @@ let let_dynamic_set_of_closures env res ~body ~bound_vars ~num_normal_occurrences_of_bound_vars set ~translate_expr = let layout = layout_for_set_of_closures env set in if layout.empty_env - then lift_set_of_closures env res ~body ~bound_vars layout set ~translate_expr + then + lift_set_of_closures env res ~body ~bound_vars layout set ~translate_expr + ~num_normal_occurrences_of_bound_vars else let_dynamic_set_of_closures0 env res ~body ~bound_vars ~num_normal_occurrences_of_bound_vars set layout diff --git a/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.mli b/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.mli index 8c54cb6ff2e..d81b9af69ac 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.mli +++ b/middle_end/flambda2/to_cmm/to_cmm_set_of_closures.mli @@ -21,10 +21,11 @@ type translate_expr = val let_static_set_of_closures : To_cmm_env.t -> + To_cmm_result.t -> Symbol.t Function_slot.Map.t -> Set_of_closures.t -> prev_updates:Cmm.expression option -> - To_cmm_env.t * Cmm.data_item list * Cmm.expression option + To_cmm_env.t * To_cmm_result.t * Cmm.data_item list * Cmm.expression option val let_dynamic_set_of_closures : To_cmm_env.t -> diff --git a/middle_end/flambda2/to_cmm/to_cmm_shared.ml b/middle_end/flambda2/to_cmm/to_cmm_shared.ml index b42732f20bb..ed6af18a885 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_shared.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_shared.ml @@ -13,6 +13,7 @@ (**************************************************************************) open! Cmm_helpers +open! Cmm_builtins module Ece = Effects_and_coeffects let exttype_of_kind (k : Flambda_kind.t) : Cmm.exttype = @@ -59,13 +60,14 @@ let symbol_from_linkage_name ~dbg ln = let symbol ~dbg sym = symbol_from_linkage_name ~dbg (Symbol.linkage_name sym) -let name0 ?consider_inlining_effectful_expressions env name = +let name0 ?consider_inlining_effectful_expressions env res name = Name.pattern_match name ~var:(fun v -> - To_cmm_env.inline_variable ?consider_inlining_effectful_expressions env v) + To_cmm_env.inline_variable ?consider_inlining_effectful_expressions env + res v) ~symbol:(fun s -> (* CR mshinwell: fix debuginfo? *) - symbol ~dbg:Debuginfo.none s, env, Ece.pure) + symbol ~dbg:Debuginfo.none s, env, res, Ece.pure_can_be_duplicated) let name env name = name0 env name @@ -79,11 +81,11 @@ let const ~dbg cst = | Naked_int64 i -> int64 ~dbg i | Naked_nativeint t -> targetint ~dbg t -let simple ?consider_inlining_effectful_expressions ~dbg env s = +let simple ?consider_inlining_effectful_expressions ~dbg env res s = Simple.pattern_match s ~name:(fun n ~coercion:_ -> - name0 ?consider_inlining_effectful_expressions env n) - ~const:(fun c -> const ~dbg c, env, Ece.pure) + name0 ?consider_inlining_effectful_expressions env res n) + ~const:(fun c -> const ~dbg c, env, res, Ece.pure_can_be_duplicated) let name_static name = Name.pattern_match name @@ -108,21 +110,23 @@ let simple_static s = ~name:(fun n ~coercion:_ -> name_static n) ~const:(fun c -> `Data (const_static c)) -let simple_list ?consider_inlining_effectful_expressions ~dbg env l = +let simple_list ?consider_inlining_effectful_expressions ~dbg env res l = (* Note that [To_cmm_primitive] relies on this function translating the [Simple] at the head of the list first. *) - let aux (list, env, effs) x = - let y, env, eff = - simple ?consider_inlining_effectful_expressions ~dbg env x + let aux (list, env, res, effs) x = + let y, env, res, eff = + simple ?consider_inlining_effectful_expressions ~dbg env res x in - y :: list, env, Ece.join eff effs + y :: list, env, res, Ece.join eff effs in - let args, env, effs = List.fold_left aux ([], env, Ece.pure) l in - List.rev args, env, effs + let args, env, res, effs = + List.fold_left aux ([], env, res, Ece.pure_can_be_duplicated) l + in + List.rev args, env, res, effs let bound_parameters env l = let flambda_vars = Bound_parameters.vars l in - let env, cmm_vars = To_cmm_env.create_variables env flambda_vars in + let env, cmm_vars = To_cmm_env.create_bound_parameters env flambda_vars in let vars = List.map2 (fun v v' -> v, machtype_of_kinded_parameter v') @@ -156,17 +160,18 @@ let invalid res ~message = in let call_expr = extcall ~dbg ~alloc:false ~is_c_builtin:false ~returns:false ~ty_args:[XInt] - "caml_flambda2_invalid" Cmm.typ_void [symbol ~dbg message_sym] + "caml_flambda2_invalid" Cmm.typ_void + [symbol ~dbg message_sym] in call_expr, res -let make_update env dbg kind ~symbol var ~index ~prev_updates = - let e, env, _ece = To_cmm_env.inline_variable env var in +let make_update env res dbg kind ~symbol var ~index ~prev_updates = + let e, env, res, _ece = To_cmm_env.inline_variable env res var in let addr = field_address symbol index dbg in let update = store ~dbg kind Initialization ~addr ~new_value:e in match prev_updates with - | None -> env, Some update - | Some prev_updates -> env, Some (sequence prev_updates update) + | None -> env, res, Some update + | Some prev_updates -> env, res, Some (sequence prev_updates update) let check_arity arity args = Flambda_arity.With_subkinds.cardinal arity = List.length args diff --git a/middle_end/flambda2/to_cmm/to_cmm_shared.mli b/middle_end/flambda2/to_cmm/to_cmm_shared.mli index 7af786c52f6..a360648c77e 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_shared.mli +++ b/middle_end/flambda2/to_cmm/to_cmm_shared.mli @@ -38,8 +38,9 @@ val symbol : dbg:Debuginfo.t -> Symbol.t -> Cmm.expression (** This does not inline effectful expressions. *) val name : To_cmm_env.t -> + To_cmm_result.t -> Name.t -> - Cmm.expression * To_cmm_env.t * Effects_and_coeffects.t + Cmm.expression * To_cmm_env.t * To_cmm_result.t * Effects_and_coeffects.t val const : dbg:Debuginfo.t -> Reg_width_const.t -> Cmm.expression @@ -50,8 +51,9 @@ val simple : ?consider_inlining_effectful_expressions:bool -> dbg:Debuginfo.t -> To_cmm_env.t -> + To_cmm_result.t -> Simple.t -> - Cmm.expression * To_cmm_env.t * Effects_and_coeffects.t + Cmm.expression * To_cmm_env.t * To_cmm_result.t * Effects_and_coeffects.t val simple_static : Simple.t -> [`Data of Cmm.data_item list | `Var of Variable.t] @@ -62,8 +64,9 @@ val simple_list : ?consider_inlining_effectful_expressions:bool -> dbg:Debuginfo.t -> To_cmm_env.t -> + To_cmm_result.t -> Simple.t list -> - Cmm.expression list * To_cmm_env.t * Effects_and_coeffects.t + Cmm.expression list * To_cmm_env.t * To_cmm_result.t * Effects_and_coeffects.t val bound_parameters : To_cmm_env.t -> @@ -76,13 +79,14 @@ val invalid : (** Make an update to a statically-allocated block. *) val make_update : To_cmm_env.t -> + To_cmm_result.t -> Debuginfo.t -> Cmm.memory_chunk -> symbol:Cmm.expression -> Variable.t -> index:int -> prev_updates:Cmm.expression option -> - To_cmm_env.t * Cmm.expression option + To_cmm_env.t * To_cmm_result.t * Cmm.expression option val check_arity : Flambda_arity.With_subkinds.t -> _ list -> bool diff --git a/middle_end/flambda2/to_cmm/to_cmm_static.ml b/middle_end/flambda2/to_cmm/to_cmm_static.ml index 95105ed65fc..2ee90d8cbee 100644 --- a/middle_end/flambda2/to_cmm/to_cmm_static.ml +++ b/middle_end/flambda2/to_cmm/to_cmm_static.ml @@ -36,39 +36,39 @@ let or_variable f default v cont = | Const c -> f c cont | Var _ -> f default cont -let rec static_block_updates symb env acc i = function - | [] -> env, acc +let rec static_block_updates symb env res acc i = function + | [] -> env, res, acc | sv :: r -> ( match (sv : Field_of_static_block.t) with | Symbol _ | Tagged_immediate _ -> - static_block_updates symb env acc (i + 1) r + static_block_updates symb env res acc (i + 1) r | Dynamically_computed (var, dbg) -> - let env, acc = - C.make_update env dbg Word_val ~symbol:(C.symbol ~dbg symb) var ~index:i - ~prev_updates:acc + let env, res, acc = + C.make_update env res dbg Word_val ~symbol:(C.symbol ~dbg symb) var + ~index:i ~prev_updates:acc in - static_block_updates symb env acc (i + 1) r) + static_block_updates symb env res acc (i + 1) r) -let rec static_float_array_updates symb env acc i = function - | [] -> env, acc +let rec static_float_array_updates symb env res acc i = function + | [] -> env, res, acc | sv :: r -> ( match (sv : _ Or_variable.t) with - | Const _ -> static_float_array_updates symb env acc (i + 1) r + | Const _ -> static_float_array_updates symb env res acc (i + 1) r | Var (var, dbg) -> - let env, acc = - C.make_update env dbg Double ~symbol:(C.symbol ~dbg symb) var ~index:i - ~prev_updates:acc + let env, res, acc = + C.make_update env res dbg Double ~symbol:(C.symbol ~dbg symb) var + ~index:i ~prev_updates:acc in - static_float_array_updates symb env acc (i + 1) r) + static_float_array_updates symb env res acc (i + 1) r) let static_boxed_number ~kind ~env ~symbol ~default ~emit ~transl ~structured v - r updates = + res updates = let aux x cont = emit (Symbol.linkage_name_as_string symbol, Cmmgen_state.Global) (transl x) cont in - let updates = + let env, res, updates = match (v : _ Or_variable.t) with | Const c -> (* Add the const to the cmmgen_state structured constants table so that @@ -77,40 +77,40 @@ let static_boxed_number ~kind ~env ~symbol ~default ~emit ~transl ~structured v let symbol_name = Symbol.linkage_name_as_string symbol in let structured_constant = structured (transl c) in Cmmgen_state.add_structured_constant symbol_name structured_constant; - env, None + env, res, None | Var (v, dbg) -> - C.make_update env dbg kind ~symbol:(C.symbol ~dbg symbol) v ~index:0 + C.make_update env res dbg kind ~symbol:(C.symbol ~dbg symbol) v ~index:0 ~prev_updates:updates in - R.update_data r (or_variable aux default v), updates + R.update_data res (or_variable aux default v), env, updates -let add_function env r ~params_and_body code_id p ~fun_dbg ~check = - let fundecl, r = params_and_body env r code_id p ~fun_dbg ~check in - R.add_function r fundecl +let add_function env res ~params_and_body code_id p ~fun_dbg ~check = + let fundecl, res = params_and_body env res code_id p ~fun_dbg ~check in + R.add_function res fundecl -let add_functions env ~params_and_body r (code : Code.t) = - add_function env r ~params_and_body (Code.code_id code) +let add_functions env ~params_and_body res (code : Code.t) = + add_function env res ~params_and_body (Code.code_id code) (Code.params_and_body code) ~fun_dbg:(Code.dbg code) ~check:(Code.check code) -let preallocate_set_of_closures (r, updates, env) ~closure_symbols +let preallocate_set_of_closures (res, updates, env) ~closure_symbols set_of_closures = - let env, data, updates = + let env, res, data, updates = let closure_symbols = closure_symbols |> Function_slot.Lmap.bindings |> Function_slot.Map.of_list in - To_cmm_set_of_closures.let_static_set_of_closures env closure_symbols + To_cmm_set_of_closures.let_static_set_of_closures env res closure_symbols set_of_closures ~prev_updates:updates in - let r = R.set_data r data in - r, updates, env + let res = R.set_data res data in + res, updates, env -let static_const0 env r ~updates (bound_static : Bound_static.Pattern.t) +let static_const0 env res ~updates (bound_static : Bound_static.Pattern.t) (static_const : Static_const.t) = match bound_static, static_const with | Block_like s, Block (tag, _mut, fields) -> - let r = R.check_for_module_symbol r s in + let res = R.check_for_module_symbol res s in let tag = Tag.Scannable.to_int tag in let block_name = Symbol.linkage_name_as_string s, Cmmgen_state.Global in let header = C.black_block_header tag (List.length fields) in @@ -122,46 +122,46 @@ let static_const0 env r ~updates (bound_static : Bound_static.Pattern.t) fields [] in let block = C.emit_block block_name header static_fields in - let env, updates = static_block_updates s env updates 0 fields in - env, R.set_data r block, updates + let env, res, updates = static_block_updates s env res updates 0 fields in + env, R.set_data res block, updates | Set_of_closures closure_symbols, Set_of_closures set_of_closures -> - let r, updates, env = - preallocate_set_of_closures (r, updates, env) ~closure_symbols + let res, updates, env = + preallocate_set_of_closures (res, updates, env) ~closure_symbols set_of_closures in - env, r, updates + env, res, updates | Block_like symbol, Boxed_float v -> let default = Numeric_types.Float_by_bit_pattern.zero in let transl = Numeric_types.Float_by_bit_pattern.to_float in let structured f = Clambda.Uconst_float f in - let r, (env, updates) = + let res, env, updates = static_boxed_number ~kind:Double ~env ~symbol ~default - ~emit:C.emit_float_constant ~transl ~structured v r updates + ~emit:C.emit_float_constant ~transl ~structured v res updates in - env, r, updates + env, res, updates | Block_like symbol, Boxed_int32 v -> let structured i = Clambda.Uconst_int32 i in - let r, (env, updates) = + let res, env, updates = static_boxed_number ~kind:Word_int ~env ~symbol ~default:0l - ~emit:C.emit_int32_constant ~transl:Fun.id ~structured v r updates + ~emit:C.emit_int32_constant ~transl:Fun.id ~structured v res updates in - env, r, updates + env, res, updates | Block_like symbol, Boxed_int64 v -> let structured i = Clambda.Uconst_int64 i in - let r, (env, updates) = + let res, env, updates = static_boxed_number ~kind:Word_int ~env ~symbol ~default:0L - ~emit:C.emit_int64_constant ~transl:Fun.id ~structured v r updates + ~emit:C.emit_int64_constant ~transl:Fun.id ~structured v res updates in - env, r, updates + env, res, updates | Block_like symbol, Boxed_nativeint v -> let default = Targetint_32_64.zero in let transl = C.nativeint_of_targetint in let structured i = Clambda.Uconst_nativeint i in - let r, (env, updates) = + let res, env, updates = static_boxed_number ~kind:Word_int ~env ~symbol ~default - ~emit:C.emit_nativeint_constant ~transl ~structured v r updates + ~emit:C.emit_nativeint_constant ~transl ~structured v res updates in - env, r, updates + env, res, updates | Block_like s, (Immutable_float_block fields | Immutable_float_array fields) -> let aux = @@ -174,8 +174,8 @@ let static_const0 env r ~updates (bound_static : Bound_static.Pattern.t) (Symbol.linkage_name_as_string s, Cmmgen_state.Global) static_fields in - let env, e = static_float_array_updates s env updates 0 fields in - env, R.update_data r float_array, e + let env, res, e = static_float_array_updates s env res updates 0 fields in + env, R.update_data res float_array, e | Block_like s, Immutable_value_array fields -> let block_name = Symbol.linkage_name_as_string s, Cmmgen_state.Global in let header = C.black_block_header 0 (List.length fields) in @@ -187,19 +187,19 @@ let static_const0 env r ~updates (bound_static : Bound_static.Pattern.t) fields [] in let block = C.emit_block block_name header static_fields in - let env, updates = static_block_updates s env updates 0 fields in - env, R.set_data r block, updates + let env, res, updates = static_block_updates s env res updates 0 fields in + env, R.set_data res block, updates | Block_like s, Empty_array -> (* Recall: empty arrays have tag zero, even if their kind is naked float. *) let block_name = Symbol.linkage_name_as_string s, Cmmgen_state.Global in let header = C.black_block_header 0 0 in let block = C.emit_block block_name header [] in - env, R.set_data r block, updates + env, R.set_data res block, updates | Block_like s, Mutable_string { initial_value = str } | Block_like s, Immutable_string str -> let name = Symbol.linkage_name_as_string s in let data = C.emit_string_constant (name, Cmmgen_state.Global) str in - env, R.update_data r data, updates + env, R.update_data res data, updates | Block_like _, Set_of_closures _ -> Misc.fatal_errorf "[Set_of_closures] values cannot be bound by [Block_like] bindings:@ %a" @@ -286,6 +286,7 @@ let static_consts env r ~params_and_body bound_static static_consts = let r = R.add_gc_roots r roots in static_consts0 env r ~params_and_body bound_static static_consts with Misc.Fatal_error as e -> + let bt = Printexc.get_raw_backtrace () in (* Create a new "let symbol" with a dummy body to better print the bound symbols and static consts. *) let dummy_body = Expr.create_invalid To_cmm_dummy_body in @@ -299,4 +300,4 @@ let static_consts env r ~params_and_body bound_static static_consts = Format.eprintf "\n@[%tContext is:%t translating `let symbol' to Cmm:@ %a@." Flambda_colours.error Flambda_colours.pop Expr.print tmp_let_symbol; - raise e + Printexc.raise_with_backtrace e bt diff --git a/middle_end/flambda2/types/flambda2_types.mli b/middle_end/flambda2/types/flambda2_types.mli index 8908918d905..d79c2e76fad 100644 --- a/middle_end/flambda2/types/flambda2_types.mli +++ b/middle_end/flambda2/types/flambda2_types.mli @@ -232,10 +232,12 @@ module Typing_env : sig val get_singleton : t -> Simple.t option - val choose_opt : t -> Simple.t option + val find_best : t -> Simple.t option val inter : t -> t -> t + val singleton : Simple.t -> t + val print : Format.formatter -> t -> unit end @@ -485,19 +487,19 @@ val closure_with_at_least_these_value_slots : flambda_type val array_of_length : - element_kind:Flambda_kind.With_subkind.t Or_unknown.t -> + element_kind:Flambda_kind.With_subkind.t Or_unknown_or_bottom.t -> length:flambda_type -> Alloc_mode.For_types.t -> flambda_type val mutable_array : - element_kind:Flambda_kind.With_subkind.t Or_unknown.t -> + element_kind:Flambda_kind.With_subkind.t Or_unknown_or_bottom.t -> length:flambda_type -> Alloc_mode.For_types.t -> flambda_type val immutable_array : - element_kind:Flambda_kind.With_subkind.t Or_unknown.t -> + element_kind:Flambda_kind.With_subkind.t Or_unknown_or_bottom.t -> fields:flambda_type list -> Alloc_mode.For_types.t -> flambda_type @@ -617,7 +619,9 @@ val prove_is_immediates_array : Typing_env.t -> t -> unit proof_of_property val meet_is_immutable_array : Typing_env.t -> t -> - (Flambda_kind.With_subkind.t Or_unknown.t * t * Alloc_mode.For_types.t) + (Flambda_kind.With_subkind.t Or_unknown_or_bottom.t + * t + * Alloc_mode.For_types.t) meet_shortcut val meet_single_closures_entry : diff --git a/middle_end/flambda2/types/grammar/more_type_creators.ml b/middle_end/flambda2/types/grammar/more_type_creators.ml index ca208be518f..e9e4614fd4e 100644 --- a/middle_end/flambda2/types/grammar/more_type_creators.ml +++ b/middle_end/flambda2/types/grammar/more_type_creators.ml @@ -315,14 +315,14 @@ let rec unknown_with_subkind ?(alloc_mode = Alloc_mode.For_types.unknown ()) ~fields:(List.init num_fields (fun _ -> TG.any_naked_float)) alloc_mode | Float_array -> - TG.mutable_array ~element_kind:(Known Flambda_kind.With_subkind.naked_float) + TG.mutable_array ~element_kind:(Ok Flambda_kind.With_subkind.naked_float) ~length:any_tagged_immediate alloc_mode | Immediate_array -> TG.mutable_array - ~element_kind:(Known Flambda_kind.With_subkind.tagged_immediate) + ~element_kind:(Ok Flambda_kind.With_subkind.tagged_immediate) ~length:any_tagged_immediate alloc_mode | Value_array -> - TG.mutable_array ~element_kind:(Known Flambda_kind.With_subkind.any_value) + TG.mutable_array ~element_kind:(Ok Flambda_kind.With_subkind.any_value) ~length:any_tagged_immediate alloc_mode | Generic_array -> TG.mutable_array ~element_kind:Unknown ~length:any_tagged_immediate diff --git a/middle_end/flambda2/types/grammar/type_grammar.ml b/middle_end/flambda2/types/grammar/type_grammar.ml index 324e33e7d1f..b2072f6a708 100644 --- a/middle_end/flambda2/types/grammar/type_grammar.ml +++ b/middle_end/flambda2/types/grammar/type_grammar.ml @@ -64,12 +64,39 @@ and head_of_kind_value = } | String of String_info.Set.t | Array of - { element_kind : Flambda_kind.With_subkind.t Or_unknown.t; + { element_kind : Flambda_kind.With_subkind.t Or_unknown_or_bottom.t; length : t; contents : array_contents Or_unknown.t; alloc_mode : Alloc_mode.For_types.t } +(* CR someday vlaviron: comparison results are encoded as naked immediates, and + in a few cases (physical equality mostly) some values of the boolean carry + information that we can represent in the types. Here is an actual example + where it would be useful: *) + +(* type t = + * | A1 of float array + * | A2 of int array + * | A3 of int array + * | A4 of int array + * + * let bar t = + * match t with + * | A3 x -> array_unsafe_get x 0 (* Not specialised currently *) + * | _ -> assert false *) + +(* Since the match is compiled using equality on the tag and not a regular + switch, we currently fail to restrict the type of [t] to the single [A3] + constructor. We could solve that by adding another case like Is_int and + Get_tag, or we could go in the other direction and make each individual + number in the set for the Naked_immediates case carry an extension. We could + even use that for encoding the Is_int and Get_tag constraints, although it is + not completely clear what the impact on performance would be (we could store + minimal extensions, carrying a shape, or we could pre-compute the full meet + for each case and store precise extensions; the first version would be faster + if we don't actually use the extensions, while the second version would be + particularly useful if we switch several times on the same scrutinee. *) and head_of_kind_naked_immediate = | Naked_immediates of Targetint_31_63.Set.t | Is_int of t @@ -132,7 +159,7 @@ and closures_entry = (* Products are a set of constraints: each new field reduces the concrete set. The empty product is top. There is no bottom. All components must be of the - same kind. + same kind except for [value_slot_indexed_product]. { 1 => Unknown; 2 => V } is equal to { 2 => V } *) and function_slot_indexed_product = @@ -728,13 +755,13 @@ and print_head_of_kind_value ppf head = | Array { element_kind; length; contents = Unknown; alloc_mode } -> Format.fprintf ppf "@[(Array@ (element_kind@ %a)@ (length@ %a)@ (alloc_mode@ %a))@]" - (Or_unknown.print Flambda_kind.With_subkind.print) + (Or_unknown_or_bottom.print Flambda_kind.With_subkind.print) element_kind print length Alloc_mode.For_types.print alloc_mode | Array { element_kind; length; contents = Known Mutable; alloc_mode } -> Format.fprintf ppf "@[(Mutable_array@ (element_kind@ %a)@ (length@ %a)@ (alloc_mode@ \ %a))@]" - (Or_unknown.print Flambda_kind.With_subkind.print) + (Or_unknown_or_bottom.print Flambda_kind.With_subkind.print) element_kind print length Alloc_mode.For_types.print alloc_mode | Array { element_kind; @@ -745,7 +772,7 @@ and print_head_of_kind_value ppf head = Format.fprintf ppf "@[(Immutable_array@ (element_kind@ %a)@ (length@ %a)@ \ (alloc_mode@ %a)@ (fields@ (%a)))@]" - (Or_unknown.print Flambda_kind.With_subkind.print) + (Or_unknown_or_bottom.print Flambda_kind.With_subkind.print) element_kind print length Alloc_mode.For_types.print alloc_mode (Format.pp_print_list ~pp_sep:Format.pp_print_space print) fields @@ -2199,18 +2226,19 @@ module Product = struct type t = function_slot_indexed_product let create function_slot_components_by_index = - if Flambda_features.check_invariants () - then - Function_slot.Map.iter - (fun _ ty -> + let function_slot_components_by_index = + Function_slot.Map.map + (fun ty -> if not (K.equal (kind ty) K.value) then Misc.fatal_errorf "Function-slot-indexed products can only hold types of kind \ [Value]:@ %a" (Function_slot.Map.print print) - function_slot_components_by_index) - function_slot_components_by_index; + function_slot_components_by_index + else ty) + function_slot_components_by_index + in { function_slot_components_by_index } let top = { function_slot_components_by_index = Function_slot.Map.empty } @@ -2224,18 +2252,6 @@ module Product = struct type t = value_slot_indexed_product let create value_slot_components_by_index = - if Flambda_features.check_invariants () - then - Value_slot.Map.iter - (fun _ ty -> - if not (K.equal (kind ty) K.value) - then - Misc.fatal_errorf - "Value-slot-indexed products can only hold types of kind \ - [Value]:@ %a" - (Value_slot.Map.print print) - value_slot_components_by_index) - value_slot_components_by_index; { value_slot_components_by_index } let top = { value_slot_components_by_index = Value_slot.Map.empty } diff --git a/middle_end/flambda2/types/grammar/type_grammar.mli b/middle_end/flambda2/types/grammar/type_grammar.mli index bdca3287dda..42c4a01da1e 100644 --- a/middle_end/flambda2/types/grammar/type_grammar.mli +++ b/middle_end/flambda2/types/grammar/type_grammar.mli @@ -57,7 +57,7 @@ and head_of_kind_value = private } | String of String_info.Set.t | Array of - { element_kind : Flambda_kind.With_subkind.t Or_unknown.t; + { element_kind : Flambda_kind.With_subkind.t Or_unknown_or_bottom.t; length : t; contents : array_contents Or_unknown.t; alloc_mode : Alloc_mode.For_types.t @@ -268,19 +268,19 @@ val this_immutable_string : string -> t val mutable_string : size:int -> t val array_of_length : - element_kind:Flambda_kind.With_subkind.t Or_unknown.t -> + element_kind:Flambda_kind.With_subkind.t Or_unknown_or_bottom.t -> length:t -> Alloc_mode.For_types.t -> t val mutable_array : - element_kind:Flambda_kind.With_subkind.t Or_unknown.t -> + element_kind:Flambda_kind.With_subkind.t Or_unknown_or_bottom.t -> length:t -> Alloc_mode.For_types.t -> t val immutable_array : - element_kind:Flambda_kind.With_subkind.t Or_unknown.t -> + element_kind:Flambda_kind.With_subkind.t Or_unknown_or_bottom.t -> fields:t list -> Alloc_mode.For_types.t -> t @@ -577,7 +577,7 @@ module Head_of_kind_value : sig val create_string : String_info.Set.t -> t val create_array_with_contents : - element_kind:Flambda_kind.With_subkind.t Or_unknown.t -> + element_kind:Flambda_kind.With_subkind.t Or_unknown_or_bottom.t -> length:flambda_type -> array_contents Or_unknown.t -> Alloc_mode.For_types.t -> diff --git a/middle_end/flambda2/types/join_levels.ml b/middle_end/flambda2/types/join_levels.ml index 79fe60c40ef..caaf23df4aa 100644 --- a/middle_end/flambda2/types/join_levels.ml +++ b/middle_end/flambda2/types/join_levels.ml @@ -151,13 +151,24 @@ let join_types ~env_at_fork envs_with_levels = Name.Map.merge join_types joined_types (TEL.equations t)) let construct_joined_level envs_with_levels ~env_at_fork ~allowed ~joined_types - = + ~params = + let allowed_and_new = + (* Parameters are already in the resulting environment *) + List.fold_left + (fun allowed_and_new param -> + Name_occurrences.remove_var allowed_and_new + ~var:(Bound_parameter.var param)) + allowed params + in + let variable_is_in_new_level var = + Name_occurrences.mem_var allowed_and_new var + in let defined_vars, binding_times = List.fold_left (fun (defined_vars, binding_times) (_env_at_use, _id, _use_kind, t) -> let defined_vars_this_level = Variable.Map.filter - (fun var _ -> Name_occurrences.mem_var allowed var) + (fun var _ -> variable_is_in_new_level var) (TEL.defined_variables_with_kinds t) in let defined_vars = @@ -175,11 +186,7 @@ let construct_joined_level envs_with_levels ~env_at_fork ~allowed ~joined_types let binding_times_this_level = Binding_time.Map.filter_map (fun _ vars -> - let vars = - Variable.Set.filter - (fun var -> Name_occurrences.mem_var allowed var) - vars - in + let vars = Variable.Set.filter variable_is_in_new_level vars in if Variable.Set.is_empty vars then None else Some vars) (TEL.variables_by_binding_time t) in @@ -297,6 +304,7 @@ let join ~env_at_fork envs_with_levels ~params ~extra_lifted_consts_in_use_envs (* Having calculated which equations to propagate, the resulting level can now be constructed. *) construct_joined_level envs_with_levels ~env_at_fork ~allowed ~joined_types + ~params let n_way_join ~env_at_fork envs_with_levels ~params ~extra_lifted_consts_in_use_envs ~extra_allowed_names = diff --git a/middle_end/flambda2/types/meet_and_join.ml b/middle_end/flambda2/types/meet_and_join.ml index 6cc7ca95b4f..244e477540c 100644 --- a/middle_end/flambda2/types/meet_and_join.ml +++ b/middle_end/flambda2/types/meet_and_join.ml @@ -98,31 +98,35 @@ let[@inline always] join_unknown join_contents (env : Join_env.t) | _, Unknown | Unknown, _ -> Unknown | Known contents1, Known contents2 -> join_contents env contents1 contents2 -let meet_array_element_kinds (element_kind1 : _ Or_unknown.t) - (element_kind2 : _ Or_unknown.t) : _ Or_bottom.t = +(* Note: Bottom is a valid element kind for empty arrays, so this function never + leads to a general Bottom result *) +let meet_array_element_kinds (element_kind1 : _ Or_unknown_or_bottom.t) + (element_kind2 : _ Or_unknown_or_bottom.t) : _ Or_unknown_or_bottom.t = match element_kind1, element_kind2 with - | Unknown, Unknown -> Ok Or_unknown.Unknown - | Unknown, Known kind | Known kind, Unknown -> Ok (Or_unknown.Known kind) - | Known element_kind1, Known element_kind2 -> + | Unknown, Unknown -> Unknown + | Bottom, _ | _, Bottom -> Bottom + | Unknown, Ok kind | Ok kind, Unknown -> Ok kind + | Ok element_kind1, Ok element_kind2 -> if Flambda_kind.With_subkind.compatible element_kind1 ~when_used_at:element_kind2 - then Ok (Or_unknown.Known element_kind1) + then Ok element_kind1 else if Flambda_kind.With_subkind.compatible element_kind2 ~when_used_at:element_kind1 - then Ok (Or_unknown.Known element_kind2) + then Ok element_kind2 else Bottom -let join_array_element_kinds (element_kind1 : _ Or_unknown.t) - (element_kind2 : _ Or_unknown.t) : _ Or_unknown.t = +let join_array_element_kinds (element_kind1 : _ Or_unknown_or_bottom.t) + (element_kind2 : _ Or_unknown_or_bottom.t) : _ Or_unknown_or_bottom.t = match element_kind1, element_kind2 with - | Unknown, Unknown | Unknown, Known _ | Known _, Unknown -> Unknown - | Known element_kind1, Known element_kind2 -> + | Unknown, _ | _, Unknown -> Unknown + | Bottom, element_kind | element_kind, Bottom -> element_kind + | Ok element_kind1, Ok element_kind2 -> if Flambda_kind.With_subkind.compatible element_kind1 ~when_used_at:element_kind2 - then Known element_kind2 + then Ok element_kind2 else if Flambda_kind.With_subkind.compatible element_kind2 ~when_used_at:element_kind1 - then Known element_kind1 + then Ok element_kind1 else Unknown let rec meet env (t1 : TG.t) (t2 : TG.t) : (TG.t * TEE.t) Or_bottom.t = @@ -386,11 +390,14 @@ and meet_head_of_kind_value env (head1 : TG.head_of_kind_value) alloc_mode = alloc_mode2 } ) -> let<* alloc_mode = meet_alloc_mode alloc_mode1 alloc_mode2 in - let<* element_kind = meet_array_element_kinds element_kind1 element_kind2 in + let element_kind = meet_array_element_kinds element_kind1 element_kind2 in let<* contents, env_extension = meet_array_contents env array_contents1 array_contents2 in let<* length, env_extension' = meet env length1 length2 in + (* CR-someday vlaviron: If the element kind is Bottom, we could meet the + length type with the constant 0 (only the empty array can have element + kind Bottom). *) let<+ env_extension = meet_env_extension env env_extension env_extension' in ( TG.Head_of_kind_value.create_array_with_contents ~element_kind ~length contents alloc_mode, @@ -918,6 +925,28 @@ and meet_env_extension0 env (ext1 : TEE.t) (ext2 : TEE.t) extra_extensions : To get around this, we'll suppose that [t2] is smaller than [t1] and add equations from [t2] to [t1], along with all extra equations *) + let has_reverse_alias name1 ty2 ext = + (* If we're adding an equation [x : (= y)] but we already have an equation + [y : (= x)], then we can drop the equation as redundant. *) + match TG.get_alias_opt ty2 with + | None -> false + | Some simple2 -> + Simple.pattern_match simple2 + ~const:(fun _ -> false) + ~name:(fun name2 ~coercion:coercion1to2 -> + match Name.Map.find_opt name2 ext with + | None -> false + | Some ty3 -> ( + match TG.get_alias_opt ty3 with + | None -> false + | Some simple3 -> + Simple.pattern_match simple3 + ~const:(fun _ -> false) + ~name:(fun name3 ~coercion:coercion2to3 -> + Name.equal name1 name3 + && Coercion.is_id + (Coercion.compose_exn coercion1to2 ~then_:coercion2to3)))) + in let equations, extra_extensions = Name.Map.fold (fun name ty (eqs, extra_extensions) -> @@ -930,11 +959,16 @@ and meet_env_extension0 env (ext1 : TEE.t) (ext2 : TEE.t) extra_extensions : | Bottom -> raise Bottom_meet | Ok (ty, new_ext) -> let eqs = - if MTC.is_alias_of_name ty name + if MTC.is_alias_of_name ty name || has_reverse_alias name ty eqs then Name.Map.remove name eqs else Name.Map.add (* replace *) name ty eqs in - eqs, new_ext :: extra_extensions)) + let extra_extensions = + if TEE.is_empty new_ext + then extra_extensions + else new_ext :: extra_extensions + in + eqs, extra_extensions)) (TEE.to_map ext2) (TEE.to_map ext1, extra_extensions) in diff --git a/middle_end/flambda2/types/provers.ml b/middle_end/flambda2/types/provers.ml index 7df7ebc39c7..feba470b163 100644 --- a/middle_end/flambda2/types/provers.ml +++ b/middle_end/flambda2/types/provers.ml @@ -495,7 +495,12 @@ let meet_is_flat_float_array env t : bool meet_shortcut = | Value Unknown -> Need_meet | Value Bottom -> Invalid | Value (Ok (Array { element_kind = Unknown; _ })) -> Need_meet - | Value (Ok (Array { element_kind = Known element_kind; _ })) -> ( + | Value (Ok (Array { element_kind = Bottom; _ })) -> + (* Empty array case. We cannot return Invalid, but any other result is + correct. We arbitrarily pick [false], as this is what we would get if we + looked at the tag at runtime. *) + Known_result false + | Value (Ok (Array { element_kind = Ok element_kind; _ })) -> ( match K.With_subkind.kind element_kind with | Value -> Known_result false | Naked_number Naked_float -> Known_result true @@ -520,7 +525,11 @@ let prove_is_immediates_array env t : unit proof_of_property = match expand_head env t with | Value (Unknown | Bottom) -> Unknown | Value (Ok (Array { element_kind = Unknown; _ })) -> Unknown - | Value (Ok (Array { element_kind = Known element_kind; _ })) -> ( + | Value (Ok (Array { element_kind = Bottom; _ })) -> + (* Empty array case. We cannot return Invalid, but it's correct to state + that any value contained in this array must be an immediate. *) + Proved () + | Value (Ok (Array { element_kind = Ok element_kind; _ })) -> ( match K.With_subkind.subkind element_kind with | Tagged_immediate -> Proved () | Anything | Boxed_float | Boxed_int32 | Boxed_int64 | Boxed_nativeint diff --git a/middle_end/flambda2/types/provers.mli b/middle_end/flambda2/types/provers.mli index 6bec5c6f2ed..0385ff4c2fd 100644 --- a/middle_end/flambda2/types/provers.mli +++ b/middle_end/flambda2/types/provers.mli @@ -120,7 +120,7 @@ val meet_is_flat_float_array : val meet_is_immutable_array : Typing_env.t -> Type_grammar.t -> - (Flambda_kind.With_subkind.t Or_unknown.t + (Flambda_kind.With_subkind.t Or_unknown_or_bottom.t * Type_grammar.t * Alloc_mode.For_types.t) meet_shortcut diff --git a/middle_end/flambda2/types/reify.ml b/middle_end/flambda2/types/reify.ml index 818a9bde425..4fca91b41a9 100644 --- a/middle_end/flambda2/types/reify.ml +++ b/middle_end/flambda2/types/reify.ml @@ -384,7 +384,10 @@ let reify ~allowed_if_free_vars_defined_in ~var_is_defined_at_toplevel | _ :: _ -> ( match element_kind with | Unknown -> try_canonical_simple () - | Known element_kind -> ( + | Bottom -> + (* CR someday vlaviron: we could use [Lift Empty_array] here *) + try_canonical_simple () + | Ok element_kind -> ( let kind = Flambda_kind.With_subkind.kind element_kind in match kind with | Value -> ( diff --git a/middle_end/flambda2/ui/flambda_colours.ml b/middle_end/flambda2/ui/flambda_colours.ml index f6b855ec3f7..d4f206afac2 100644 --- a/middle_end/flambda2/ui/flambda_colours.ml +++ b/middle_end/flambda2/ui/flambda_colours.ml @@ -18,14 +18,26 @@ let debug_push_and_pop = false type directive = Format.formatter -> unit -let colour_enabled = - lazy - ((* This avoids having to alter misc.ml *) - let buf = Buffer.create 10 in - let ppf = Format.formatter_of_buffer buf in - Misc.Color.set_color_tag_handling ppf; - Format.fprintf ppf "@{@}%!"; - String.length (Buffer.contents buf) > 0) +let disable_colours = ref false + +let is_colour_enabled = + let colour_enabled = + lazy + ((* This avoids having to alter misc.ml *) + let buf = Buffer.create 10 in + let ppf = Format.formatter_of_buffer buf in + Misc.Color.set_color_tag_handling ppf; + Format.fprintf ppf "@{@}%!"; + String.length (Buffer.contents buf) > 0) + in + fun () -> Lazy.force colour_enabled && not !disable_colours + +let without_colours ~f = + let tmp = !disable_colours in + disable_colours := true; + let res = f () in + disable_colours := tmp; + res type state = { fg : int option; @@ -40,7 +52,7 @@ let state_stack = ref [initial_state] let output ppf str = - if Lazy.force colour_enabled then Format.fprintf ppf "@<0>%s" str + if is_colour_enabled () then Format.fprintf ppf "@<0>%s" str let sequence command_code arg = Printf.sprintf "\x1b[%d;5;%d;1m" command_code arg diff --git a/middle_end/flambda2/ui/flambda_colours.mli b/middle_end/flambda2/ui/flambda_colours.mli index f3bb760f136..200bb0eae61 100644 --- a/middle_end/flambda2/ui/flambda_colours.mli +++ b/middle_end/flambda2/ui/flambda_colours.mli @@ -91,3 +91,5 @@ val error : directive val each_file : directive val lambda : directive + +val without_colours : f:(unit -> 'a) -> 'a diff --git a/middle_end/flambda2/ui/flambda_features.ml b/middle_end/flambda2/ui/flambda_features.ml index 5ecc9599a3c..34945199aed 100644 --- a/middle_end/flambda2/ui/flambda_features.ml +++ b/middle_end/flambda2/ui/flambda_features.ml @@ -101,6 +101,8 @@ let dump_flexpect () = !Flambda_backend_flags.Flambda2.Dump.flexpect let dump_slot_offsets () = !Flambda_backend_flags.Flambda2.Dump.slot_offsets +let dump_flow () = !Flambda_backend_flags.Flambda2.Dump.flow + let freshen_when_printing () = !Flambda_backend_flags.Flambda2.Dump.freshen module Inlining = struct @@ -126,7 +128,10 @@ module Inlining = struct | Round round -> IH.get ~key:round !I.max_depth | Default opt_level -> (default_for_opt_level opt_level).max_depth in - depth * depth_scaling_factor + (* This computation (rather than just [depth * depth_scaling_factor]) gives + a bit more leeway for always-inlined functions, which reduce the depth by + much less than [depth_scaling_factor], to be inlined. *) + ((depth + 1) * depth_scaling_factor) - 1 let max_rec_depth round_or_default = match round_or_default with @@ -225,6 +230,10 @@ module Expert = struct let can_inline_recursive_functions () = !Flambda_backend_flags.Flambda2.Expert.can_inline_recursive_functions |> with_default ~f:(fun d -> d.can_inline_recursive_functions) + + let max_function_simplify_run () = + !Flambda_backend_flags.Flambda2.Expert.max_function_simplify_run + |> with_default ~f:(fun d -> d.max_function_simplify_run) end let stack_allocation_enabled () = Config.stack_allocation diff --git a/middle_end/flambda2/ui/flambda_features.mli b/middle_end/flambda2/ui/flambda_features.mli index 5fed8b6a2ce..e958c7e839a 100644 --- a/middle_end/flambda2/ui/flambda_features.mli +++ b/middle_end/flambda2/ui/flambda_features.mli @@ -70,6 +70,8 @@ val dump_flexpect : unit -> bool val dump_slot_offsets : unit -> bool +val dump_flow : unit -> bool + val freshen_when_printing : unit -> bool module Inlining : sig @@ -123,6 +125,8 @@ module Expert : sig val max_unboxing_depth : unit -> int val can_inline_recursive_functions : unit -> bool + + val max_function_simplify_run : unit -> int end val stack_allocation_enabled : unit -> bool diff --git a/middle_end/internal_variable_names.ml b/middle_end/internal_variable_names.ml index d8a48332cdd..8b17c9877cb 100644 --- a/middle_end/internal_variable_names.ml +++ b/middle_end/internal_variable_names.ml @@ -107,7 +107,6 @@ let pbytessetu = "Pbytessetu" let pccall = "Pccall" let pctconst = "Pctconst" let pcvtbint = "Pcvtbint" -let pdirapply = "Pdirapply" let pdivbint = "Pdivbint" let pdivfloat = "Pdivfloat" let pdivint = "Pdivint" @@ -119,7 +118,7 @@ let pfloatcomp = "Pfloatcomp" let pfloatfield = "Pfloatfield" let pfloatofint = "Pfloatofint" let pgetglobal = "Pgetglobal" -let pidentity = "Pidentity" +let pgetpredef = "Pgetpredef" let pignore = "Pignore" let pint_as_pointer = "Pint_as_pointer" let pintcomp = "Pintcomp" @@ -156,7 +155,6 @@ let porbint = "Porbint" let porint = "Porint" let praise = "Praise" let predef_exn = "predef_exn" -let prevapply = "Prevapply" let project_closure = "project_closure" let psequand = "Psequand" let psequor = "Psequor" @@ -213,7 +211,6 @@ let pbytessetu_arg = "Pbytessetu_arg" let pccall_arg = "Pccall_arg" let pctconst_arg = "Pctconst_arg" let pcvtbint_arg = "Pcvtbint_arg" -let pdirapply_arg = "Pdirapply_arg" let pdivbint_arg = "Pdivbint_arg" let pdivfloat_arg = "Pdivfloat_arg" let pdivint_arg = "Pdivint_arg" @@ -225,9 +222,9 @@ let pfloatcomp_arg = "Pfloatcomp_arg" let pfloatfield_arg = "Pfloatfield_arg" let pfloatofint_arg = "Pfloatofint_arg" let pgetglobal_arg = "Pgetglobal_arg" +let pgetpredef_arg = "Pgetpredef_arg" let pobj_dup_arg = "Pobj_dup_arg" let pobj_magic_arg = "Pobj_magic_arg" -let pidentity_arg = "Pidentity_arg" let pignore_arg = "Pignore_arg" let pint_as_pointer_arg = "Pint_as_pointer_arg" let pintcomp_arg = "Pintcomp_arg" @@ -260,7 +257,6 @@ let popaque_arg = "Popaque_arg" let porbint_arg = "Porbint_arg" let porint_arg = "Porint_arg" let praise_arg = "Praise_arg" -let prevapply_arg = "Prevapply_arg" let psequand_arg = "Psequand_arg" let psequor_arg = "Psequor_arg" let psetfield_arg = "Psetfield_arg" @@ -319,14 +315,12 @@ let anon_fn_with_loc (sloc: Lambda.scoped_location) = (Filename.basename file) line pp_chars let of_primitive : Lambda.primitive -> string = function - | Pidentity -> pidentity | Pbytes_of_string -> pbytes_of_string | Pbytes_to_string -> pbytes_to_string | Pignore -> pignore - | Prevapply _ -> prevapply - | Pdirapply _ -> pdirapply | Pgetglobal _ -> pgetglobal | Psetglobal _ -> psetglobal + | Pgetpredef _ -> pgetpredef | Pmakeblock _ -> pmakeblock | Pmakefloatblock _ -> pmakefloatblock | Pfield _ -> pfield @@ -429,14 +423,12 @@ let of_primitive : Lambda.primitive -> string = function | Pobj_magic -> pobj_magic let of_primitive_arg : Lambda.primitive -> string = function - | Pidentity -> pidentity_arg | Pbytes_of_string -> pbytes_of_string_arg | Pbytes_to_string -> pbytes_to_string_arg | Pignore -> pignore_arg - | Prevapply _ -> prevapply_arg - | Pdirapply _ -> pdirapply_arg | Pgetglobal _ -> pgetglobal_arg | Psetglobal _ -> psetglobal_arg + | Pgetpredef _ -> pgetpredef_arg | Pmakeblock _ -> pmakeblock_arg | Pmakefloatblock _ -> pmakefloatblock_arg | Pfield _ -> pfield_arg diff --git a/middle_end/mangling.ml b/middle_end/mangling.ml index fb3ce3b43e1..f93e19eff8e 100644 --- a/middle_end/mangling.ml +++ b/middle_end/mangling.ml @@ -21,6 +21,8 @@ * SOFTWARE. *) +[@@@ocaml.warning "-69"] + module String = Misc.Stdlib.String let escape_symbols part = @@ -134,10 +136,10 @@ let convert_identifier str = Templated (s, [Cpp_name (Simple "quoted")]) let convert_closure_id id loc = - if String.begins_with id "anon_fn[" + if String.begins_with id ~prefix:"anon_fn[" then (* Keep the unique integer stamp *) - let _init, stamp = String.split_last_exn id '_' in + let _init, stamp = String.split_last_exn id ~split_on:'_' in (* Put the location inside C++ template args *) Templated ("anon_fn_" ^ stamp, build_location_info loc) else @@ -146,7 +148,7 @@ let convert_closure_id id loc = | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' -> convert_identifier id (* An operator *) | _op -> - let op, stamp = String.split_last_exn id '_' in + let op, stamp = String.split_last_exn id ~split_on:'_' in Templated ("op_" ^ stamp, [Cpp_name (Simple (name_op op))]) let convert_scope scope = @@ -164,7 +166,7 @@ let convert_scope scope = let list_of_scopes scopes = (* Works for now since the only separators are '.' and '#' *) let scope_str = Debuginfo.Scoped_location.string_of_scopes scopes in - String.split_on_chars scope_str ['.'; '#'] + String.split_on_chars scope_str ~split_on:['.'; '#'] let scope_matches_closure_id scope closure_id = (* If the `id` is an anonymous function this corresponds to that, and, even if @@ -172,11 +174,11 @@ let scope_matches_closure_id scope closure_id = `let f = fun x -> ...`) *) String.equal scope "(fun)" (* Normal case where closure id and scope match directly *) - || String.begins_with closure_id scope + || String.begins_with closure_id ~prefix:scope || (* For operators, the scope is wrapped in parens *) String.length scope >= 3 && String.begins_with closure_id - (String.sub scope 1 (String.length scope - 2)) + ~prefix:(String.sub scope 1 (String.length scope - 2)) (* Returns a pair of the top-level module and the list of scopes that strictly contain the closure id *) @@ -200,7 +202,7 @@ let module_and_scopes ~unitname loc id = let remove_prefix ~prefix str = let n = String.length prefix in - if String.begins_with str prefix + if String.begins_with str ~prefix then String.sub str n (String.length str - n) else str @@ -208,7 +210,8 @@ let fun_symbol ~unitname ~loc ~id = let unitname = remove_prefix ~prefix:"caml" unitname in let top_level_module, sub_scopes = module_and_scopes ~unitname loc id in let namespace_parts name = - String.split_on_string name "__" |> List.map (fun part -> Simple part) + String.split_on_string name ~split_on:"__" + |> List.map (fun part -> Simple part) in let parts = List.concat diff --git a/middle_end/printclambda.ml b/middle_end/printclambda.ml index df4b9ab29f2..a5e99d7dbec 100644 --- a/middle_end/printclambda.ml +++ b/middle_end/printclambda.ml @@ -137,12 +137,13 @@ and lam ppf = function let lams ppf largs = List.iter (fun l -> fprintf ppf "@ %a" lam l) largs in fprintf ppf "@[<2>(%a@ %a%a)@]" apply_kind kind lam lfun lams largs - | Uclosure(clos, fv) -> + | Uclosure { functions ; not_scanned_slots ; scanned_slots } -> let funs ppf = List.iter (fprintf ppf "@ @[<2>%a@]" one_fun) in let lams ppf = List.iter (fprintf ppf "@ %a" lam) in - fprintf ppf "@[<2>(closure@ %a %a)@]" funs clos lams fv + fprintf ppf "@[<2>(closure@ %a (%a) %a)@]" funs functions + lams not_scanned_slots lams scanned_slots | Uoffset(l,i) -> fprintf ppf "@[<2>(offset %a %d)@]" lam l i | Ulet(mut, kind, id, arg, body) -> let rec letbody ul = match ul with diff --git a/middle_end/symbol_utils.ml b/middle_end/symbol_utils.ml index d01107dec1b..081591eb3b8 100644 --- a/middle_end/symbol_utils.ml +++ b/middle_end/symbol_utils.ml @@ -46,12 +46,4 @@ module Flambda = struct let for_code_of_closure closure_id = Symbol.for_name (Closure_id.get_compilation_unit closure_id) (Closure_id.unique_name closure_id) - - (* CR-soon lmaurer: Be rid of this when we have prefixes set correctly to begin - with *) - let import_for_pack symbol ~pack = - let compilation_unit = - CU.with_for_pack_prefix (Symbol.compilation_unit symbol) pack - in - Symbol.with_compilation_unit symbol compilation_unit end diff --git a/middle_end/symbol_utils.mli b/middle_end/symbol_utils.mli index e4d7fbeb705..711576a3a05 100644 --- a/middle_end/symbol_utils.mli +++ b/middle_end/symbol_utils.mli @@ -26,6 +26,4 @@ module Flambda : sig val for_variable : Variable.t -> Symbol.t val for_closure : Closure_id.t -> Symbol.t val for_code_of_closure : Closure_id.t -> Symbol.t - - val import_for_pack : Symbol.t -> pack:Compilation_unit.Prefix.t -> Symbol.t end diff --git a/native_toplevel/opttopdirs.ml b/native_toplevel/opttopdirs.ml index 913ccfb0bfa..e4829e28f19 100644 --- a/native_toplevel/opttopdirs.ml +++ b/native_toplevel/opttopdirs.ml @@ -35,7 +35,7 @@ let _ = Hashtbl.add directive_table "quit" (Directive_none dir_quit) let dir_directory s = let d = expand_directory Config.standard_library s in let dir = Load_path.Dir.create d in - Load_path.add dir; + Load_path.append_dir dir; toplevel_env := Stdlib.String.Set.fold (fun name env -> @@ -85,7 +85,8 @@ let load_file ppf name0 = if Filename.check_suffix name ".cmx" || Filename.check_suffix name ".cmxa" then let cmxs = Filename.temp_file "caml" ".cmxs" in - Asmlink.link_shared ~ppf_dump:ppf [name] cmxs; + Asmlink.link_shared (module Unix : Compiler_owee.Unix_intf.S) + ~ppf_dump:ppf [name] cmxs; cmxs,true else name,false @@ -191,7 +192,7 @@ let _ = Hashtbl.add directive_table "remove_printer" (Directive_ident (dir_remove_printer std_out)) let parse_warnings ppf iserr s = - try Warnings.parse_options iserr s + try ignore (Warnings.parse_options iserr s : Warnings.alert option) with Arg.Bad err -> fprintf ppf "%s.@." err let _ = diff --git a/native_toplevel/opttoploop.ml b/native_toplevel/opttoploop.ml index 62f3413b632..bd22605b596 100644 --- a/native_toplevel/opttoploop.ml +++ b/native_toplevel/opttoploop.ml @@ -51,16 +51,21 @@ external ndl_run_toplevel: string -> string -> res let default_lookup sym = Dynlink.unsafe_get_global_value ~bytecode_or_asm_symbol:sym -let global_symbol id = - let sym = Compilenv.symbol_for_global id in +let global_symbol comp_unit = let lookup = match !jit with | None -> default_lookup | Some {Jit.lookup_symbol; _} -> lookup_symbol in - match lookup (sym |> Linkage_name.to_string) with + let linkage_name = + Symbol.for_compilation_unit comp_unit + |> Symbol.linkage_name + |> Linkage_name.to_string + in + match lookup linkage_name with | None -> - fatal_error ("Opttoploop.global_symbol " ^ (Ident.unique_name id)) + fatal_error ("Opttoploop.global_symbol " ^ + (Compilation_unit.full_path_as_string comp_unit)) | Some obj -> obj let need_symbol sym = @@ -129,10 +134,10 @@ let toplevel_value id = (* Return the value referred to by a path *) let rec eval_address = function - | Env.Aident id -> - if Ident.is_global id - then global_symbol id - else toplevel_value id + | Env.Aunit cu -> + global_symbol cu + | Env.Alocal id -> + toplevel_value id | Env.Adot(a, pos) -> Obj.field (eval_address a) pos @@ -255,10 +260,6 @@ let phrase_name = ref "TOP" module Backend = struct (* See backend_intf.mli. *) - let symbol_for_global' = Compilenv.symbol_for_global' - - let pack_prefix_for_global_ident = Compilenv.pack_prefix_for_global_ident - let really_import_approx = Import_approx.really_import_approx let import_symbol = Import_approx.import_symbol @@ -284,7 +285,7 @@ let default_load ppf (program : Lambda.program) = ~filename ~prefixname:filename ~flambda2:Flambda2.lambda_to_cmm ~ppf_dump:ppf ~size:program.main_module_block_size - ~module_ident:program.module_ident + ~compilation_unit:program.compilation_unit ~module_initializer:program.code ~required_globals:program.required_globals end @@ -316,7 +317,7 @@ let default_load ppf (program : Lambda.program) = files) *) res -let load_lambda ppf ~module_ident ~required_globals lam size = +let load_lambda ppf ~compilation_unit ~required_globals lam size = if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam; let slam = Simplif.simplify_lambda lam in if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam; @@ -324,7 +325,7 @@ let load_lambda ppf ~module_ident ~required_globals lam size = { Lambda. code = slam; main_module_block_size = size; - module_ident; + compilation_unit; required_globals; } in @@ -386,7 +387,7 @@ let name_expression ~loc ~attrs exp = { pat_desc = Tpat_var(id, mknoloc name); pat_loc = loc; pat_extra = []; - pat_mode = Btype.Value_mode.global; + pat_mode = Types.Value_mode.global; pat_type = exp.exp_type; pat_env = exp.exp_env; pat_attributes = []; } @@ -425,7 +426,7 @@ let execute_phrase print_outcome ppf phr = in Compilenv.reset compilation_unit; Typecore.reset_delayed_checks (); - let (str, sg, names, newenv) = + let (str, sg, names, _shape, newenv) = Typemod.type_toplevel_phrase oldenv oldsig sstr in if !Clflags.dump_typedtree then Printtyped.implementation ppf str; @@ -439,7 +440,7 @@ let execute_phrase print_outcome ppf phr = [{ vb_expr = e ; vb_pat = { pat_desc = Tpat_any; - pat_extra = []; _ } + _ } ; vb_attributes = attrs }]) ; str_loc = loc } ] -> @@ -447,30 +448,33 @@ let execute_phrase print_outcome ppf phr = str, sg', true | _ -> str, sg', false in - let module_ident, res, required_globals, size = + let compilation_unit, res, required_globals, size = if any_flambda then - let { Lambda.module_ident; main_module_block_size = size; + let { Lambda.compilation_unit; main_module_block_size = size; required_globals; code = res } = - Translmod.transl_implementation_flambda !phrase_name + Translmod.transl_implementation_flambda compilation_unit (str, coercion) in - remember module_ident 0 sg'; - module_ident, close_phrase res, required_globals, size + remember compilation_unit 0 sg'; + compilation_unit, close_phrase res, required_globals, size else - let size, res = Translmod.transl_store_phrases !phrase_name str in - Ident.create_persistent !phrase_name, res, Ident.Set.empty, size + let size, res = Translmod.transl_store_phrases compilation_unit str in + compilation_unit, res, Compilation_unit.Set.empty, size in Warnings.check_fatal (); begin try toplevel_env := newenv; toplevel_sig := List.rev_append sg' oldsig; - let res = load_lambda ppf ~required_globals ~module_ident res size in + let res = + load_lambda ppf ~required_globals ~compilation_unit res size + in let out_phr = match res with | Result _ -> if any_flambda then (* CR-someday trefis: *) - Env.register_import_as_opaque (Ident.name module_ident) + Env.register_import_as_opaque + (Compilation_unit.name compilation_unit) else Compilenv.record_global_approx_toplevel (); if print_outcome then @@ -731,7 +735,7 @@ let set_paths () = [expand "+camlp4"]; ] in - Load_path.init load_path + Load_path.init ~auto_include:Compmisc.auto_include load_path let initialize_toplevel_env () = toplevel_env := Compmisc.initial_env(); diff --git a/ocaml/.depend b/ocaml/.depend index 62d5dc5955b..2676979c6d6 100644 --- a/ocaml/.depend +++ b/ocaml/.depend @@ -75,6 +75,24 @@ utils/consistbl.cmx : \ utils/consistbl.cmi utils/consistbl.cmi : \ utils/misc.cmi +utils/diffing.cmo : \ + utils/misc.cmi \ + utils/diffing.cmi +utils/diffing.cmx : \ + utils/misc.cmx \ + utils/diffing.cmi +utils/diffing.cmi : \ + utils/misc.cmi +utils/diffing_with_keys.cmo : \ + utils/misc.cmi \ + utils/diffing.cmi \ + utils/diffing_with_keys.cmi +utils/diffing_with_keys.cmx : \ + utils/misc.cmx \ + utils/diffing.cmx \ + utils/diffing_with_keys.cmi +utils/diffing_with_keys.cmi : \ + utils/diffing.cmi utils/domainstate.cmo : \ utils/domainstate.cmi utils/domainstate.cmx : \ @@ -87,11 +105,26 @@ utils/identifiable.cmx : \ utils/misc.cmx \ utils/identifiable.cmi utils/identifiable.cmi : +utils/import_info.cmo : \ + utils/misc.cmi \ + utils/compilation_unit.cmi \ + utils/import_info.cmi +utils/import_info.cmx : \ + utils/misc.cmx \ + utils/compilation_unit.cmx \ + utils/import_info.cmi +utils/import_info.cmi : \ + utils/compilation_unit.cmi utils/int_replace_polymorphic_compare.cmo : \ utils/int_replace_polymorphic_compare.cmi utils/int_replace_polymorphic_compare.cmx : \ utils/int_replace_polymorphic_compare.cmi utils/int_replace_polymorphic_compare.cmi : +utils/lazy_backtrack.cmo : \ + utils/lazy_backtrack.cmi +utils/lazy_backtrack.cmx : \ + utils/lazy_backtrack.cmi +utils/lazy_backtrack.cmi : utils/linkage_name.cmo : \ utils/int_replace_polymorphic_compare.cmi \ utils/identifiable.cmi \ @@ -265,6 +298,7 @@ parsing/ast_mapper.cmo : \ utils/load_path.cmi \ utils/config.cmi \ utils/clflags.cmi \ + parsing/builtin_attributes.cmi \ parsing/asttypes.cmi \ parsing/ast_helper.cmi \ parsing/ast_mapper.cmi @@ -276,6 +310,7 @@ parsing/ast_mapper.cmx : \ utils/load_path.cmx \ utils/config.cmx \ utils/clflags.cmx \ + parsing/builtin_attributes.cmx \ parsing/asttypes.cmi \ parsing/ast_helper.cmx \ parsing/ast_mapper.cmi @@ -287,11 +322,13 @@ parsing/asttypes.cmi : \ parsing/attr_helper.cmo : \ parsing/parsetree.cmi \ parsing/location.cmi \ + parsing/builtin_attributes.cmi \ parsing/asttypes.cmi \ parsing/attr_helper.cmi parsing/attr_helper.cmx : \ parsing/parsetree.cmi \ parsing/location.cmx \ + parsing/builtin_attributes.cmx \ parsing/asttypes.cmi \ parsing/attr_helper.cmi parsing/attr_helper.cmi : \ @@ -307,6 +344,7 @@ parsing/builtin_attributes.cmo : \ utils/config.cmi \ utils/clflags.cmi \ parsing/asttypes.cmi \ + parsing/ast_helper.cmi \ parsing/builtin_attributes.cmi parsing/builtin_attributes.cmx : \ utils/warnings.cmx \ @@ -317,6 +355,7 @@ parsing/builtin_attributes.cmx : \ utils/config.cmx \ utils/clflags.cmx \ parsing/asttypes.cmi \ + parsing/ast_helper.cmx \ parsing/builtin_attributes.cmi parsing/builtin_attributes.cmi : \ parsing/parsetree.cmi \ @@ -448,6 +487,7 @@ parsing/parser.cmo : \ parsing/docstrings.cmi \ utils/clflags.cmi \ parsing/camlinternalMenhirLib.cmi \ + parsing/builtin_attributes.cmi \ parsing/asttypes.cmi \ parsing/ast_helper.cmi \ parsing/parser.cmi @@ -460,6 +500,7 @@ parsing/parser.cmx : \ parsing/docstrings.cmx \ utils/clflags.cmx \ parsing/camlinternalMenhirLib.cmx \ + parsing/builtin_attributes.cmx \ parsing/asttypes.cmi \ parsing/ast_helper.cmx \ parsing/parser.cmi @@ -521,7 +562,6 @@ typing/annot.cmi : \ typing/btype.cmo : \ typing/types.cmi \ typing/path.cmi \ - utils/misc.cmi \ utils/local_store.cmi \ typing/ident.cmi \ parsing/asttypes.cmi \ @@ -529,7 +569,6 @@ typing/btype.cmo : \ typing/btype.cmx : \ typing/types.cmx \ typing/path.cmx \ - utils/misc.cmx \ utils/local_store.cmx \ typing/ident.cmx \ parsing/asttypes.cmi \ @@ -578,6 +617,7 @@ typing/ctype.cmo : \ parsing/location.cmi \ utils/local_store.cmi \ typing/ident.cmi \ + typing/errortrace.cmi \ typing/env.cmi \ utils/clflags.cmi \ typing/btype.cmi \ @@ -595,6 +635,7 @@ typing/ctype.cmx : \ parsing/location.cmx \ utils/local_store.cmx \ typing/ident.cmx \ + typing/errortrace.cmx \ typing/env.cmx \ utils/clflags.cmx \ typing/btype.cmx \ @@ -606,8 +647,11 @@ typing/ctype.cmi : \ typing/primitive.cmi \ typing/path.cmi \ parsing/longident.cmi \ + parsing/location.cmi \ typing/ident.cmi \ + typing/errortrace.cmi \ typing/env.cmi \ + typing/btype.cmi \ parsing/asttypes.cmi typing/datarepr.cmo : \ typing/types.cmi \ @@ -628,11 +672,13 @@ typing/datarepr.cmx : \ typing/datarepr.cmi : \ typing/types.cmi \ typing/path.cmi \ - typing/ident.cmi + typing/ident.cmi \ + utils/compilation_unit.cmi typing/env.cmo : \ utils/warnings.cmi \ typing/types.cmi \ typing/subst.cmi \ + typing/shape.cmi \ typing/predef.cmi \ typing/persistent_env.cmi \ typing/path.cmi \ @@ -641,8 +687,10 @@ typing/env.cmo : \ parsing/location.cmi \ utils/local_store.cmi \ utils/load_path.cmi \ + utils/lazy_backtrack.cmi \ typing/ident.cmi \ typing/datarepr.cmi \ + utils/compilation_unit.cmi \ file_formats/cmi_format.cmi \ utils/clflags.cmi \ parsing/builtin_attributes.cmi \ @@ -653,6 +701,7 @@ typing/env.cmx : \ utils/warnings.cmx \ typing/types.cmx \ typing/subst.cmx \ + typing/shape.cmx \ typing/predef.cmx \ typing/persistent_env.cmx \ typing/path.cmx \ @@ -661,8 +710,10 @@ typing/env.cmx : \ parsing/location.cmx \ utils/local_store.cmx \ utils/load_path.cmx \ + utils/lazy_backtrack.cmx \ typing/ident.cmx \ typing/datarepr.cmx \ + utils/compilation_unit.cmx \ file_formats/cmi_format.cmx \ utils/clflags.cmx \ parsing/builtin_attributes.cmx \ @@ -673,12 +724,15 @@ typing/env.cmi : \ utils/warnings.cmi \ typing/types.cmi \ typing/subst.cmi \ + typing/shape.cmi \ typing/path.cmi \ utils/misc.cmi \ parsing/longident.cmi \ parsing/location.cmi \ utils/load_path.cmi \ + utils/import_info.cmi \ typing/ident.cmi \ + utils/compilation_unit.cmi \ file_formats/cmi_format.cmi \ parsing/asttypes.cmi typing/envaux.cmo : \ @@ -703,6 +757,20 @@ typing/envaux.cmi : \ typing/subst.cmi \ typing/path.cmi \ typing/env.cmi +typing/errortrace.cmo : \ + typing/types.cmi \ + typing/path.cmi \ + parsing/asttypes.cmi \ + typing/errortrace.cmi +typing/errortrace.cmx : \ + typing/types.cmx \ + typing/path.cmx \ + parsing/asttypes.cmi \ + typing/errortrace.cmi +typing/errortrace.cmi : \ + typing/types.cmi \ + typing/path.cmi \ + parsing/asttypes.cmi typing/ident.cmo : \ utils/misc.cmi \ utils/local_store.cmi \ @@ -733,6 +801,7 @@ typing/includeclass.cmx : \ typing/includeclass.cmi typing/includeclass.cmi : \ typing/types.cmi \ + typing/printtyp.cmi \ parsing/location.cmi \ typing/env.cmi \ typing/ctype.cmi @@ -743,8 +812,11 @@ typing/includecore.cmo : \ typing/printtyp.cmi \ typing/primitive.cmi \ typing/path.cmi \ + utils/misc.cmi \ typing/ident.cmi \ + typing/errortrace.cmi \ typing/env.cmi \ + utils/diffing_with_keys.cmi \ typing/ctype.cmi \ parsing/builtin_attributes.cmi \ typing/btype.cmi \ @@ -757,8 +829,11 @@ typing/includecore.cmx : \ typing/printtyp.cmx \ typing/primitive.cmx \ typing/path.cmx \ + utils/misc.cmx \ typing/ident.cmx \ + typing/errortrace.cmx \ typing/env.cmx \ + utils/diffing_with_keys.cmx \ typing/ctype.cmx \ parsing/builtin_attributes.cmx \ typing/btype.cmx \ @@ -771,27 +846,29 @@ typing/includecore.cmi : \ typing/path.cmi \ parsing/location.cmi \ typing/ident.cmi \ + typing/errortrace.cmi \ typing/env.cmi \ - typing/ctype.cmi + utils/diffing_with_keys.cmi typing/includemod.cmo : \ typing/types.cmi \ typing/typedtree.cmi \ typing/subst.cmi \ + typing/shape.cmi \ typing/printtyp.cmi \ typing/primitive.cmi \ typing/predef.cmi \ typing/path.cmi \ - typing/oprint.cmi \ typing/mtype.cmi \ utils/misc.cmi \ + parsing/longident.cmi \ parsing/location.cmi \ typing/includecore.cmi \ typing/includeclass.cmi \ typing/ident.cmi \ typing/env.cmi \ + utils/diffing.cmi \ typing/ctype.cmi \ file_formats/cmt_format.cmi \ - utils/clflags.cmi \ parsing/builtin_attributes.cmi \ typing/btype.cmi \ typing/includemod.cmi @@ -799,33 +876,71 @@ typing/includemod.cmx : \ typing/types.cmx \ typing/typedtree.cmx \ typing/subst.cmx \ + typing/shape.cmx \ typing/printtyp.cmx \ typing/primitive.cmx \ typing/predef.cmx \ typing/path.cmx \ - typing/oprint.cmx \ typing/mtype.cmx \ utils/misc.cmx \ + parsing/longident.cmx \ parsing/location.cmx \ typing/includecore.cmx \ typing/includeclass.cmx \ typing/ident.cmx \ typing/env.cmx \ + utils/diffing.cmx \ typing/ctype.cmx \ file_formats/cmt_format.cmx \ - utils/clflags.cmx \ parsing/builtin_attributes.cmx \ typing/btype.cmx \ typing/includemod.cmi typing/includemod.cmi : \ typing/types.cmi \ typing/typedtree.cmi \ + typing/shape.cmi \ typing/path.cmi \ + parsing/longident.cmi \ parsing/location.cmi \ typing/includecore.cmi \ typing/ident.cmi \ typing/env.cmi \ + utils/diffing.cmi \ typing/ctype.cmi +typing/includemod_errorprinter.cmo : \ + typing/types.cmi \ + typing/typedtree.cmi \ + typing/printtyp.cmi \ + typing/path.cmi \ + typing/oprint.cmi \ + utils/misc.cmi \ + parsing/location.cmi \ + typing/includemod.cmi \ + typing/includecore.cmi \ + typing/includeclass.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + utils/diffing.cmi \ + utils/clflags.cmi \ + typing/includemod_errorprinter.cmi +typing/includemod_errorprinter.cmx : \ + typing/types.cmx \ + typing/typedtree.cmx \ + typing/printtyp.cmx \ + typing/path.cmx \ + typing/oprint.cmx \ + utils/misc.cmx \ + parsing/location.cmx \ + typing/includemod.cmx \ + typing/includecore.cmx \ + typing/includeclass.cmx \ + typing/ident.cmx \ + typing/env.cmx \ + utils/diffing.cmx \ + utils/clflags.cmx \ + typing/includemod_errorprinter.cmi +typing/includemod_errorprinter.cmi : \ + typing/includemod.cmi typing/mtype.cmo : \ typing/types.cmi \ typing/subst.cmi \ @@ -926,9 +1041,11 @@ typing/parmatch.cmi : \ typing/env.cmi \ parsing/asttypes.cmi typing/path.cmo : \ + utils/misc.cmi \ typing/ident.cmi \ typing/path.cmi typing/path.cmx : \ + utils/misc.cmx \ typing/ident.cmx \ typing/path.cmi typing/path.cmi : \ @@ -941,7 +1058,6 @@ typing/patterns.cmo : \ typing/ident.cmi \ typing/env.cmi \ typing/ctype.cmi \ - typing/btype.cmi \ parsing/asttypes.cmi \ typing/patterns.cmi typing/patterns.cmx : \ @@ -952,7 +1068,6 @@ typing/patterns.cmx : \ typing/ident.cmx \ typing/env.cmx \ typing/ctype.cmx \ - typing/btype.cmx \ parsing/asttypes.cmi \ typing/patterns.cmi typing/patterns.cmi : \ @@ -966,8 +1081,11 @@ typing/persistent_env.cmo : \ utils/misc.cmi \ parsing/location.cmi \ utils/load_path.cmi \ + utils/lazy_backtrack.cmi \ + utils/import_info.cmi \ utils/consistbl.cmi \ utils/config.cmi \ + utils/compilation_unit.cmi \ file_formats/cmi_format.cmi \ utils/clflags.cmi \ typing/persistent_env.cmi @@ -976,8 +1094,11 @@ typing/persistent_env.cmx : \ utils/misc.cmx \ parsing/location.cmx \ utils/load_path.cmx \ + utils/lazy_backtrack.cmx \ + utils/import_info.cmx \ utils/consistbl.cmx \ utils/config.cmx \ + utils/compilation_unit.cmx \ file_formats/cmi_format.cmx \ utils/clflags.cmx \ typing/persistent_env.cmi @@ -985,7 +1106,10 @@ typing/persistent_env.cmi : \ typing/types.cmi \ utils/misc.cmi \ parsing/location.cmi \ + utils/lazy_backtrack.cmi \ + utils/import_info.cmi \ utils/consistbl.cmi \ + utils/compilation_unit.cmi \ file_formats/cmi_format.cmi typing/predef.cmo : \ typing/types.cmi \ @@ -1050,6 +1174,7 @@ typing/printtyp.cmo : \ utils/warnings.cmi \ typing/types.cmi \ typing/type_immediacy.cmi \ + typing/signature_group.cmi \ typing/primitive.cmi \ typing/predef.cmi \ typing/path.cmi \ @@ -1060,8 +1185,10 @@ typing/printtyp.cmo : \ parsing/longident.cmi \ parsing/location.cmi \ typing/ident.cmi \ + typing/errortrace.cmi \ typing/env.cmi \ typing/ctype.cmi \ + utils/compilation_unit.cmi \ utils/clflags.cmi \ typing/btype.cmi \ parsing/asttypes.cmi \ @@ -1070,6 +1197,7 @@ typing/printtyp.cmx : \ utils/warnings.cmx \ typing/types.cmx \ typing/type_immediacy.cmx \ + typing/signature_group.cmx \ typing/primitive.cmx \ typing/predef.cmx \ typing/path.cmx \ @@ -1080,8 +1208,10 @@ typing/printtyp.cmx : \ parsing/longident.cmx \ parsing/location.cmx \ typing/ident.cmx \ + typing/errortrace.cmx \ typing/env.cmx \ typing/ctype.cmx \ + utils/compilation_unit.cmx \ utils/clflags.cmx \ typing/btype.cmx \ parsing/asttypes.cmi \ @@ -1093,33 +1223,33 @@ typing/printtyp.cmi : \ parsing/longident.cmi \ parsing/location.cmi \ typing/ident.cmi \ + typing/errortrace.cmi \ typing/env.cmi \ - typing/ctype.cmi \ parsing/asttypes.cmi typing/printtyped.cmo : \ typing/types.cmi \ typing/typedtree.cmi \ parsing/printast.cmi \ + parsing/pprintast.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ parsing/longident.cmi \ parsing/location.cmi \ typing/ident.cmi \ utils/clflags.cmi \ - typing/btype.cmi \ parsing/asttypes.cmi \ typing/printtyped.cmi typing/printtyped.cmx : \ typing/types.cmx \ typing/typedtree.cmx \ parsing/printast.cmx \ + parsing/pprintast.cmx \ typing/path.cmx \ parsing/parsetree.cmi \ parsing/longident.cmx \ parsing/location.cmx \ typing/ident.cmx \ utils/clflags.cmx \ - typing/btype.cmx \ parsing/asttypes.cmi \ typing/printtyped.cmi typing/printtyped.cmi : \ @@ -1147,6 +1277,37 @@ typing/rec_check.cmx : \ typing/rec_check.cmi : \ typing/typedtree.cmi \ typing/ident.cmi +typing/shape.cmo : \ + typing/path.cmi \ + utils/misc.cmi \ + utils/identifiable.cmi \ + typing/ident.cmi \ + utils/compilation_unit.cmi \ + typing/shape.cmi +typing/shape.cmx : \ + typing/path.cmx \ + utils/misc.cmx \ + utils/identifiable.cmx \ + typing/ident.cmx \ + utils/compilation_unit.cmx \ + typing/shape.cmi +typing/shape.cmi : \ + typing/path.cmi \ + utils/identifiable.cmi \ + typing/ident.cmi \ + utils/compilation_unit.cmi +typing/signature_group.cmo : \ + typing/types.cmi \ + typing/ident.cmi \ + typing/btype.cmi \ + typing/signature_group.cmi +typing/signature_group.cmx : \ + typing/types.cmx \ + typing/ident.cmx \ + typing/btype.cmx \ + typing/signature_group.cmi +typing/signature_group.cmi : \ + typing/types.cmi typing/stypes.cmo : \ typing/typedtree.cmi \ typing/printtyp.cmi \ @@ -1174,6 +1335,7 @@ typing/subst.cmo : \ utils/misc.cmi \ parsing/location.cmi \ utils/local_store.cmi \ + utils/lazy_backtrack.cmi \ typing/ident.cmi \ utils/clflags.cmi \ typing/btype.cmi \ @@ -1186,6 +1348,7 @@ typing/subst.cmx : \ utils/misc.cmx \ parsing/location.cmx \ utils/local_store.cmx \ + utils/lazy_backtrack.cmx \ typing/ident.cmx \ utils/clflags.cmx \ typing/btype.cmx \ @@ -1251,6 +1414,7 @@ typing/typeclass.cmo : \ parsing/location.cmi \ typing/includeclass.cmi \ typing/ident.cmi \ + typing/errortrace.cmi \ typing/env.cmi \ typing/ctype.cmi \ file_formats/cmt_format.cmi \ @@ -1278,6 +1442,7 @@ typing/typeclass.cmx : \ parsing/location.cmx \ typing/includeclass.cmx \ typing/ident.cmx \ + typing/errortrace.cmx \ typing/env.cmx \ typing/ctype.cmx \ file_formats/cmt_format.cmx \ @@ -1294,6 +1459,7 @@ typing/typeclass.cmi : \ parsing/longident.cmi \ parsing/location.cmi \ typing/ident.cmi \ + typing/errortrace.cmi \ typing/env.cmi \ typing/ctype.cmi \ parsing/asttypes.cmi @@ -1303,7 +1469,9 @@ typing/typecore.cmo : \ typing/types.cmi \ typing/typedtree.cmi \ typing/typedecl.cmi \ + typing/type_immediacy.cmi \ typing/subst.cmi \ + typing/shape.cmi \ typing/rec_check.cmi \ typing/printtyp.cmi \ typing/printpat.cmi \ @@ -1320,6 +1488,7 @@ typing/typecore.cmo : \ utils/local_store.cmi \ typing/ident.cmi \ parsing/extensions.cmi \ + typing/errortrace.cmi \ typing/env.cmi \ typing/ctype.cmi \ file_formats/cmt_format.cmi \ @@ -1335,7 +1504,9 @@ typing/typecore.cmx : \ typing/types.cmx \ typing/typedtree.cmx \ typing/typedecl.cmx \ + typing/type_immediacy.cmx \ typing/subst.cmx \ + typing/shape.cmx \ typing/rec_check.cmx \ typing/printtyp.cmx \ typing/printpat.cmx \ @@ -1352,6 +1523,7 @@ typing/typecore.cmx : \ utils/local_store.cmx \ typing/ident.cmx \ parsing/extensions.cmx \ + typing/errortrace.cmx \ typing/env.cmx \ typing/ctype.cmx \ file_formats/cmt_format.cmx \ @@ -1364,15 +1536,15 @@ typing/typecore.cmx : \ typing/typecore.cmi : \ typing/types.cmi \ typing/typedtree.cmi \ + typing/shape.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ parsing/longident.cmi \ parsing/location.cmi \ typing/ident.cmi \ + typing/errortrace.cmi \ typing/env.cmi \ - typing/ctype.cmi \ utils/clflags.cmi \ - typing/btype.cmi \ parsing/asttypes.cmi typing/typedecl.cmo : \ utils/warnings.cmi \ @@ -1397,6 +1569,7 @@ typing/typedecl.cmo : \ parsing/location.cmi \ typing/includecore.cmi \ typing/ident.cmi \ + typing/errortrace.cmi \ typing/env.cmi \ typing/ctype.cmi \ utils/config.cmi \ @@ -1431,6 +1604,7 @@ typing/typedecl.cmx : \ parsing/location.cmx \ typing/includecore.cmx \ typing/ident.cmx \ + typing/errortrace.cmx \ typing/env.cmx \ typing/ctype.cmx \ utils/config.cmx \ @@ -1454,8 +1628,8 @@ typing/typedecl.cmi : \ parsing/location.cmi \ typing/includecore.cmi \ typing/ident.cmi \ + typing/errortrace.cmi \ typing/env.cmi \ - typing/ctype.cmi \ parsing/asttypes.cmi typing/typedecl_immediacy.cmo : \ typing/types.cmi \ @@ -1504,7 +1678,6 @@ typing/typedecl_separability.cmo : \ typing/ctype.cmi \ utils/config.cmi \ typing/btype.cmi \ - parsing/asttypes.cmi \ typing/typedecl_separability.cmi typing/typedecl_separability.cmx : \ typing/types.cmx \ @@ -1514,7 +1687,6 @@ typing/typedecl_separability.cmx : \ typing/ctype.cmx \ utils/config.cmx \ typing/btype.cmx \ - parsing/asttypes.cmi \ typing/typedecl_separability.cmi typing/typedecl_separability.cmi : \ typing/types.cmi \ @@ -1524,13 +1696,11 @@ typing/typedecl_separability.cmi : \ typing/env.cmi typing/typedecl_unboxed.cmo : \ typing/types.cmi \ - typing/predef.cmi \ typing/env.cmi \ typing/ctype.cmi \ typing/typedecl_unboxed.cmi typing/typedecl_unboxed.cmx : \ typing/types.cmx \ - typing/predef.cmx \ typing/env.cmx \ typing/ctype.cmx \ typing/typedecl_unboxed.cmi @@ -1573,6 +1743,7 @@ typing/typedecl_variance.cmi : \ typing/typedtree.cmo : \ utils/warnings.cmi \ typing/types.cmi \ + typing/shape.cmi \ typing/primitive.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ @@ -1585,6 +1756,7 @@ typing/typedtree.cmo : \ typing/typedtree.cmx : \ utils/warnings.cmx \ typing/types.cmx \ + typing/shape.cmx \ typing/primitive.cmx \ typing/path.cmx \ parsing/parsetree.cmi \ @@ -1597,6 +1769,7 @@ typing/typedtree.cmx : \ typing/typedtree.cmi : \ utils/warnings.cmi \ typing/types.cmi \ + typing/shape.cmi \ typing/primitive.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ @@ -1614,6 +1787,8 @@ typing/typemod.cmo : \ typing/typecore.cmi \ typing/typeclass.cmi \ typing/subst.cmi \ + typing/signature_group.cmi \ + typing/shape.cmi \ typing/printtyp.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ @@ -1623,12 +1798,15 @@ typing/typemod.cmo : \ parsing/longident.cmi \ parsing/location.cmi \ utils/load_path.cmi \ + typing/includemod_errorprinter.cmi \ typing/includemod.cmi \ + utils/import_info.cmi \ typing/ident.cmi \ typing/envaux.cmi \ typing/env.cmi \ typing/ctype.cmi \ utils/config.cmi \ + utils/compilation_unit.cmi \ file_formats/cmt_format.cmi \ typing/cmt2annot.cmo \ file_formats/cmi_format.cmi \ @@ -1647,6 +1825,8 @@ typing/typemod.cmx : \ typing/typecore.cmx \ typing/typeclass.cmx \ typing/subst.cmx \ + typing/signature_group.cmx \ + typing/shape.cmx \ typing/printtyp.cmx \ typing/path.cmx \ parsing/parsetree.cmi \ @@ -1656,12 +1836,15 @@ typing/typemod.cmx : \ parsing/longident.cmx \ parsing/location.cmx \ utils/load_path.cmx \ + typing/includemod_errorprinter.cmx \ typing/includemod.cmx \ + utils/import_info.cmx \ typing/ident.cmx \ typing/envaux.cmx \ typing/env.cmx \ typing/ctype.cmx \ utils/config.cmx \ + utils/compilation_unit.cmx \ file_formats/cmt_format.cmx \ typing/cmt2annot.cmx \ file_formats/cmi_format.cmx \ @@ -1675,6 +1858,7 @@ typing/typemod.cmi : \ typing/types.cmi \ typing/typedtree.cmi \ typing/typedecl.cmi \ + typing/shape.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ parsing/longident.cmi \ @@ -1682,12 +1866,13 @@ typing/typemod.cmi : \ typing/includemod.cmi \ typing/ident.cmi \ typing/env.cmi \ - file_formats/cmi_format.cmi \ - utils/clflags.cmi + utils/compilation_unit.cmi \ + file_formats/cmi_format.cmi typing/typeopt.cmo : \ typing/types.cmi \ typing/typedtree.cmi \ - typing/typedecl.cmi \ + typing/typedecl_unboxed.cmi \ + typing/type_immediacy.cmi \ typing/predef.cmi \ typing/path.cmi \ utils/numbers.cmi \ @@ -1697,12 +1882,14 @@ typing/typeopt.cmo : \ typing/env.cmi \ typing/ctype.cmi \ utils/config.cmi \ + utils/clflags.cmi \ parsing/asttypes.cmi \ typing/typeopt.cmi typing/typeopt.cmx : \ typing/types.cmx \ typing/typedtree.cmx \ - typing/typedecl.cmx \ + typing/typedecl_unboxed.cmx \ + typing/type_immediacy.cmx \ typing/predef.cmx \ typing/path.cmx \ utils/numbers.cmx \ @@ -1712,6 +1899,7 @@ typing/typeopt.cmx : \ typing/env.cmx \ typing/ctype.cmx \ utils/config.cmx \ + utils/clflags.cmx \ parsing/asttypes.cmi \ typing/typeopt.cmi typing/typeopt.cmi : \ @@ -1722,38 +1910,40 @@ typing/typeopt.cmi : \ typing/env.cmi typing/types.cmo : \ typing/type_immediacy.cmi \ + typing/shape.cmi \ typing/primitive.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ utils/misc.cmi \ parsing/longident.cmi \ parsing/location.cmi \ - utils/identifiable.cmi \ + utils/local_store.cmi \ typing/ident.cmi \ utils/config.cmi \ parsing/asttypes.cmi \ typing/types.cmi typing/types.cmx : \ typing/type_immediacy.cmx \ + typing/shape.cmx \ typing/primitive.cmx \ typing/path.cmx \ parsing/parsetree.cmi \ utils/misc.cmx \ parsing/longident.cmx \ parsing/location.cmx \ - utils/identifiable.cmx \ + utils/local_store.cmx \ typing/ident.cmx \ utils/config.cmx \ parsing/asttypes.cmi \ typing/types.cmi typing/types.cmi : \ typing/type_immediacy.cmi \ + typing/shape.cmi \ typing/primitive.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ parsing/longident.cmi \ parsing/location.cmi \ - utils/identifiable.cmi \ typing/ident.cmi \ parsing/asttypes.cmi typing/typetexp.cmo : \ @@ -1768,6 +1958,7 @@ typing/typetexp.cmo : \ utils/misc.cmi \ parsing/longident.cmi \ parsing/location.cmi \ + typing/errortrace.cmi \ typing/env.cmi \ typing/ctype.cmi \ utils/clflags.cmi \ @@ -1788,6 +1979,7 @@ typing/typetexp.cmx : \ utils/misc.cmx \ parsing/longident.cmx \ parsing/location.cmx \ + typing/errortrace.cmx \ typing/env.cmx \ typing/ctype.cmx \ utils/clflags.cmx \ @@ -1803,8 +1995,9 @@ typing/typetexp.cmi : \ parsing/parsetree.cmi \ parsing/longident.cmi \ parsing/location.cmi \ + typing/errortrace.cmi \ typing/env.cmi \ - typing/ctype.cmi \ + utils/clflags.cmi \ parsing/asttypes.cmi typing/untypeast.cmo : \ typing/typedtree.cmi \ @@ -1850,6 +2043,7 @@ bytecomp/bytegen.cmo : \ typing/env.cmi \ lambda/debuginfo.cmi \ utils/config.cmi \ + utils/compilation_unit.cmi \ utils/clflags.cmi \ parsing/asttypes.cmi \ bytecomp/bytegen.cmi @@ -1866,6 +2060,7 @@ bytecomp/bytegen.cmx : \ typing/env.cmx \ lambda/debuginfo.cmx \ utils/config.cmx \ + utils/compilation_unit.cmx \ utils/clflags.cmx \ parsing/asttypes.cmi \ bytecomp/bytegen.cmi @@ -1901,6 +2096,7 @@ bytecomp/bytelink.cmo : \ parsing/location.cmi \ utils/load_path.cmi \ bytecomp/instruct.cmi \ + utils/import_info.cmi \ typing/ident.cmi \ bytecomp/emitcode.cmi \ bytecomp/dll.cmi \ @@ -1920,6 +2116,7 @@ bytecomp/bytelink.cmx : \ parsing/location.cmx \ utils/load_path.cmx \ bytecomp/instruct.cmx \ + utils/import_info.cmx \ typing/ident.cmx \ bytecomp/emitcode.cmx \ bytecomp/dll.cmx \ @@ -1934,6 +2131,8 @@ bytecomp/bytelink.cmx : \ bytecomp/bytelink.cmi : \ bytecomp/symtable.cmi \ utils/misc.cmi \ + utils/import_info.cmi \ + utils/compilation_unit.cmi \ file_formats/cmo_format.cmi bytecomp/bytepackager.cmo : \ typing/typemod.cmi \ @@ -1946,6 +2145,7 @@ bytecomp/bytepackager.cmo : \ parsing/location.cmi \ utils/load_path.cmi \ bytecomp/instruct.cmi \ + utils/import_info.cmi \ typing/ident.cmi \ typing/env.cmi \ bytecomp/emitcode.cmi \ @@ -1967,6 +2167,7 @@ bytecomp/bytepackager.cmx : \ parsing/location.cmx \ utils/load_path.cmx \ bytecomp/instruct.cmx \ + utils/import_info.cmx \ typing/ident.cmx \ typing/env.cmx \ bytecomp/emitcode.cmx \ @@ -1979,7 +2180,8 @@ bytecomp/bytepackager.cmx : \ bytecomp/bytepackager.cmi bytecomp/bytepackager.cmi : \ typing/ident.cmi \ - typing/env.cmi + typing/env.cmi \ + utils/compilation_unit.cmi bytecomp/bytesections.cmo : \ utils/config.cmi \ bytecomp/bytesections.cmi @@ -2012,7 +2214,6 @@ bytecomp/emitcode.cmo : \ parsing/location.cmi \ lambda/lambda.cmi \ bytecomp/instruct.cmi \ - typing/ident.cmi \ typing/env.cmi \ utils/config.cmi \ utils/compilation_unit.cmi \ @@ -2030,7 +2231,6 @@ bytecomp/emitcode.cmx : \ parsing/location.cmx \ lambda/lambda.cmx \ bytecomp/instruct.cmx \ - typing/ident.cmx \ typing/env.cmx \ utils/config.cmx \ utils/compilation_unit.cmx \ @@ -2043,7 +2243,7 @@ bytecomp/emitcode.cmx : \ bytecomp/emitcode.cmi : \ utils/misc.cmi \ bytecomp/instruct.cmi \ - typing/ident.cmi \ + utils/compilation_unit.cmi \ file_formats/cmo_format.cmi bytecomp/instruct.cmo : \ typing/types.cmi \ @@ -2107,6 +2307,7 @@ bytecomp/symtable.cmo : \ bytecomp/meta.cmi \ parsing/location.cmi \ lambda/lambda.cmi \ + utils/import_info.cmi \ typing/ident.cmi \ bytecomp/dll.cmi \ utils/config.cmi \ @@ -2122,6 +2323,7 @@ bytecomp/symtable.cmx : \ bytecomp/meta.cmx \ parsing/location.cmx \ lambda/lambda.cmx \ + utils/import_info.cmx \ typing/ident.cmx \ bytecomp/dll.cmx \ utils/config.cmx \ @@ -2133,6 +2335,7 @@ bytecomp/symtable.cmx : \ bytecomp/symtable.cmi : \ utils/misc.cmi \ lambda/lambda.cmi \ + utils/import_info.cmi \ typing/ident.cmi \ file_formats/cmo_format.cmi asmcomp/CSE.cmo : \ @@ -2195,6 +2398,7 @@ asmcomp/asmgen.cmo : \ asmcomp/printlinear.cmi \ asmcomp/printcmm.cmi \ typing/primitive.cmi \ + asmcomp/polling.cmi \ utils/misc.cmi \ asmcomp/mach.cmi \ parsing/location.cmi \ @@ -2206,7 +2410,6 @@ asmcomp/asmgen.cmo : \ lambda/lambda.cmi \ asmcomp/interval.cmi \ asmcomp/interf.cmi \ - typing/ident.cmi \ asmcomp/emitaux.cmi \ asmcomp/emit.cmi \ asmcomp/deadcode.cmi \ @@ -2223,7 +2426,6 @@ asmcomp/asmgen.cmo : \ middle_end/clambda.cmi \ asmcomp/CSE.cmo \ middle_end/backend_intf.cmi \ - asmcomp/debug/available_regs.cmi \ asmcomp/asmgen.cmi asmcomp/asmgen.cmx : \ lambda/translmod.cmx \ @@ -2239,6 +2441,7 @@ asmcomp/asmgen.cmx : \ asmcomp/printlinear.cmx \ asmcomp/printcmm.cmx \ typing/primitive.cmx \ + asmcomp/polling.cmx \ utils/misc.cmx \ asmcomp/mach.cmx \ parsing/location.cmx \ @@ -2250,7 +2453,6 @@ asmcomp/asmgen.cmx : \ lambda/lambda.cmx \ asmcomp/interval.cmx \ asmcomp/interf.cmx \ - typing/ident.cmx \ asmcomp/emitaux.cmx \ asmcomp/emit.cmx \ asmcomp/deadcode.cmx \ @@ -2267,11 +2469,11 @@ asmcomp/asmgen.cmx : \ middle_end/clambda.cmx \ asmcomp/CSE.cmx \ middle_end/backend_intf.cmi \ - asmcomp/debug/available_regs.cmx \ asmcomp/asmgen.cmi asmcomp/asmgen.cmi : \ lambda/lambda.cmi \ asmcomp/emitaux.cmi \ + utils/compilation_unit.cmi \ asmcomp/cmm.cmi \ middle_end/clambda.cmi \ middle_end/backend_intf.cmi @@ -2309,6 +2511,7 @@ asmcomp/asmlink.cmo : \ utils/misc.cmi \ parsing/location.cmi \ utils/load_path.cmi \ + utils/import_info.cmi \ asmcomp/emitaux.cmi \ asmcomp/emit.cmi \ utils/consistbl.cmi \ @@ -2329,6 +2532,7 @@ asmcomp/asmlink.cmx : \ utils/misc.cmx \ parsing/location.cmx \ utils/load_path.cmx \ + utils/import_info.cmx \ asmcomp/emitaux.cmx \ asmcomp/emit.cmx \ utils/consistbl.cmx \ @@ -2344,6 +2548,8 @@ asmcomp/asmlink.cmx : \ asmcomp/asmlink.cmi asmcomp/asmlink.cmi : \ utils/misc.cmi \ + utils/import_info.cmi \ + utils/compilation_unit.cmi \ file_formats/cmx_format.cmi asmcomp/asmpackager.cmo : \ typing/typemod.cmi \ @@ -2356,9 +2562,8 @@ asmcomp/asmpackager.cmo : \ utils/load_path.cmi \ utils/linkage_name.cmi \ lambda/lambda.cmi \ - typing/ident.cmi \ + utils/import_info.cmi \ middle_end/flambda/flambda_middle_end.cmi \ - middle_end/flambda/export_info_for_pack.cmi \ middle_end/flambda/export_info.cmi \ typing/env.cmi \ utils/config.cmi \ @@ -2382,9 +2587,8 @@ asmcomp/asmpackager.cmx : \ utils/load_path.cmx \ utils/linkage_name.cmx \ lambda/lambda.cmx \ - typing/ident.cmx \ + utils/import_info.cmx \ middle_end/flambda/flambda_middle_end.cmx \ - middle_end/flambda/export_info_for_pack.cmx \ middle_end/flambda/export_info.cmx \ typing/env.cmx \ utils/config.cmx \ @@ -2399,6 +2603,7 @@ asmcomp/asmpackager.cmx : \ asmcomp/asmpackager.cmi asmcomp/asmpackager.cmi : \ typing/env.cmi \ + utils/compilation_unit.cmi \ middle_end/backend_intf.cmi asmcomp/branch_relaxation.cmo : \ utils/misc.cmi \ @@ -2420,10 +2625,12 @@ asmcomp/branch_relaxation.cmi : \ asmcomp/branch_relaxation_intf.cmo : \ asmcomp/linear.cmi \ lambda/debuginfo.cmi \ + asmcomp/cmm.cmi \ asmcomp/arch.cmo asmcomp/branch_relaxation_intf.cmx : \ asmcomp/linear.cmx \ lambda/debuginfo.cmx \ + asmcomp/cmm.cmx \ asmcomp/arch.cmx asmcomp/cmm.cmo : \ utils/targetint.cmi \ @@ -2584,10 +2791,12 @@ asmcomp/cmmgen_state.cmi : \ asmcomp/coloring.cmo : \ asmcomp/reg.cmi \ asmcomp/proc.cmi \ + utils/misc.cmi \ asmcomp/coloring.cmi asmcomp/coloring.cmx : \ asmcomp/reg.cmx \ asmcomp/proc.cmx \ + utils/misc.cmx \ asmcomp/coloring.cmi asmcomp/coloring.cmi : asmcomp/comballoc.cmo : \ @@ -2608,6 +2817,16 @@ asmcomp/comballoc.cmx : \ asmcomp/comballoc.cmi asmcomp/comballoc.cmi : \ asmcomp/mach.cmi +asmcomp/dataflow.cmo : \ + asmcomp/mach.cmi \ + asmcomp/cmm.cmi \ + asmcomp/dataflow.cmi +asmcomp/dataflow.cmx : \ + asmcomp/mach.cmx \ + asmcomp/cmm.cmx \ + asmcomp/dataflow.cmi +asmcomp/dataflow.cmi : \ + asmcomp/mach.cmi asmcomp/deadcode.cmo : \ asmcomp/reg.cmi \ asmcomp/proc.cmi \ @@ -2638,6 +2857,7 @@ asmcomp/emit.cmo : \ asmcomp/mach.cmi \ asmcomp/linear.cmi \ lambda/lambda.cmi \ + asmcomp/emitenv.cmi \ asmcomp/emitaux.cmi \ utils/domainstate.cmi \ lambda/debuginfo.cmi \ @@ -2662,6 +2882,7 @@ asmcomp/emit.cmx : \ asmcomp/mach.cmx \ asmcomp/linear.cmx \ lambda/lambda.cmx \ + asmcomp/emitenv.cmi \ asmcomp/emitaux.cmx \ utils/domainstate.cmx \ lambda/debuginfo.cmx \ @@ -2676,6 +2897,8 @@ asmcomp/emit.cmi : \ asmcomp/linear.cmi \ asmcomp/cmm.cmi asmcomp/emitaux.cmo : \ + utils/misc.cmi \ + asmcomp/emitenv.cmi \ lambda/debuginfo.cmi \ utils/config.cmi \ asmcomp/cmm.cmi \ @@ -2683,6 +2906,8 @@ asmcomp/emitaux.cmo : \ asmcomp/arch.cmo \ asmcomp/emitaux.cmi asmcomp/emitaux.cmx : \ + utils/misc.cmx \ + asmcomp/emitenv.cmi \ lambda/debuginfo.cmx \ utils/config.cmx \ asmcomp/cmm.cmx \ @@ -2690,7 +2915,11 @@ asmcomp/emitaux.cmx : \ asmcomp/arch.cmx \ asmcomp/emitaux.cmi asmcomp/emitaux.cmi : \ + asmcomp/linear.cmi \ + asmcomp/emitenv.cmi \ lambda/debuginfo.cmi +asmcomp/emitenv.cmi : \ + asmcomp/linear.cmi asmcomp/interf.cmo : \ asmcomp/reg.cmi \ asmcomp/proc.cmi \ @@ -2776,7 +3005,7 @@ asmcomp/liveness.cmo : \ asmcomp/printmach.cmi \ utils/misc.cmi \ asmcomp/mach.cmi \ - asmcomp/cmm.cmi \ + asmcomp/dataflow.cmi \ asmcomp/liveness.cmi asmcomp/liveness.cmx : \ asmcomp/reg.cmx \ @@ -2784,41 +3013,54 @@ asmcomp/liveness.cmx : \ asmcomp/printmach.cmx \ utils/misc.cmx \ asmcomp/mach.cmx \ - asmcomp/cmm.cmx \ + asmcomp/dataflow.cmx \ asmcomp/liveness.cmi asmcomp/liveness.cmi : \ asmcomp/mach.cmi asmcomp/mach.cmo : \ - asmcomp/debug/reg_with_debug_info.cmi \ - asmcomp/debug/reg_availability_set.cmi \ asmcomp/reg.cmi \ lambda/lambda.cmi \ lambda/debuginfo.cmi \ asmcomp/cmm.cmi \ - middle_end/backend_var.cmi \ parsing/asttypes.cmi \ asmcomp/arch.cmo \ asmcomp/mach.cmi asmcomp/mach.cmx : \ - asmcomp/debug/reg_with_debug_info.cmx \ - asmcomp/debug/reg_availability_set.cmx \ asmcomp/reg.cmx \ lambda/lambda.cmx \ lambda/debuginfo.cmx \ asmcomp/cmm.cmx \ - middle_end/backend_var.cmx \ parsing/asttypes.cmi \ asmcomp/arch.cmx \ asmcomp/mach.cmi asmcomp/mach.cmi : \ - asmcomp/debug/reg_availability_set.cmi \ asmcomp/reg.cmi \ lambda/lambda.cmi \ lambda/debuginfo.cmi \ asmcomp/cmm.cmi \ - middle_end/backend_var.cmi \ parsing/asttypes.cmi \ asmcomp/arch.cmo +asmcomp/polling.cmo : \ + utils/numbers.cmi \ + utils/misc.cmi \ + asmcomp/mach.cmi \ + parsing/location.cmi \ + lambda/debuginfo.cmi \ + asmcomp/dataflow.cmi \ + asmcomp/cmm.cmi \ + asmcomp/polling.cmi +asmcomp/polling.cmx : \ + utils/numbers.cmx \ + utils/misc.cmx \ + asmcomp/mach.cmx \ + parsing/location.cmx \ + lambda/debuginfo.cmx \ + asmcomp/dataflow.cmx \ + asmcomp/cmm.cmx \ + asmcomp/polling.cmi +asmcomp/polling.cmi : \ + utils/misc.cmi \ + asmcomp/mach.cmi asmcomp/printcmm.cmo : \ utils/targetint.cmi \ lambda/lambda.cmi \ @@ -2859,7 +3101,6 @@ asmcomp/printlinear.cmx : \ asmcomp/printlinear.cmi : \ asmcomp/linear.cmi asmcomp/printmach.cmo : \ - asmcomp/debug/reg_availability_set.cmi \ asmcomp/reg.cmi \ asmcomp/proc.cmi \ asmcomp/printcmm.cmi \ @@ -2869,11 +3110,9 @@ asmcomp/printmach.cmo : \ lambda/debuginfo.cmi \ asmcomp/cmm.cmi \ utils/clflags.cmi \ - middle_end/backend_var.cmi \ asmcomp/arch.cmo \ asmcomp/printmach.cmi asmcomp/printmach.cmx : \ - asmcomp/debug/reg_availability_set.cmx \ asmcomp/reg.cmx \ asmcomp/proc.cmx \ asmcomp/printcmm.cmx \ @@ -2883,7 +3122,6 @@ asmcomp/printmach.cmx : \ lambda/debuginfo.cmx \ asmcomp/cmm.cmx \ utils/clflags.cmx \ - middle_end/backend_var.cmx \ asmcomp/arch.cmx \ asmcomp/printmach.cmi asmcomp/printmach.cmi : \ @@ -2958,6 +3196,7 @@ asmcomp/reloadgen.cmi : \ asmcomp/schedgen.cmo : \ asmcomp/reg.cmi \ asmcomp/proc.cmi \ + utils/misc.cmi \ asmcomp/mach.cmi \ asmcomp/linear.cmi \ asmcomp/cmm.cmi \ @@ -2967,6 +3206,7 @@ asmcomp/schedgen.cmo : \ asmcomp/schedgen.cmx : \ asmcomp/reg.cmx \ asmcomp/proc.cmx \ + utils/misc.cmx \ asmcomp/mach.cmx \ asmcomp/linear.cmx \ asmcomp/cmm.cmx \ @@ -2987,6 +3227,7 @@ asmcomp/scheduling.cmi : \ asmcomp/selectgen.cmo : \ asmcomp/reg.cmi \ asmcomp/proc.cmi \ + asmcomp/polling.cmi \ utils/numbers.cmi \ utils/misc.cmi \ asmcomp/mach.cmi \ @@ -3001,6 +3242,7 @@ asmcomp/selectgen.cmo : \ asmcomp/selectgen.cmx : \ asmcomp/reg.cmx \ asmcomp/proc.cmx \ + asmcomp/polling.cmx \ utils/numbers.cmx \ utils/misc.cmx \ asmcomp/mach.cmx \ @@ -3014,6 +3256,7 @@ asmcomp/selectgen.cmx : \ asmcomp/selectgen.cmi asmcomp/selectgen.cmi : \ asmcomp/reg.cmi \ + utils/misc.cmi \ asmcomp/mach.cmi \ lambda/debuginfo.cmi \ asmcomp/cmm.cmi \ @@ -3037,6 +3280,7 @@ asmcomp/selection.cmx : \ asmcomp/arch.cmx \ asmcomp/selection.cmi asmcomp/selection.cmi : \ + utils/misc.cmi \ asmcomp/mach.cmi \ asmcomp/cmm.cmi asmcomp/spill.cmo : \ @@ -3139,9 +3383,7 @@ asmcomp/x86_proc.cmi : \ asmcomp/x86_ast.cmi middle_end/backend_intf.cmi : \ utils/symbol.cmi \ - middle_end/flambda/simple_value_approx.cmi \ - typing/ident.cmi \ - utils/compilation_unit.cmi + middle_end/flambda/simple_value_approx.cmi middle_end/backend_var.cmo : \ typing/path.cmi \ typing/ident.cmi \ @@ -3208,6 +3450,7 @@ middle_end/compilenv.cmo : \ parsing/location.cmi \ utils/load_path.cmi \ utils/linkage_name.cmi \ + utils/import_info.cmi \ typing/ident.cmi \ middle_end/flambda/export_info.cmi \ typing/env.cmi \ @@ -3227,6 +3470,7 @@ middle_end/compilenv.cmx : \ parsing/location.cmx \ utils/load_path.cmx \ utils/linkage_name.cmx \ + utils/import_info.cmx \ typing/ident.cmx \ middle_end/flambda/export_info.cmx \ typing/env.cmx \ @@ -3237,23 +3481,23 @@ middle_end/compilenv.cmx : \ middle_end/clambda.cmx \ middle_end/compilenv.cmi middle_end/compilenv.cmi : \ - utils/symbol.cmi \ middle_end/flambda/simple_value_approx.cmi \ middle_end/flambda/base_types/set_of_closures_id.cmi \ lambda/lambda.cmi \ - typing/ident.cmi \ middle_end/flambda/export_info.cmi \ utils/compilation_unit.cmi \ file_formats/cmx_format.cmi \ middle_end/clambda.cmi middle_end/convert_primitives.cmo : \ lambda/printlambda.cmi \ + typing/primitive.cmi \ utils/misc.cmi \ lambda/lambda.cmi \ middle_end/clambda_primitives.cmi \ middle_end/convert_primitives.cmi middle_end/convert_primitives.cmx : \ lambda/printlambda.cmx \ + typing/primitive.cmx \ utils/misc.cmx \ lambda/lambda.cmx \ middle_end/clambda_primitives.cmx \ @@ -3359,17 +3603,20 @@ lambda/debuginfo.cmo : \ parsing/location.cmi \ utils/int_replace_polymorphic_compare.cmi \ typing/ident.cmi \ + utils/compilation_unit.cmi \ parsing/asttypes.cmi \ lambda/debuginfo.cmi lambda/debuginfo.cmx : \ parsing/location.cmx \ utils/int_replace_polymorphic_compare.cmx \ typing/ident.cmx \ + utils/compilation_unit.cmx \ parsing/asttypes.cmi \ lambda/debuginfo.cmi lambda/debuginfo.cmi : \ parsing/location.cmi \ typing/ident.cmi \ + utils/compilation_unit.cmi \ parsing/asttypes.cmi lambda/lambda.cmo : \ typing/types.cmi \ @@ -3381,6 +3628,7 @@ lambda/lambda.cmo : \ typing/env.cmi \ lambda/debuginfo.cmi \ utils/config.cmi \ + utils/compilation_unit.cmi \ utils/clflags.cmi \ parsing/asttypes.cmi \ lambda/lambda.cmi @@ -3394,6 +3642,7 @@ lambda/lambda.cmx : \ typing/env.cmx \ lambda/debuginfo.cmx \ utils/config.cmx \ + utils/compilation_unit.cmx \ utils/clflags.cmx \ parsing/asttypes.cmi \ lambda/lambda.cmi @@ -3404,6 +3653,7 @@ lambda/lambda.cmi : \ typing/ident.cmi \ typing/env.cmi \ lambda/debuginfo.cmi \ + utils/compilation_unit.cmi \ parsing/asttypes.cmi lambda/matching.cmo : \ typing/types.cmi \ @@ -3463,6 +3713,7 @@ lambda/printlambda.cmo : \ lambda/lambda.cmi \ typing/ident.cmi \ lambda/debuginfo.cmi \ + utils/compilation_unit.cmi \ utils/clflags.cmi \ parsing/asttypes.cmi \ lambda/printlambda.cmi @@ -3474,6 +3725,7 @@ lambda/printlambda.cmx : \ lambda/lambda.cmx \ typing/ident.cmx \ lambda/debuginfo.cmx \ + utils/compilation_unit.cmx \ utils/clflags.cmx \ parsing/asttypes.cmi \ lambda/printlambda.cmi @@ -3487,7 +3739,9 @@ lambda/runtimedef.cmx : \ lambda/runtimedef.cmi : lambda/simplif.cmo : \ utils/warnings.cmi \ + lambda/tmc.cmi \ typing/primitive.cmi \ + utils/misc.cmi \ parsing/location.cmi \ lambda/lambda.cmi \ typing/ident.cmi \ @@ -3497,7 +3751,9 @@ lambda/simplif.cmo : \ lambda/simplif.cmi lambda/simplif.cmx : \ utils/warnings.cmx \ + lambda/tmc.cmx \ typing/primitive.cmx \ + utils/misc.cmx \ parsing/location.cmx \ lambda/lambda.cmx \ typing/ident.cmx \ @@ -3513,6 +3769,22 @@ lambda/switch.cmo : \ lambda/switch.cmx : \ lambda/switch.cmi lambda/switch.cmi : +lambda/tmc.cmo : \ + utils/warnings.cmi \ + parsing/location.cmi \ + lambda/lambda.cmi \ + typing/ident.cmi \ + lambda/debuginfo.cmi \ + lambda/tmc.cmi +lambda/tmc.cmx : \ + utils/warnings.cmx \ + parsing/location.cmx \ + lambda/lambda.cmx \ + typing/ident.cmx \ + lambda/debuginfo.cmx \ + lambda/tmc.cmi +lambda/tmc.cmi : \ + lambda/lambda.cmi lambda/translattribute.cmo : \ utils/warnings.cmi \ typing/typedtree.cmi \ @@ -3522,6 +3794,7 @@ lambda/translattribute.cmo : \ parsing/location.cmi \ lambda/lambda.cmi \ utils/config.cmi \ + parsing/builtin_attributes.cmi \ lambda/translattribute.cmi lambda/translattribute.cmx : \ utils/warnings.cmx \ @@ -3532,6 +3805,7 @@ lambda/translattribute.cmx : \ parsing/location.cmx \ lambda/lambda.cmx \ utils/config.cmx \ + parsing/builtin_attributes.cmx \ lambda/translattribute.cmi lambda/translattribute.cmi : \ typing/typedtree.cmi \ @@ -3614,6 +3888,7 @@ lambda/translcore.cmo : \ typing/printtyp.cmi \ typing/primitive.cmi \ typing/predef.cmi \ + parsing/pprintast.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ typing/parmatch.cmi \ @@ -3644,6 +3919,7 @@ lambda/translcore.cmx : \ typing/printtyp.cmx \ typing/primitive.cmx \ typing/predef.cmx \ + parsing/pprintast.cmx \ typing/path.cmx \ parsing/parsetree.cmi \ typing/parmatch.cmx \ @@ -3664,7 +3940,7 @@ lambda/translcore.cmx : \ lambda/translcore.cmi : \ typing/types.cmi \ typing/typedtree.cmi \ - typing/path.cmi \ + parsing/longident.cmi \ parsing/location.cmi \ lambda/lambda.cmi \ typing/ident.cmi \ @@ -3684,12 +3960,14 @@ lambda/translmod.cmo : \ typing/path.cmi \ typing/mtype.cmi \ utils/misc.cmi \ + parsing/longident.cmi \ parsing/location.cmi \ lambda/lambda.cmi \ typing/ident.cmi \ typing/env.cmi \ lambda/debuginfo.cmi \ typing/ctype.cmi \ + utils/compilation_unit.cmi \ utils/clflags.cmi \ parsing/asttypes.cmi \ lambda/translmod.cmi @@ -3706,12 +3984,14 @@ lambda/translmod.cmx : \ typing/path.cmx \ typing/mtype.cmx \ utils/misc.cmx \ + parsing/longident.cmx \ parsing/location.cmx \ lambda/lambda.cmx \ typing/ident.cmx \ typing/env.cmx \ lambda/debuginfo.cmx \ typing/ctype.cmx \ + utils/compilation_unit.cmx \ utils/clflags.cmx \ parsing/asttypes.cmi \ lambda/translmod.cmi @@ -3720,7 +4000,8 @@ lambda/translmod.cmi : \ typing/primitive.cmi \ parsing/location.cmi \ lambda/lambda.cmi \ - typing/ident.cmi + typing/ident.cmi \ + utils/compilation_unit.cmi lambda/translobj.cmo : \ typing/primitive.cmi \ utils/misc.cmi \ @@ -3748,7 +4029,8 @@ lambda/translobj.cmx : \ lambda/translobj.cmi : \ lambda/lambda.cmi \ typing/ident.cmi \ - typing/env.cmi + typing/env.cmi \ + utils/compilation_unit.cmi lambda/translprim.cmo : \ typing/types.cmi \ typing/typeopt.cmi \ @@ -3763,6 +4045,7 @@ lambda/translprim.cmo : \ typing/env.cmi \ lambda/debuginfo.cmi \ utils/config.cmi \ + utils/compilation_unit.cmi \ utils/clflags.cmi \ parsing/asttypes.cmi \ lambda/translprim.cmi @@ -3780,6 +4063,7 @@ lambda/translprim.cmx : \ typing/env.cmx \ lambda/debuginfo.cmx \ utils/config.cmx \ + utils/compilation_unit.cmx \ utils/clflags.cmx \ parsing/asttypes.cmi \ lambda/translprim.cmi @@ -3791,37 +4075,47 @@ lambda/translprim.cmi : \ parsing/location.cmi \ lambda/lambda.cmi \ typing/ident.cmi \ - typing/env.cmi + typing/env.cmi \ + utils/compilation_unit.cmi file_formats/cmi_format.cmo : \ typing/types.cmi \ utils/misc.cmi \ parsing/location.cmi \ + utils/import_info.cmi \ utils/config.cmi \ + utils/compilation_unit.cmi \ file_formats/cmi_format.cmi file_formats/cmi_format.cmx : \ typing/types.cmx \ utils/misc.cmx \ parsing/location.cmx \ + utils/import_info.cmx \ utils/config.cmx \ + utils/compilation_unit.cmx \ file_formats/cmi_format.cmi file_formats/cmi_format.cmi : \ typing/types.cmi \ - utils/misc.cmi -file_formats/cmo_format.cmi : \ utils/misc.cmi \ + utils/import_info.cmi \ + utils/compilation_unit.cmi +file_formats/cmo_format.cmi : \ lambda/lambda.cmi \ + utils/import_info.cmi \ typing/ident.cmi \ utils/compilation_unit.cmi file_formats/cmt_format.cmo : \ typing/types.cmi \ typing/typedtree.cmi \ typing/tast_mapper.cmi \ + typing/shape.cmi \ utils/misc.cmi \ parsing/location.cmi \ utils/load_path.cmi \ parsing/lexer.cmi \ + utils/import_info.cmi \ typing/env.cmi \ utils/config.cmi \ + utils/compilation_unit.cmi \ file_formats/cmi_format.cmi \ utils/clflags.cmi \ file_formats/cmt_format.cmi @@ -3829,30 +4123,34 @@ file_formats/cmt_format.cmx : \ typing/types.cmx \ typing/typedtree.cmx \ typing/tast_mapper.cmx \ + typing/shape.cmx \ utils/misc.cmx \ parsing/location.cmx \ utils/load_path.cmx \ parsing/lexer.cmx \ + utils/import_info.cmx \ typing/env.cmx \ utils/config.cmx \ + utils/compilation_unit.cmx \ file_formats/cmi_format.cmx \ utils/clflags.cmx \ file_formats/cmt_format.cmi file_formats/cmt_format.cmi : \ typing/types.cmi \ typing/typedtree.cmi \ - utils/misc.cmi \ + typing/shape.cmi \ parsing/location.cmi \ typing/env.cmi \ + utils/compilation_unit.cmi \ file_formats/cmi_format.cmi file_formats/cmx_format.cmi : \ - utils/misc.cmi \ lambda/lambda.cmi \ + utils/import_info.cmi \ middle_end/flambda/export_info.cmi \ utils/compilation_unit.cmi \ middle_end/clambda.cmi file_formats/cmxs_format.cmi : \ - utils/misc.cmi \ + utils/import_info.cmi \ utils/compilation_unit.cmi file_formats/linear_format.cmo : \ utils/misc.cmi \ @@ -4151,8 +4449,8 @@ middle_end/flambda/closure_conversion.cmx : \ middle_end/flambda/closure_conversion.cmi middle_end/flambda/closure_conversion.cmi : \ lambda/lambda.cmi \ - typing/ident.cmi \ middle_end/flambda/flambda.cmi \ + utils/compilation_unit.cmi \ middle_end/backend_intf.cmi middle_end/flambda/closure_conversion_aux.cmo : \ middle_end/variable.cmi \ @@ -4264,8 +4562,7 @@ middle_end/flambda/export_info_for_pack.cmo : \ middle_end/flambda/export_info.cmi \ middle_end/flambda/base_types/export_id.cmi \ utils/compilation_unit.cmi \ - middle_end/flambda/base_types/closure_id.cmi \ - middle_end/flambda/export_info_for_pack.cmi + middle_end/flambda/base_types/closure_id.cmi middle_end/flambda/export_info_for_pack.cmx : \ middle_end/variable.cmx \ middle_end/flambda/base_types/var_within_closure.cmx \ @@ -4278,11 +4575,7 @@ middle_end/flambda/export_info_for_pack.cmx : \ middle_end/flambda/export_info.cmx \ middle_end/flambda/base_types/export_id.cmx \ utils/compilation_unit.cmx \ - middle_end/flambda/base_types/closure_id.cmx \ - middle_end/flambda/export_info_for_pack.cmi -middle_end/flambda/export_info_for_pack.cmi : \ - middle_end/flambda/export_info.cmi \ - utils/compilation_unit.cmi + middle_end/flambda/base_types/closure_id.cmx middle_end/flambda/extract_projections.cmo : \ middle_end/variable.cmi \ middle_end/flambda/base_types/var_within_closure.cmi \ @@ -4608,6 +4901,7 @@ middle_end/flambda/flambda_to_clambda.cmi : \ middle_end/flambda/flambda_utils.cmo : \ middle_end/variable.cmi \ middle_end/flambda/base_types/var_within_closure.cmi \ + middle_end/symbol_utils.cmi \ utils/symbol.cmi \ lambda/switch.cmi \ middle_end/flambda/base_types/static_exception.cmi \ @@ -4633,6 +4927,7 @@ middle_end/flambda/flambda_utils.cmo : \ middle_end/flambda/flambda_utils.cmx : \ middle_end/variable.cmx \ middle_end/flambda/base_types/var_within_closure.cmx \ + middle_end/symbol_utils.cmx \ utils/symbol.cmx \ lambda/switch.cmx \ middle_end/flambda/base_types/static_exception.cmx \ @@ -5830,80 +6125,6 @@ middle_end/flambda/base_types/var_within_closure.cmx : \ middle_end/flambda/base_types/var_within_closure.cmi middle_end/flambda/base_types/var_within_closure.cmi : \ middle_end/flambda/base_types/closure_element.cmi -asmcomp/debug/available_regs.cmo : \ - asmcomp/debug/reg_with_debug_info.cmi \ - asmcomp/debug/reg_availability_set.cmi \ - asmcomp/reg.cmi \ - asmcomp/proc.cmi \ - asmcomp/printmach.cmi \ - utils/misc.cmi \ - asmcomp/mach.cmi \ - utils/clflags.cmi \ - middle_end/backend_var.cmi \ - asmcomp/debug/available_regs.cmi -asmcomp/debug/available_regs.cmx : \ - asmcomp/debug/reg_with_debug_info.cmx \ - asmcomp/debug/reg_availability_set.cmx \ - asmcomp/reg.cmx \ - asmcomp/proc.cmx \ - asmcomp/printmach.cmx \ - utils/misc.cmx \ - asmcomp/mach.cmx \ - utils/clflags.cmx \ - middle_end/backend_var.cmx \ - asmcomp/debug/available_regs.cmi -asmcomp/debug/available_regs.cmi : \ - asmcomp/mach.cmi -asmcomp/debug/compute_ranges.cmo : \ - asmcomp/printlinear.cmi \ - utils/numbers.cmi \ - utils/misc.cmi \ - asmcomp/linear.cmi \ - utils/int_replace_polymorphic_compare.cmi \ - asmcomp/debug/compute_ranges_intf.cmo \ - asmcomp/cmm.cmi \ - asmcomp/debug/compute_ranges.cmi -asmcomp/debug/compute_ranges.cmx : \ - asmcomp/printlinear.cmx \ - utils/numbers.cmx \ - utils/misc.cmx \ - asmcomp/linear.cmx \ - utils/int_replace_polymorphic_compare.cmx \ - asmcomp/debug/compute_ranges_intf.cmx \ - asmcomp/cmm.cmx \ - asmcomp/debug/compute_ranges.cmi -asmcomp/debug/compute_ranges.cmi : \ - asmcomp/debug/compute_ranges_intf.cmo -asmcomp/debug/compute_ranges_intf.cmo : \ - utils/numbers.cmi \ - asmcomp/linear.cmi \ - utils/identifiable.cmi -asmcomp/debug/compute_ranges_intf.cmx : \ - utils/numbers.cmx \ - asmcomp/linear.cmx \ - utils/identifiable.cmx -asmcomp/debug/reg_availability_set.cmo : \ - asmcomp/debug/reg_with_debug_info.cmi \ - middle_end/backend_var.cmi \ - asmcomp/debug/reg_availability_set.cmi -asmcomp/debug/reg_availability_set.cmx : \ - asmcomp/debug/reg_with_debug_info.cmx \ - middle_end/backend_var.cmx \ - asmcomp/debug/reg_availability_set.cmi -asmcomp/debug/reg_availability_set.cmi : \ - asmcomp/debug/reg_with_debug_info.cmi \ - asmcomp/reg.cmi -asmcomp/debug/reg_with_debug_info.cmo : \ - asmcomp/reg.cmi \ - middle_end/backend_var.cmi \ - asmcomp/debug/reg_with_debug_info.cmi -asmcomp/debug/reg_with_debug_info.cmx : \ - asmcomp/reg.cmx \ - middle_end/backend_var.cmx \ - asmcomp/debug/reg_with_debug_info.cmi -asmcomp/debug/reg_with_debug_info.cmi : \ - asmcomp/reg.cmi \ - middle_end/backend_var.cmi driver/compenv.cmo : \ utils/warnings.cmi \ utils/profile.cmi \ @@ -5925,6 +6146,7 @@ driver/compenv.cmx : \ driver/compenv.cmi : \ utils/clflags.cmi driver/compile.cmo : \ + typing/typedtree.cmi \ lambda/translmod.cmi \ lambda/simplif.cmi \ utils/profile.cmi \ @@ -5934,10 +6156,12 @@ driver/compile.cmo : \ lambda/lambda.cmi \ bytecomp/emitcode.cmi \ driver/compile_common.cmi \ + utils/compilation_unit.cmi \ utils/clflags.cmi \ bytecomp/bytegen.cmi \ driver/compile.cmi driver/compile.cmx : \ + typing/typedtree.cmx \ lambda/translmod.cmx \ lambda/simplif.cmx \ utils/profile.cmx \ @@ -5947,20 +6171,22 @@ driver/compile.cmx : \ lambda/lambda.cmx \ bytecomp/emitcode.cmx \ driver/compile_common.cmx \ + utils/compilation_unit.cmx \ utils/clflags.cmx \ bytecomp/bytegen.cmx \ driver/compile.cmi driver/compile.cmi : \ typing/typedtree.cmi \ bytecomp/instruct.cmi \ - typing/ident.cmi \ driver/compile_common.cmi \ + utils/compilation_unit.cmi \ utils/clflags.cmi driver/compile_common.cmo : \ utils/warnings.cmi \ typing/typemod.cmi \ typing/typedtree.cmi \ typing/typecore.cmi \ + typing/shape.cmi \ utils/profile.cmi \ typing/printtyped.cmi \ typing/printtyp.cmi \ @@ -5972,6 +6198,7 @@ driver/compile_common.cmo : \ typing/env.cmi \ utils/config.cmi \ driver/compmisc.cmi \ + utils/compilation_unit.cmi \ driver/compenv.cmi \ utils/clflags.cmi \ parsing/builtin_attributes.cmi \ @@ -5981,6 +6208,7 @@ driver/compile_common.cmx : \ typing/typemod.cmx \ typing/typedtree.cmx \ typing/typecore.cmx \ + typing/shape.cmx \ utils/profile.cmx \ typing/printtyped.cmx \ typing/printtyp.cmx \ @@ -5992,6 +6220,7 @@ driver/compile_common.cmx : \ typing/env.cmx \ utils/config.cmx \ driver/compmisc.cmx \ + utils/compilation_unit.cmx \ driver/compenv.cmx \ utils/clflags.cmx \ parsing/builtin_attributes.cmx \ @@ -5999,7 +6228,8 @@ driver/compile_common.cmx : \ driver/compile_common.cmi : \ typing/typedtree.cmi \ parsing/parsetree.cmi \ - typing/env.cmi + typing/env.cmi \ + utils/compilation_unit.cmi driver/compmisc.cmo : \ utils/warnings.cmi \ typing/types.cmi \ @@ -6027,6 +6257,7 @@ driver/compmisc.cmx : \ utils/clflags.cmx \ driver/compmisc.cmi driver/compmisc.cmi : \ + utils/load_path.cmi \ typing/env.cmi \ utils/clflags.cmi driver/errors.cmo : \ @@ -6044,6 +6275,7 @@ driver/main_args.cmo : \ utils/warnings.cmi \ utils/profile.cmi \ utils/misc.cmi \ + parsing/location.cmi \ utils/config.cmi \ driver/compenv.cmi \ utils/clflags.cmi \ @@ -6052,6 +6284,7 @@ driver/main_args.cmx : \ utils/warnings.cmx \ utils/profile.cmx \ utils/misc.cmx \ + parsing/location.cmx \ utils/config.cmx \ driver/compenv.cmx \ utils/clflags.cmx \ @@ -6116,6 +6349,7 @@ driver/makedepend.cmx : \ driver/makedepend.cmi driver/makedepend.cmi : driver/optcompile.cmo : \ + typing/typedtree.cmi \ lambda/translmod.cmi \ lambda/simplif.cmi \ utils/profile.cmi \ @@ -6126,12 +6360,12 @@ driver/optcompile.cmo : \ utils/config.cmi \ middle_end/compilenv.cmi \ driver/compile_common.cmi \ - utils/compilation_unit.cmi \ middle_end/closure/closure_middle_end.cmi \ utils/clflags.cmi \ asmcomp/asmgen.cmi \ driver/optcompile.cmi driver/optcompile.cmx : \ + typing/typedtree.cmx \ lambda/translmod.cmx \ lambda/simplif.cmx \ utils/profile.cmx \ @@ -6142,7 +6376,6 @@ driver/optcompile.cmx : \ utils/config.cmx \ middle_end/compilenv.cmx \ driver/compile_common.cmx \ - utils/compilation_unit.cmx \ middle_end/closure/closure_middle_end.cmx \ utils/clflags.cmx \ asmcomp/asmgen.cmx \ @@ -6174,7 +6407,6 @@ driver/optmaindriver.cmo : \ middle_end/flambda/import_approx.cmi \ utils/config.cmi \ driver/compmisc.cmi \ - middle_end/compilenv.cmi \ driver/compenv.cmi \ utils/clflags.cmi \ middle_end/backend_intf.cmi \ @@ -6194,7 +6426,6 @@ driver/optmaindriver.cmx : \ middle_end/flambda/import_approx.cmx \ utils/config.cmx \ driver/compmisc.cmx \ - middle_end/compilenv.cmx \ driver/compenv.cmx \ utils/clflags.cmx \ middle_end/backend_intf.cmi \ @@ -6236,13 +6467,17 @@ toplevel/expunge.cmo : \ bytecomp/symtable.cmi \ lambda/runtimedef.cmi \ utils/misc.cmi \ + utils/import_info.cmi \ typing/ident.cmi \ + utils/compilation_unit.cmi \ bytecomp/bytesections.cmi toplevel/expunge.cmx : \ bytecomp/symtable.cmx \ lambda/runtimedef.cmx \ utils/misc.cmx \ + utils/import_info.cmx \ typing/ident.cmx \ + utils/compilation_unit.cmx \ bytecomp/bytesections.cmx toplevel/genprintval.cmo : \ typing/types.cmi \ @@ -6285,52 +6520,8 @@ toplevel/genprintval.cmi : \ typing/path.cmi \ typing/outcometree.cmi \ typing/env.cmi -toplevel/opttopdirs.cmo : \ - utils/warnings.cmi \ - typing/types.cmi \ - typing/printtyp.cmi \ - toplevel/opttoploop.cmi \ - utils/misc.cmi \ - parsing/longident.cmi \ - utils/load_path.cmi \ - typing/ident.cmi \ - typing/env.cmi \ - typing/ctype.cmi \ - utils/config.cmi \ - driver/compenv.cmi \ - utils/clflags.cmi \ - asmcomp/asmlink.cmi \ - toplevel/opttopdirs.cmi -toplevel/opttopdirs.cmx : \ - utils/warnings.cmx \ - typing/types.cmx \ - typing/printtyp.cmx \ - toplevel/opttoploop.cmx \ - utils/misc.cmx \ - parsing/longident.cmx \ - utils/load_path.cmx \ - typing/ident.cmx \ - typing/env.cmx \ - typing/ctype.cmx \ - utils/config.cmx \ - driver/compenv.cmx \ - utils/clflags.cmx \ - asmcomp/asmlink.cmx \ - toplevel/opttopdirs.cmi -toplevel/opttopdirs.cmi : \ - parsing/longident.cmi -toplevel/opttoploop.cmo : \ - utils/warnings.cmi \ - typing/types.cmi \ - typing/typemod.cmi \ +toplevel/topcommon.cmo : \ typing/typedtree.cmi \ - typing/typecore.cmi \ - lambda/translmod.cmi \ - lambda/simplif.cmi \ - asmcomp/proc.cmi \ - typing/printtyped.cmi \ - typing/printtyp.cmi \ - lambda/printlambda.cmi \ parsing/printast.cmi \ typing/predef.cmi \ parsing/pprintast.cmi \ @@ -6345,40 +6536,20 @@ toplevel/opttoploop.cmo : \ parsing/location.cmi \ utils/load_path.cmi \ parsing/lexer.cmi \ - lambda/lambda.cmi \ - typing/includemod.cmi \ - middle_end/flambda/import_approx.cmi \ typing/ident.cmi \ toplevel/genprintval.cmi \ - middle_end/flambda/flambda_middle_end.cmi \ typing/env.cmi \ + bytecomp/dll.cmi \ utils/config.cmi \ driver/compmisc.cmi \ - middle_end/compilenv.cmi \ utils/compilation_unit.cmi \ driver/compenv.cmi \ - middle_end/closure/closure_middle_end.cmi \ utils/clflags.cmi \ - typing/btype.cmi \ - middle_end/backend_intf.cmi \ parsing/asttypes.cmi \ parsing/ast_helper.cmi \ - asmcomp/asmlink.cmi \ - asmcomp/asmgen.cmi \ - asmcomp/arch.cmo \ - toplevel/opttoploop.cmi -toplevel/opttoploop.cmx : \ - utils/warnings.cmx \ - typing/types.cmx \ - typing/typemod.cmx \ + toplevel/topcommon.cmi +toplevel/topcommon.cmx : \ typing/typedtree.cmx \ - typing/typecore.cmx \ - lambda/translmod.cmx \ - lambda/simplif.cmx \ - asmcomp/proc.cmx \ - typing/printtyped.cmx \ - typing/printtyp.cmx \ - lambda/printlambda.cmx \ parsing/printast.cmx \ typing/predef.cmx \ parsing/pprintast.cmx \ @@ -6393,76 +6564,41 @@ toplevel/opttoploop.cmx : \ parsing/location.cmx \ utils/load_path.cmx \ parsing/lexer.cmx \ - lambda/lambda.cmx \ - typing/includemod.cmx \ - middle_end/flambda/import_approx.cmx \ typing/ident.cmx \ toplevel/genprintval.cmx \ - middle_end/flambda/flambda_middle_end.cmx \ typing/env.cmx \ + bytecomp/dll.cmx \ utils/config.cmx \ driver/compmisc.cmx \ - middle_end/compilenv.cmx \ utils/compilation_unit.cmx \ driver/compenv.cmx \ - middle_end/closure/closure_middle_end.cmx \ utils/clflags.cmx \ - typing/btype.cmx \ - middle_end/backend_intf.cmi \ parsing/asttypes.cmi \ parsing/ast_helper.cmx \ - asmcomp/asmlink.cmx \ - asmcomp/asmgen.cmx \ - asmcomp/arch.cmx \ - toplevel/opttoploop.cmi -toplevel/opttoploop.cmi : \ + toplevel/topcommon.cmi +toplevel/topcommon.cmi : \ utils/warnings.cmi \ typing/types.cmi \ + typing/typedtree.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ typing/outcometree.cmi \ parsing/longident.cmi \ parsing/location.cmi \ - typing/env.cmi -toplevel/opttopmain.cmo : \ - toplevel/opttoploop.cmi \ - toplevel/opttopdirs.cmi \ - utils/misc.cmi \ - driver/main_args.cmi \ - parsing/location.cmi \ - driver/compmisc.cmi \ - driver/compenv.cmi \ - utils/clflags.cmi \ - toplevel/opttopmain.cmi -toplevel/opttopmain.cmx : \ - toplevel/opttoploop.cmx \ - toplevel/opttopdirs.cmx \ - utils/misc.cmx \ - driver/main_args.cmx \ - parsing/location.cmx \ - driver/compmisc.cmx \ - driver/compenv.cmx \ - utils/clflags.cmx \ - toplevel/opttopmain.cmi -toplevel/opttopmain.cmi : -toplevel/opttopstart.cmo : \ - toplevel/opttopmain.cmi -toplevel/opttopstart.cmx : \ - toplevel/opttopmain.cmx + typing/ident.cmi \ + toplevel/genprintval.cmi \ + typing/env.cmi \ + utils/compilation_unit.cmi toplevel/topdirs.cmo : \ utils/warnings.cmi \ typing/types.cmi \ - toplevel/trace.cmi \ toplevel/toploop.cmi \ - bytecomp/symtable.cmi \ + toplevel/topeval.cmi \ typing/printtyp.cmi \ typing/predef.cmi \ - typing/persistent_env.cmi \ typing/path.cmi \ parsing/parsetree.cmi \ - bytecomp/opcodes.cmi \ utils/misc.cmi \ - bytecomp/meta.cmi \ parsing/longident.cmi \ parsing/location.cmi \ utils/load_path.cmi \ @@ -6472,7 +6608,6 @@ toplevel/topdirs.cmo : \ typing/ctype.cmi \ utils/config.cmi \ driver/compenv.cmi \ - file_formats/cmo_format.cmi \ utils/clflags.cmi \ typing/btype.cmi \ parsing/asttypes.cmi \ @@ -6481,17 +6616,13 @@ toplevel/topdirs.cmo : \ toplevel/topdirs.cmx : \ utils/warnings.cmx \ typing/types.cmx \ - toplevel/trace.cmx \ toplevel/toploop.cmx \ - bytecomp/symtable.cmx \ + toplevel/topeval.cmi \ typing/printtyp.cmx \ typing/predef.cmx \ - typing/persistent_env.cmx \ typing/path.cmx \ parsing/parsetree.cmi \ - bytecomp/opcodes.cmx \ utils/misc.cmx \ - bytecomp/meta.cmx \ parsing/longident.cmx \ parsing/location.cmx \ utils/load_path.cmx \ @@ -6501,7 +6632,6 @@ toplevel/topdirs.cmx : \ typing/ctype.cmx \ utils/config.cmx \ driver/compenv.cmx \ - file_formats/cmo_format.cmi \ utils/clflags.cmx \ typing/btype.cmx \ parsing/asttypes.cmi \ @@ -6509,131 +6639,176 @@ toplevel/topdirs.cmx : \ toplevel/topdirs.cmi toplevel/topdirs.cmi : \ parsing/longident.cmi +toplevel/topeval.cmi : \ + toplevel/topcommon.cmi \ + parsing/parsetree.cmi toplevel/toploop.cmo : \ utils/warnings.cmi \ typing/typetexp.cmi \ + toplevel/topeval.cmi \ + toplevel/topcommon.cmi \ + utils/misc.cmi \ + parsing/location.cmi \ + utils/load_path.cmi \ + parsing/lexer.cmi \ + typing/env.cmi \ + utils/config.cmi \ + driver/compmisc.cmi \ + driver/compenv.cmi \ + utils/clflags.cmi \ + typing/btype.cmi \ + toplevel/toploop.cmi +toplevel/toploop.cmx : \ + utils/warnings.cmx \ + typing/typetexp.cmx \ + toplevel/topeval.cmi \ + toplevel/topcommon.cmx \ + utils/misc.cmx \ + parsing/location.cmx \ + utils/load_path.cmx \ + parsing/lexer.cmx \ + typing/env.cmx \ + utils/config.cmx \ + driver/compmisc.cmx \ + driver/compenv.cmx \ + utils/clflags.cmx \ + typing/btype.cmx \ + toplevel/toploop.cmi +toplevel/toploop.cmi : \ + utils/warnings.cmi \ + typing/types.cmi \ + typing/path.cmi \ + parsing/parsetree.cmi \ + typing/outcometree.cmi \ + parsing/longident.cmi \ + parsing/location.cmi \ + typing/env.cmi +toplevel/topmain.cmi : +toplevel/topstart.cmo : \ + toplevel/topmain.cmi +toplevel/topstart.cmx : \ + toplevel/topmain.cmi +toplevel/trace.cmi : \ + typing/types.cmi \ + typing/path.cmi \ + parsing/longident.cmi \ + typing/env.cmi +toplevel/byte/topeval.cmo : \ + utils/warnings.cmi \ typing/types.cmi \ typing/typemod.cmi \ typing/typedtree.cmi \ typing/typecore.cmi \ lambda/translmod.cmi \ + toplevel/topcommon.cmi \ bytecomp/symtable.cmi \ lambda/simplif.cmi \ + typing/shape.cmi \ typing/printtyped.cmi \ typing/printtyp.cmi \ lambda/printlambda.cmi \ bytecomp/printinstr.cmi \ - parsing/printast.cmi \ typing/predef.cmi \ - parsing/pprintast.cmi \ - driver/pparse.cmi \ - typing/path.cmi \ + typing/persistent_env.cmi \ parsing/parsetree.cmi \ - parsing/parse.cmi \ typing/outcometree.cmi \ - typing/oprint.cmi \ + bytecomp/opcodes.cmi \ utils/misc.cmi \ bytecomp/meta.cmi \ - parsing/longident.cmi \ parsing/location.cmi \ utils/load_path.cmi \ - parsing/lexer.cmi \ typing/includemod.cmi \ typing/ident.cmi \ - toplevel/genprintval.cmi \ typing/env.cmi \ bytecomp/emitcode.cmi \ bytecomp/dll.cmi \ utils/config.cmi \ driver/compmisc.cmi \ - driver/compenv.cmi \ + utils/compilation_unit.cmi \ + file_formats/cmo_format.cmi \ utils/clflags.cmi \ bytecomp/bytegen.cmi \ - typing/btype.cmi \ - parsing/asttypes.cmi \ - parsing/ast_helper.cmi \ - toplevel/toploop.cmi -toplevel/toploop.cmx : \ + toplevel/byte/topeval.cmi +toplevel/byte/topeval.cmx : \ utils/warnings.cmx \ - typing/typetexp.cmx \ typing/types.cmx \ typing/typemod.cmx \ typing/typedtree.cmx \ typing/typecore.cmx \ lambda/translmod.cmx \ + toplevel/topcommon.cmx \ bytecomp/symtable.cmx \ lambda/simplif.cmx \ + typing/shape.cmx \ typing/printtyped.cmx \ typing/printtyp.cmx \ lambda/printlambda.cmx \ bytecomp/printinstr.cmx \ - parsing/printast.cmx \ typing/predef.cmx \ - parsing/pprintast.cmx \ - driver/pparse.cmx \ - typing/path.cmx \ + typing/persistent_env.cmx \ parsing/parsetree.cmi \ - parsing/parse.cmx \ typing/outcometree.cmi \ - typing/oprint.cmx \ + bytecomp/opcodes.cmx \ utils/misc.cmx \ bytecomp/meta.cmx \ - parsing/longident.cmx \ parsing/location.cmx \ utils/load_path.cmx \ - parsing/lexer.cmx \ typing/includemod.cmx \ typing/ident.cmx \ - toplevel/genprintval.cmx \ typing/env.cmx \ bytecomp/emitcode.cmx \ bytecomp/dll.cmx \ utils/config.cmx \ driver/compmisc.cmx \ - driver/compenv.cmx \ + utils/compilation_unit.cmx \ + file_formats/cmo_format.cmi \ utils/clflags.cmx \ bytecomp/bytegen.cmx \ - typing/btype.cmx \ - parsing/asttypes.cmi \ - parsing/ast_helper.cmx \ - toplevel/toploop.cmi -toplevel/toploop.cmi : \ - utils/warnings.cmi \ + toplevel/byte/topeval.cmi +toplevel/byte/topeval.cmi : \ + toplevel/topcommon.cmi \ + parsing/parsetree.cmi +toplevel/byte/topmain.cmo : \ typing/types.cmi \ - typing/path.cmi \ - parsing/parsetree.cmi \ - typing/outcometree.cmi \ - parsing/longident.cmi \ - parsing/location.cmi \ - typing/env.cmi -toplevel/topmain.cmo : \ + toplevel/byte/trace.cmi \ toplevel/toploop.cmi \ + toplevel/byte/topeval.cmi \ toplevel/topdirs.cmi \ + toplevel/topcommon.cmi \ + typing/printtyp.cmi \ + typing/path.cmi \ utils/misc.cmi \ driver/main_args.cmi \ parsing/location.cmi \ + typing/env.cmi \ + typing/ctype.cmi \ driver/compmisc.cmi \ driver/compenv.cmi \ utils/clflags.cmi \ - toplevel/topmain.cmi -toplevel/topmain.cmx : \ + toplevel/byte/topmain.cmi +toplevel/byte/topmain.cmx : \ + typing/types.cmx \ + toplevel/byte/trace.cmx \ toplevel/toploop.cmx \ + toplevel/byte/topeval.cmx \ toplevel/topdirs.cmx \ + toplevel/topcommon.cmx \ + typing/printtyp.cmx \ + typing/path.cmx \ utils/misc.cmx \ driver/main_args.cmx \ parsing/location.cmx \ + typing/env.cmx \ + typing/ctype.cmx \ driver/compmisc.cmx \ driver/compenv.cmx \ utils/clflags.cmx \ - toplevel/topmain.cmi -toplevel/topmain.cmi : -toplevel/topstart.cmo : \ - toplevel/topmain.cmi -toplevel/topstart.cmx : \ - toplevel/topmain.cmx -toplevel/trace.cmo : \ + toplevel/byte/topmain.cmi +toplevel/byte/topmain.cmi : +toplevel/byte/trace.cmo : \ typing/types.cmi \ - toplevel/toploop.cmi \ + toplevel/byte/topeval.cmi \ + toplevel/topcommon.cmi \ typing/printtyp.cmi \ typing/predef.cmi \ typing/path.cmi \ @@ -6642,10 +6817,11 @@ toplevel/trace.cmo : \ parsing/longident.cmi \ typing/ctype.cmi \ parsing/asttypes.cmi \ - toplevel/trace.cmi -toplevel/trace.cmx : \ + toplevel/byte/trace.cmi +toplevel/byte/trace.cmx : \ typing/types.cmx \ - toplevel/toploop.cmx \ + toplevel/byte/topeval.cmx \ + toplevel/topcommon.cmx \ typing/printtyp.cmx \ typing/predef.cmx \ typing/path.cmx \ @@ -6654,8 +6830,144 @@ toplevel/trace.cmx : \ parsing/longident.cmx \ typing/ctype.cmx \ parsing/asttypes.cmi \ - toplevel/trace.cmi -toplevel/trace.cmi : \ + toplevel/byte/trace.cmi +toplevel/byte/trace.cmi : \ + typing/types.cmi \ + typing/path.cmi \ + parsing/longident.cmi \ + typing/env.cmi +toplevel/native/topeval.cmo : \ + utils/warnings.cmi \ + typing/types.cmi \ + typing/typemod.cmi \ + typing/typedtree.cmi \ + typing/typecore.cmi \ + lambda/translmod.cmi \ + toplevel/native/tophooks.cmi \ + toplevel/topcommon.cmi \ + utils/symbol.cmi \ + lambda/simplif.cmi \ + typing/shape.cmi \ + typing/printtyped.cmi \ + typing/printtyp.cmi \ + lambda/printlambda.cmi \ + typing/predef.cmi \ + parsing/parsetree.cmi \ + typing/outcometree.cmi \ + utils/misc.cmi \ + parsing/location.cmi \ + utils/load_path.cmi \ + utils/linkage_name.cmi \ + lambda/lambda.cmi \ + typing/includemod.cmi \ + typing/ident.cmi \ + typing/env.cmi \ + utils/config.cmi \ + driver/compmisc.cmi \ + middle_end/compilenv.cmi \ + utils/compilation_unit.cmi \ + utils/clflags.cmi \ + asmcomp/asmlink.cmi \ + toplevel/native/topeval.cmi +toplevel/native/topeval.cmx : \ + utils/warnings.cmx \ + typing/types.cmx \ + typing/typemod.cmx \ + typing/typedtree.cmx \ + typing/typecore.cmx \ + lambda/translmod.cmx \ + toplevel/native/tophooks.cmx \ + toplevel/topcommon.cmx \ + utils/symbol.cmx \ + lambda/simplif.cmx \ + typing/shape.cmx \ + typing/printtyped.cmx \ + typing/printtyp.cmx \ + lambda/printlambda.cmx \ + typing/predef.cmx \ + parsing/parsetree.cmi \ + typing/outcometree.cmi \ + utils/misc.cmx \ + parsing/location.cmx \ + utils/load_path.cmx \ + utils/linkage_name.cmx \ + lambda/lambda.cmx \ + typing/includemod.cmx \ + typing/ident.cmx \ + typing/env.cmx \ + utils/config.cmx \ + driver/compmisc.cmx \ + middle_end/compilenv.cmx \ + utils/compilation_unit.cmx \ + utils/clflags.cmx \ + asmcomp/asmlink.cmx \ + toplevel/native/topeval.cmi +toplevel/native/topeval.cmi : \ + toplevel/topcommon.cmi \ + parsing/parsetree.cmi +toplevel/native/tophooks.cmo : \ + toplevel/topcommon.cmi \ + asmcomp/proc.cmi \ + utils/misc.cmi \ + lambda/lambda.cmi \ + middle_end/flambda/import_approx.cmi \ + middle_end/flambda/flambda_middle_end.cmi \ + utils/config.cmi \ + middle_end/closure/closure_middle_end.cmi \ + utils/clflags.cmi \ + middle_end/backend_intf.cmi \ + asmcomp/asmlink.cmi \ + asmcomp/asmgen.cmi \ + asmcomp/arch.cmo \ + toplevel/native/tophooks.cmi +toplevel/native/tophooks.cmx : \ + toplevel/topcommon.cmx \ + asmcomp/proc.cmx \ + utils/misc.cmx \ + lambda/lambda.cmx \ + middle_end/flambda/import_approx.cmx \ + middle_end/flambda/flambda_middle_end.cmx \ + utils/config.cmx \ + middle_end/closure/closure_middle_end.cmx \ + utils/clflags.cmx \ + middle_end/backend_intf.cmi \ + asmcomp/asmlink.cmx \ + asmcomp/asmgen.cmx \ + asmcomp/arch.cmx \ + toplevel/native/tophooks.cmi +toplevel/native/tophooks.cmi : \ + toplevel/topcommon.cmi \ + lambda/lambda.cmi +toplevel/native/topmain.cmo : \ + toplevel/toploop.cmi \ + toplevel/native/topeval.cmi \ + toplevel/topcommon.cmi \ + utils/misc.cmi \ + driver/main_args.cmi \ + parsing/location.cmi \ + driver/compmisc.cmi \ + driver/compenv.cmi \ + utils/clflags.cmi \ + toplevel/native/topmain.cmi +toplevel/native/topmain.cmx : \ + toplevel/toploop.cmx \ + toplevel/native/topeval.cmx \ + toplevel/topcommon.cmx \ + utils/misc.cmx \ + driver/main_args.cmx \ + parsing/location.cmx \ + driver/compmisc.cmx \ + driver/compenv.cmx \ + utils/clflags.cmx \ + toplevel/native/topmain.cmi +toplevel/native/topmain.cmi : +toplevel/native/trace.cmo : \ + typing/path.cmi \ + toplevel/native/trace.cmi +toplevel/native/trace.cmx : \ + typing/path.cmx \ + toplevel/native/trace.cmi +toplevel/native/trace.cmi : \ typing/types.cmi \ typing/path.cmi \ parsing/longident.cmi \ diff --git a/ocaml/.gitattributes b/ocaml/.gitattributes index 5961fef2905..4ac00cad84a 100644 --- a/ocaml/.gitattributes +++ b/ocaml/.gitattributes @@ -45,8 +45,10 @@ # No header for text files (would be too obtrusive). *.md typo.missing-header README* typo.missing-header +VERSION typo.missing-header *.adoc typo.missing-header -stdlib/*.mld typo.missing-header +api_docgen/*.mld typo.missing-header +api_docgen/alldoc.tex typo.missing-header tools/mantis2gh_stripped.csv typo.missing-header *.adoc typo.long-line=may @@ -63,7 +65,6 @@ tools/mantis2gh_stripped.csv typo.missing-header # tools/ci/appveyor/appveyor_build.cmd only has missing-header because # dra27 too lazy to update check-typo to interpret Cmd-style comments! /tools/ci/appveyor/appveyor_build.cmd typo.very-long-line typo.missing-header typo.non-ascii -/tools/ci/appveyor/appveyor_build.sh typo.non-ascii /tools/ci/inria/bootstrap/remove-sinh-primitive.patch typo.prune /release-info/howto.md typo.missing-header typo.long-line /release-info/templates/*.md typo.missing-header typo.very-long-line=may @@ -72,7 +73,7 @@ tools/mantis2gh_stripped.csv typo.missing-header /.depend.menhir typo.prune # Makefiles may contain tabs -Makefile* typo.tab=may +Makefile* typo.makefile-whitespace=may asmcomp/*/emit.mlp typo.tab=may typo.long-line=may @@ -101,6 +102,9 @@ otherlibs/win32unix/readlink.c typo.long-line otherlibs/win32unix/stat.c typo.long-line otherlibs/win32unix/symlink.c typo.long-line +runtime/sak.c typo.non-ascii +runtime/caml/compatibility.h typo.very-long-line + stdlib/hashbang typo.white-at-eol typo.missing-lf testsuite/tests/** typo.missing-header typo.long-line=may @@ -110,9 +114,11 @@ testsuite/tests/misc-unsafe/almabench.ml typo.long-line testsuite/tests/tool-toplevel/strings.ml typo.utf8 testsuite/tests/win-unicode/*.ml typo.utf8 testsuite/tests/asmgen/immediates.cmm typo.very-long-line +testsuite/tests/generated-parse-errors/errors.* typo.very-long-line testsuite/tools/*.S typo.missing-header testsuite/tools/*.asm typo.missing-header testsuite/typing typo.missing-header +testsuite/tests/messages/highlight_tabs.ml typo.tab # prune testsuite reference files testsuite/tests/**/*.reference typo.prune @@ -150,6 +156,7 @@ menhir-bench.bash typo.missing-header typo.utf8 /tools/ci/appveyor/appveyor_build.cmd text eol=crlf +aclocal.m4 typo.tab configure.ac text eol=lf build-aux/compile text eol=lf build-aux/config.guess text eol=lf @@ -164,6 +171,7 @@ stdlib/sharpbang text eol=lf tools/autogen text eol=lf tools/ci/inria/remove-sinh-primitive.patch text eol=lf tools/check-typo text eol=lf +tools/check-symbol-names text eol=lf tools/ci-build text eol=lf tools/msvs-promote-path text eol=lf tools/gdb-macros text eol=lf @@ -171,12 +179,9 @@ tools/magic text eol=lf tools/make-opcodes text eol=lf tools/make-package-macosx text eol=lf tools/ocaml-objcopy-macosx text eol=lf -tools/ocamlmktop.tpl text eol=lf tools/ocamlsize text eol=lf tools/pre-commit-githook text eol=lf tools/markdown-add-pr-links.sh text eol=lf -runtime/caml/m.h.in text eol=lf -runtime/caml/s.h.in text eol=lf runtime/caml/compatibility.h typo.long-line=may # These are all Perl scripts, so may not actually require this @@ -189,73 +194,23 @@ manual/tools/texexpand text eol=lf # Tests which include references spanning multiple lines fail with \r\n # endings, so use \n endings only, even on Windows. +testsuite/tests/backtrace/names.ml text eol=lf testsuite/tests/basic-modules/anonymous.ml text eol=lf -testsuite/tests/basic-more/morematch.ml text eol=lf -testsuite/tests/basic-more/robustmatch.ml text eol=lf -testsuite/tests/parsing/*.ml text eol=lf -testsuite/tests/docstrings/empty.ml text eol=lf +testsuite/tests/formatting/test_locations.ml text eol=lf testsuite/tests/functors/functors.ml text eol=lf +testsuite/tests/lib-dynlink-initializers/test10_main.ml text eol=lf +testsuite/tests/parsing/attributes.ml text eol=lf +testsuite/tests/parsing/extensions.ml text eol=lf +testsuite/tests/parsing/hash_ambiguity.ml text eol=lf +testsuite/tests/parsing/int_and_float_with_modifier.ml text eol=lf +testsuite/tests/parsing/pr6865.ml text eol=lf +testsuite/tests/parsing/quotedextensions.ml text eol=lf +testsuite/tests/parsing/shortcut_ext_attr.ml text eol=lf testsuite/tests/tool-ocamlc-stop-after/stop_after_parsing_impl.ml text eol=lf testsuite/tests/tool-ocamlc-stop-after/stop_after_parsing_intf.mli text eol=lf testsuite/tests/tool-ocamlc-stop-after/stop_after_typing_impl.ml text eol=lf -testsuite/tests/tool-toplevel/error_highlighting.ml text eol=lf -testsuite/tests/tool-toplevel/error_highlighting_use4.ml text eol=lf testsuite/tests/translprim/module_coercion.ml text eol=lf -testsuite/tests/typing-objects-bugs/pr3968_bad.ml text eol=lf -testsuite/tests/typing-ocamlc-i/pr7402.ml text eol=lf -testsuite/tests/typing-ocamlc-i/pervasives_leitmotiv.ml text eol=lf -testsuite/tests/typing-recmod/t12bad.ml text eol=lf -testsuite/tests/typing-safe-linking/b_bad.ml text eol=lf -testsuite/tests/warnings/w04.ml text eol=lf -testsuite/tests/warnings/w04_failure.ml text eol=lf -testsuite/tests/warnings/w32.ml text eol=lf - -# These are forced to \n to allow the Cygwin testsuite to pass on a + +# This is forced to \n to allow the Cygwin testsuite to pass on a # Windows-checkout -testsuite/tests/formatting/margins.ml text eol=lf -testsuite/tests/letrec-check/pr7706.ml text eol=lf -testsuite/tests/letrec-disallowed/disallowed.ml text eol=lf -testsuite/tests/letrec-disallowed/extension_constructor.ml text eol=lf -testsuite/tests/letrec-disallowed/float_block_allowed.ml text eol=lf -testsuite/tests/letrec-disallowed/float_block_disallowed.ml text eol=lf -testsuite/tests/letrec-disallowed/generic_arrays.ml text eol=lf -testsuite/tests/letrec-disallowed/lazy_.ml text eol=lf -testsuite/tests/letrec-disallowed/module_constraints.ml text eol=lf -testsuite/tests/letrec-disallowed/unboxed.ml text eol=lf -testsuite/tests/letrec-disallowed/pr7215.ml text eol=lf -testsuite/tests/letrec-disallowed/pr7231.ml text eol=lf -testsuite/tests/letrec-disallowed/pr7706.ml text eol=lf -testsuite/tests/lexing/uchar_esc.ml text eol=lf -testsuite/tests/match-exception-warnings/exhaustiveness_warnings.ml text eol=lf -testsuite/tests/tool-toplevel/pr7060.ml text eol=lf -testsuite/tests/typing-extension-constructor/test.ml text eol=lf -testsuite/tests/typing-extensions/extensions.ml text eol=lf -testsuite/tests/typing-extensions/open_types.ml text eol=lf -testsuite/tests/typing-objects/Exemples.ml text eol=lf -testsuite/tests/typing-objects/pr5619_bad.ml text eol=lf -testsuite/tests/typing-objects/pr6123_bad.ml text eol=lf -testsuite/tests/typing-objects/pr6907_bad.ml text eol=lf -testsuite/tests/typing-objects/Tests.ml text eol=lf -testsuite/tests/typing-pattern_open/pattern_open.ml text eol=lf -testsuite/tests/typing-private/private.ml text eol=lf -testsuite/tests/typing-recordarg/recordarg.ml text eol=lf -testsuite/tests/typing-short-paths/pr5918.ml text eol=lf -testsuite/tests/typing-sigsubst/sigsubst.ml text eol=lf -testsuite/tests/typing-typeparam/newtype.ml text eol=lf -testsuite/tests/typing-unboxed/test.ml text eol=lf -testsuite/tests/typing-unboxed-types/test.ml text eol=lf -testsuite/tests/typing-unboxed-types/test_flat.ml text eol=lf -testsuite/tests/typing-unboxed-types/test_no_flat.ml text eol=lf -testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml text eol=lf -testsuite/tests/typing-warnings/application.ml text eol=lf -testsuite/tests/typing-warnings/coercions.ml text eol=lf -testsuite/tests/typing-warnings/exhaustiveness.ml text eol=lf -testsuite/tests/typing-warnings/pr6587.ml text eol=lf -testsuite/tests/typing-warnings/pr6872.ml text eol=lf -testsuite/tests/typing-warnings/pr7085.ml text eol=lf -testsuite/tests/typing-warnings/pr7115.ml text eol=lf -testsuite/tests/typing-warnings/pr7261.ml text eol=lf -testsuite/tests/typing-warnings/pr7297.ml text eol=lf -testsuite/tests/typing-warnings/pr7553.ml text eol=lf -testsuite/tests/typing-warnings/records.ml text eol=lf -testsuite/tests/typing-warnings/unused_types.ml text eol=lf +testsuite/tests/parsetree/locations_test.ml text eol=lf diff --git a/ocaml/.github/workflows/build.yml b/ocaml/.github/workflows/build.yml new file mode 100644 index 00000000000..2fae5fd1ace --- /dev/null +++ b/ocaml/.github/workflows/build.yml @@ -0,0 +1,114 @@ +name: build +on: [push, pull_request] +jobs: + build: + name: ${{ matrix.name }} + runs-on: ${{ matrix.os }} + + strategy: + fail-fast: false + matrix: + include: + - name: closure-nnp-local + config: --enable-stack-allocation + os: ubuntu-latest + ocamlparam: '' + check_arch: true + + - name: flambda-local + config: --enable-flambda --enable-stack-allocation + os: ubuntu-latest + use_runtime: d + ocamlrunparam: "v=0,V=1" + + - name: i386 + config: CC='cc32' AS='as --32' ASPP='gcc -m32 -c' -host i386-linux PARTIALLD='ld -r -melf_i386' + os: ubuntu-20.04 + ocamlparam: '' + boot_config: CC='cc32' AS='as --32' ASPP='gcc -m32 -c' -host i386-linux PARTIALLD='ld -r -melf_i386' + boot_cachekey: 32bit + + env: + J: "3" + + steps: + - name: Install GNU parallel + if: matrix.os == 'macos-latest' + run: HOMEBREW_NO_INSTALL_CLEANUP=TRUE brew install parallel + + - name: Install GCC 32-bit libraries + if: matrix.name == 'i386' + run: | + sudo apt-get install gcc-multilib gfortran-multilib + + - name: Checkout the ocaml-jst repo + uses: actions/checkout@master + with: + path: 'ocaml-jst' + + - name: Cache OCaml 4.12 and dune + uses: actions/cache@v1 + id: cache + with: + path: ${{ github.workspace }}/ocaml-412/_install + key: ${{ matrix.os }}-cache-ocaml-412-dune-341-bits-${{ matrix.boot_cachekey }} + + - name: Checkout OCaml 4.12 + uses: actions/checkout@master + if: steps.cache.outputs.cache-hit != 'true' + with: + repository: 'ocaml/ocaml' + path: 'ocaml-412' + ref: '4.12' + + - name: Setup 32-bit C compiler + if: matrix.name == 'i386' && steps.cache.outputs.cache-hit != 'true' + run: | + mkdir -p ocaml-412/_install/bin + { echo '#!/bin/sh'; echo 'exec gcc -m32 "$@"'; } > ocaml-412/_install/bin/cc32 + chmod +x ocaml-412/_install/bin/cc32 + + - name: Build OCaml 4.12 + if: steps.cache.outputs.cache-hit != 'true' + working-directory: ocaml-412 + run: | + export PATH=$GITHUB_WORKSPACE/ocaml-412/_install/bin:$PATH + ./configure --prefix=$GITHUB_WORKSPACE/ocaml-412/_install ${{ matrix.boot_config }} + make -j $J world.opt + make install + # Remove unneeded parts to shrink cache file + rm -rf $GITHUB_WORKSPACE/ocaml-412/_install/{lib/ocaml/compiler-libs,lib/ocaml/expunge,bin/*.byte} + + - name: Checkout dune github repo + uses: actions/checkout@master + if: steps.cache.outputs.cache-hit != 'true' + with: + repository: 'ocaml/dune' + ref: '3.4.1' + path: 'dune' + + - name: Build dune + working-directory: dune + if: steps.cache.outputs.cache-hit != 'true' + run: | + PATH=$GITHUB_WORKSPACE/ocaml-412/_install/bin:$PATH make release + cp dune.exe $GITHUB_WORKSPACE/ocaml-412/_install/bin/dune + + - name: Configure OCaml + working-directory: ocaml-jst + run: | + export PATH=$GITHUB_WORKSPACE/ocaml-412/_install/bin:$PATH + autoconf + ./configure \ + --prefix=$GITHUB_WORKSPACE/_install \ + ${{ matrix.config }} + + - name: Build, install and test ocaml-jst + working-directory: ocaml-jst + run: | + export PATH=$GITHUB_WORKSPACE/ocaml-412/_install/bin:$PATH + make -f Makefile.jst runtest-upstream + env: + BUILD_OCAMLPARAM: ${{ matrix.ocamlparam }} + OCAMLRUNPARAM: ${{ matrix.ocamlrunparam }} + USE_RUNTIME: ${{ matrix.use_runtime }} diff --git a/ocaml/.github/workflows/main.yml b/ocaml/.github/workflows/main.yml deleted file mode 100644 index 0077e5119e7..00000000000 --- a/ocaml/.github/workflows/main.yml +++ /dev/null @@ -1,107 +0,0 @@ -name: main - -on: [push, pull_request] - -jobs: - no-naked-pointers-local: - runs-on: ubuntu-latest - env: - OCAMLPARAM: "_,extension=local" - steps: - - name: Checkout - uses: actions/checkout@v2 - - name: configure tree - run: ./configure --disable-naked-pointers --disable-stdlib-manpages --disable-dependency-generation --enable-ocamltest - - name: Build - run: | - make -j world.opt - - name: Run the testsuite - run: | - make -C testsuite USE_RUNTIME=d all - i386-static-local: - runs-on: ubuntu-latest - env: - OCAMLPARAM: "_,extension=local" - steps: - - name: Checkout - uses: actions/checkout@v2 - - name: Packages - run: | - sudo apt-get update -y && sudo apt-get install -y gcc-multilib gfortran-multilib - - name: configure tree - run: | - XARCH=i386 CONFIG_ARG='--disable-stdlib-manpages --disable-shared' bash -xe tools/ci/actions/runner.sh configure - - name: Build - run: | - bash -xe tools/ci/actions/runner.sh build - - name: Run the testsuite - run: | - bash -xe tools/ci/actions/runner.sh test - - name: Install - run: | - bash -xe tools/ci/actions/runner.sh install - - name: Other checks - run: | - bash -xe tools/ci/actions/runner.sh other-checks - full-flambda: - runs-on: ubuntu-latest - steps: - - name: Checkout - uses: actions/checkout@v2 - - name: Packages - run: | - sudo apt-get update -y && sudo apt-get install -y texlive-latex-extra texlive-fonts-recommended - # Ensure that make distclean can be run from an empty tree - - name: distclean - run: | - MAKE_ARG=-j make distclean - - name: configure tree - run: | - MAKE_ARG=-j XARCH=x64 CONFIG_ARG='--enable-flambda --enable-dependency-generation' OCAMLRUNPARAM=b,v=0 bash -xe tools/ci/actions/runner.sh configure - - name: Build - run: | - MAKE_ARG=-j OCAMLRUNPARAM=b,v=0 bash -xe tools/ci/actions/runner.sh build - - name: Run the testsuite - run: | - MAKE_ARG=-j OCAMLRUNPARAM=b,v=0 bash -xe tools/ci/actions/runner.sh test - - name: Build API Documentation - run: | - MAKE_ARG=-j OCAMLRUNPARAM=b,v=0 bash -xe tools/ci/actions/runner.sh api-docs - - name: Install - run: | - MAKE_ARG=-j OCAMLRUNPARAM=b,v=0 bash -xe tools/ci/actions/runner.sh install - - name: Other checks - run: | - MAKE_ARG=-j OCAMLRUNPARAM=b,v=0 bash -xe tools/ci/actions/runner.sh other-checks - full-flambda-local: - runs-on: ubuntu-latest - env: - OCAMLPARAM: "_,extension=local" - steps: - - name: Checkout - uses: actions/checkout@v2 - - name: Packages - run: | - sudo apt-get update -y && sudo apt-get install -y texlive-latex-extra texlive-fonts-recommended - # Ensure that make distclean can be run from an empty tree - - name: distclean - run: | - MAKE_ARG=-j make distclean - - name: configure tree - run: | - MAKE_ARG=-j XARCH=x64 CONFIG_ARG='--enable-flambda --enable-dependency-generation' OCAMLRUNPARAM=b,v=0 bash -xe tools/ci/actions/runner.sh configure - - name: Build - run: | - MAKE_ARG=-j OCAMLRUNPARAM=b,v=0 bash -xe tools/ci/actions/runner.sh build - - name: Run the testsuite - run: | - MAKE_ARG=-j OCAMLRUNPARAM=b,v=0 bash -xe tools/ci/actions/runner.sh test - - name: Build API Documentation - run: | - MAKE_ARG=-j OCAMLRUNPARAM=b,v=0 bash -xe tools/ci/actions/runner.sh api-docs - - name: Install - run: | - MAKE_ARG=-j OCAMLRUNPARAM=b,v=0 bash -xe tools/ci/actions/runner.sh install - - name: Other checks - run: | - MAKE_ARG=-j OCAMLRUNPARAM=b,v=0 bash -xe tools/ci/actions/runner.sh other-checks diff --git a/ocaml/.gitignore b/ocaml/.gitignore index 2005d871000..4f23ba809a0 100644 --- a/ocaml/.gitignore +++ b/ocaml/.gitignore @@ -48,6 +48,7 @@ _build /ocaml-*.cache /config.log /config.status +/flexlink.opt /libtool /ocamlc.opt /expunge @@ -56,6 +57,11 @@ _build /ocamlopt.opt /ocamlnat /dirs-to-ignore.inc +/dune-project +/*.sexp +/_install +/_runtest +/_opam # specific files and patterns in sub-directories @@ -68,8 +74,10 @@ _build /asmcomp/CSE.ml /boot/ocamlrun +/boot/ocamlruns /boot/camlheader /boot/ocamlc.opt +/boot/flexlink.byte /bytecomp/opcodes.ml /bytecomp/opcodes.mli @@ -82,6 +90,8 @@ _build /emacs/ocamltags /emacs/*.elc +/flexdll-sources + /lambda/runtimedef.ml /lex/parser.ml @@ -91,8 +101,13 @@ _build /lex/ocamllex.opt /lex/parser.output -/manual/manual/cmds/warnings-help.etex -/manual/manual/warnings-help.etex +/manual/src/cmds/warnings-help.etex +/manual/src/html_processing/src/common.ml +/manual/src/warnings-help.etex + +/api_docgen/build +/api_docgen/odoc/build +/api_docgen/ocamldoc/build /ocamldoc/ocamldoc /ocamldoc/ocamldoc.opt @@ -106,14 +121,11 @@ _build /ocamldoc/odoc_text_lexer.ml /ocamldoc/odoc_text_parser.ml /ocamldoc/odoc_text_parser.mli -/ocamldoc/stdlib_man -/ocamldoc/stdlib_html -/ocamldoc/stdlib_latex -/ocamldoc/stdlib_texi /ocamldoc/*.output /ocamldoc/test_stdlib /ocamldoc/test_latex /ocamldoc/test +/ocamldoc/stdlib_man /ocamltest/.dep /ocamltest/ocamltest @@ -132,6 +144,7 @@ _build /otherlibs/dynlink/dynlink_compilerlibs/*.ml /otherlibs/dynlink/dynlink_compilerlibs/*.mli /otherlibs/dynlink/dynlink_compilerlibs/.depend +/otherlibs/dynlink/dynlink_compilerlibs.mli /otherlibs/threads/marshal.mli /otherlibs/threads/stdlib.mli /otherlibs/threads/unix.mli @@ -174,6 +187,7 @@ _build /parsing/parser.output /parsing/parser.automaton /parsing/parser.conflicts +/parsing/parser.auto.messages /parsing/camlinternalMenhirLib.ml /parsing/camlinternalMenhirLib.mli @@ -191,6 +205,8 @@ _build /runtime/ld.conf /runtime/.gdb_history /runtime/.dep +/runtime/build_config.h +/runtime/sak /runtime/domain_state32.inc /runtime/domain_state64.inc @@ -226,6 +242,7 @@ _build /tools/ocamlprof /tools/ocamlprof.opt /tools/opnames.ml +/tools/ocamlmklibconfig.ml /tools/dumpobj /tools/dumpobj.opt /tools/dumpapprox @@ -246,7 +263,6 @@ _build /tools/keywords /tools/ocamlmklib /tools/ocamlmklib.opt -/tools/ocamlmklibconfig.ml /tools/ocamlcmt /tools/ocamlcmt.opt /tools/cmpbyt @@ -258,6 +274,13 @@ _build /tools/caml-tex /tools/eventlog_metadata +/toplevel/byte/topeval.mli +/toplevel/byte/trace.mli +/toplevel/byte/topmain.mli +/toplevel/native/topeval.mli +/toplevel/native/trace.mli +/toplevel/native/topmain.mli + /utils/config.ml /utils/domainstate.ml /utils/domainstate.mli diff --git a/ocaml/.mailmap b/ocaml/.mailmap index 8eec8afae3e..08c772e097c 100644 --- a/ocaml/.mailmap +++ b/ocaml/.mailmap @@ -28,10 +28,21 @@ cvs2svn Damien Doligez Some Name Damien Doligez doligez Mohamed Iguernelala -Jérémie Dimino +Jérémie Dimino +Jérémie Dimino Jeremy Yallop yallop Nicolás Ojeda Bär - +Nicolás Ojeda Bär +François Pottier +Jérôme Vouillon +Frédéric Bour +Frédéric Bour +Armaël Guéneau +Armaël Guéneau +Armaël Guéneau +Edwin Török +Edwin Török +Edwin Török ### Approved Approvers @@ -121,6 +132,7 @@ Joris Giovannangeli Wilfred Hughes John Skaller Eduardo Rafael +Runhang Li # These contributors prefer to be referred to pseudonymously whitequark diff --git a/ocaml/BOOTSTRAP.adoc b/ocaml/BOOTSTRAP.adoc index e73d01fe628..70db0d0ea85 100644 --- a/ocaml/BOOTSTRAP.adoc +++ b/ocaml/BOOTSTRAP.adoc @@ -31,8 +31,8 @@ Here is how to perform a change that requires a bootstrap: safer. Similarly, `make world.opt` will also bring you to such a stable state but builds more things than actually required.) -4. Now, and only now, edit the sources. Changes here may include adding, - removing or renaming a primitive in the runtime, changing the magic +4. Now, and only now, edit the sources. Changes here may include removing + or renaming a primitive in the runtime, changing the magic number of bytecode executable files, changing the way types are represented or anything else in the format of .cmi files, etc. @@ -53,10 +53,57 @@ This will rebuild runtime/ocamlrun, ocamlc, etc. make bootstrap += Problems + If you notice that this procedure fails for a given change you are trying to implement, please report it so that the procedure can be updated to also cope with your change. += Upstreaming + If you want to upstream your changes, indicate in the message of the commit that the changes need a bootstrap. Perform the bootstrap and commit the result of the bootstrap separately, after that commit. + += Adding, removing and renaming primitives + +Primitives can be added without having to bootstrap, however it is necessary +to repeat `make coldstart` in order to use your new primitive in the standard +library. + +There are five steps to renaming a primitive: + +1. Rename the primitive and its uses + +2. Create a temporary stub with the old primitive's name. This stub simply + passes its arguments on to the new primitive: + + CAMLprim value caml_old_primitive(value a1, value a2) { + return caml_new_primitive(a1, a2); + } + +3. Deal with the addition of the new primitive: + + make coldstart + +4. Ensure the system still works: + + make coreall + +5. Now remove the old primitive stub and issue: + + make bootstrap + +It is desirable for bootstraps to be easily repeatable, so you should commit +changes after step 4. + += Bootstrap test script + +A script is provided (and used on Inria's continuous +integration infrastructure) to make sure the bootstrap works. This +script implements the bootstrap procedure described above and performs +two changes to the compiler: it updates the magic numbers and removes +a primitive from the runtime. It then makes sure the bootstrap still +works after these changes. This script can be run locally as follows: + + OCAML_ARCH=linux ./tools/ci/inria/bootstrap diff --git a/ocaml/CONTRIBUTING.md b/ocaml/CONTRIBUTING.md index 22e630b9dc3..6663229e5b4 100644 --- a/ocaml/CONTRIBUTING.md +++ b/ocaml/CONTRIBUTING.md @@ -66,10 +66,7 @@ contribution. You should not leave trailing whitespace; not have line longer than 80 columns, not use tab characters (spaces only), and not use non-ASCII characters. These typographical rules can be checked with the script -`tools/check-typo`. - -If you are working from a Git clone, you can automate this process by -copying the file `tools/pre-commit-githook` to `.git/hooks/pre-commit`. +`tools/check-typo`, see [HACKING.adoc: check-typo](HACKING.adoc#check-typo). Otherwise, there are no strongly enforced guidelines specific to the compiler -- and, as a result, the style may differ in the different @@ -341,51 +338,9 @@ log -u` to make sure the rebase patches make sense), but: ## Contributing to the standard library -Contributions to the standard library are very welcome. There is some -widespread belief in the community than the stdlib is somehow "frozen" -and that its evolutions are mostly driven by the need of the OCaml -compiler itself. Let's be clear: this is just plain wrong. The -compiler is happy with its own local utility functions, and many -recent additions to the stdlib are not used by the compiler. - -Another common and wrong idea is that core OCaml maintainers don't -really care about the standard library. This is not true, and won't -be unless one of the "alternative standard" libraries really gains -enough "market share" in the community. - -So: please contribute! - -Obviously, the proposals to evolve the standard library will be -evaluated with very high standards, similar to those applied to the -evolution of the surface langage, and much higher than those for -internal compiler changes (optimizations, etc). - -A key property of the standard library is its stability. Backward -compatibility is not an absolute technical requirement (any addition -to/of a module can break existing code, formally), but breakage should -be limited as much as possible (and assessed, when relevant). A -corollary is that any addition creates a long-term support commitment. -For instance, once a concrete type or function is made public, -changing the exposed definition cannot be done easily. - -There is no plan to extend dramatically the functional domain covered -by the standard library. For instance, proposals to include support -for XML, JSON, or network protocols are very likely to be rejected. Such -domains are better treated by external libraries. Small additions to -existing modules are much simpler to get in, even more so (but not -necessarily) when: - - - they cannot easily be implemented externally, or when - - they facilitate communication between independent external - libraries, or when - - they fill obvious gaps. - -Of course, standard guidelines apply as well: proper documentation, -proper tests, portability (yes, also Windows!), good justification for -why the change is desirable and why it should go into stdlib. - -So: be prepared for some serious review process! But yes, yes, -contributions are welcome and appreciated. Promised. +Contributions to the standard library are very welcome. +See the dedicated [stdlib/CONTRIBUTING.md](stdlib/CONTRIBUTING.md) +for more information. ## Contributing optimizations diff --git a/ocaml/Changes b/ocaml/Changes index 686702c9e8d..a91fe1ecdbe 100644 --- a/ocaml/Changes +++ b/ocaml/Changes @@ -1,38 +1,1304 @@ +OCaml 4.14.1 (20 December 2022) +------------------------------ -OCaml 4.14, maintenance version -------------------------------- +### Bug fixes: -### Code generation and optimizations: +- #11803, #11808: on x86, the destination of an integer comparison must be + a register, it cannot be a stack slot. + (Vincent Laviron, review by Xavier Leroy, report by + Emilio Jesús Gallego Arias) + + +OCaml 4.14.1 +----------------------------- + +### Compiler user-interface and warnings: + +- #11184, #11670: Stop calling ranlib on created / installed libraries + (Sébastien Hinderer and Xavier Leroy, review by the same) + +### Build system: + +- #11370, #11373: Don't pass CFLAGS to flexlink during configure. + (David Allsopp, report by William Hu, review by Xavier Leroy and + Sébastien Hinderer) + +- #11487: Thwart FMA test optimization during configure + (William Hu, review by David Allsopp and Sébastien Hinderer) + +### Bug fixes: + +- #10768, #11340: Fix typechecking regression when combining first class + modules and GADTs. + (Jacques Garrigue, report by François Thiré, review by Matthew Ryan) + +- #11204: Fix regression introduced in 4.14.0 that would trigger Warning 17 when + calling virtual methods introduced by constraining the self type from within + the class definition. + (Nicolás Ojeda Bär, review by Leo White) + +- #11263, #11267: caml/{memory,misc}.h: check whether `_MSC_VER` is defined + before using it to ensure that the headers can always be used in code which + turns on -Wundef (or equivalent). + (David Allsopp and Nicolás Ojeda Bär, review by Nicolás Ojeda Bär and + Sébastien Hinderer) + +- #11314, #11416: fix non-informative error message for module inclusion + (Florian Angeletti, report by Thierry Martinez, review by Gabriel Scherer) + +- #11358, #11379: Refactor the initialization of bytecode threading, + This avoids a "dangling pointer" warning of GCC 12.1. + (Xavier Leroy, report by Armaël Guéneau, review by Gabriel Scherer) + +- #11387, module type with constraints no longer crash the compiler in presence + of both shadowing warnings and the `-bin-annot` compiler flag. + (Florian Angeletti, report by Christophe Raffalli, review by Gabriel Scherer) + +- #11392, #11392: assertion failure with -rectypes and external definitions + (Gabriel Scherer, review by Florian Angeletti, report by Dmitrii Kosarev) + +- #11417: Fix regression allowing virtual methods in non-virtual classes. + (Leo White, review by Florian Angeletti) + +- #11468: Fix regression from #10186 (OCaml 4.13) detecting IPv6 on Windows for + mingw-w64 i686 port. + (David Allsopp, review by Xavier Leroy and Sébastien Hinderer) + +- #11489, #11496: More prudent deallocation of alternate signal stack + (Xavier Leroy, report by @rajdakin, review by Florian Angeletti) + +- #11516, #11524: Fix the `deprecated_mutable` attribute. + (Chris Casinghino, review by Nicolás Ojeda Bär and Florian Angeletti) + +- #11194, #11609: Fix inconsistent type variable names in "unbound type var" + messages + (Ulysse Gérard and Florian Angeletti, review Florian Angeletti and + Gabriel Scherer) + +- #11622: Prevent stack overflow when printing a constructor or record + mismatch error involving recursive types. + (Florian Angeletti, review by Gabriel Scherer) + +- #11732: Ensure that types from packed modules are always generalised + (Stephen Dolan and Leo White, review by Jacques Garrigue) + +- #11737: Fix segfault condition in Unix.stat under Windows in the presence of + multiple threads. + (Marc Lasson, Nicolás Ojeda Bär, review by Gabriel Scherer and David Allsopp) + +- #11776: Extend environment with functor parameters in `strengthen_lazy`. + (Chris Casinghino and Luke Maurer, review by Gabriel Scherer) + +- #11533, #11534: follow synonyms again in #show_module_type + (this had stopped working in 4.14.0) + (Gabriel Scherer, review by Jacques Garrigue, report by Yaron Minsky) + +- #11768, #11788: Fix crash at start-up of bytecode programs in + no-naked-pointers mode caused by wrong initialization of caml_global_data + (Xavier Leroy, report by Etienne Millon, review by Gabriel Scherer) + + +OCaml 4.14.0 (28 March 2022) +---------------------------- + +### Language features (highlights): + +- #10437: Allow explicit binders for type variables. + (Stephen Dolan, review by Leo White) + +- #181, #9760, #10740: opt-in tail-modulo-cons (TMC) transformation + let[@tail_mod_cons] rec map f li = ... + (Frédéric Bour, Gabriel Scherer, Basile Clément, + review by Basile Clément and Pierre Chambart, + tested by Konstantin Romanov) + +### Runtime system (highlights): + +- #10195, #10680: Speed up GC by prefetching during marking + (Stephen Dolan, review by Xavier Leroy, Guillaume Munch-Maccagnoni, + Jacques-Henri Jourdan, Damien Doligez and Leo White) + +### Code generation and optimizations (highlights): - #10595: Tail calls with up to 64 arguments are guaranteed to be compiled as tail calls. To this end, memory locations in the domain state are used for passing arguments that do not fit in registers. (Xavier Leroy, review by Vincent Laviron) +### Standard library (highlights): -OCaml 4.12, maintenance version -------------------------------- +* #10710: Add UTF tools, codecs and validations to the Uchar, Bytes and + String modules. + (Daniel Bünzli, review by Florian Angeletti, Nicolás Ojeda Bär, Alain + Frisch and Gabriel Scherer) + +* #10482: mark the Stream and Genlex modules as deprecated, in preparation + for a future removal. These modules (without deprecation alert) + are now provided by the camlp-streams library. + (Xavier Leroy, review by Nicolás Ojeda Bär) + +- #10545: Add In_channel and Out_channel modules. + (Nicolás Ojeda Bär, review by Daniel Bünzli, Simon Cruanes, Gabriel Scherer, + Guillaume Munch-Maccagnoni, Alain Frisch and Xavier Leroy) + +### Compiler user-interface and warnings (highlights) + +- #10328, #10780: Give more precise error when disambiguation could not + possibly work. + (Leo White, review by Gabriel Scherer and Florian Angeletti) + +- #10361: Improve error messages for mismatched record and variant + definitions. + (Florian Angeletti, review by Gabriel Radanne and Gabriel Scherer) + +- #10407: Produce more detailed error messages that contain full error traces + when module inclusion fails. + (Antal Spector-Zabusky, review by Florian Angeletti) + +### Internal/compiler-libs changes (highlights): + +- #10718, #11012: Add "Shape" information to the cmt files. Shapes are an + abstraction of modules that can be used by external tooling to perform + definition-aware operations. + (Ulysse Gérard, Thomas Refis and Leo White, review by Florian Angeletti) + +### Language features: + +- #10462: Add attribute to produce a compiler error for polls. + (Sadiq Jaffer, review by Mark Shinwell, Stephen Dolan + and Guillaume Munch-Maccagnoni) + +- #10441: Remove unnecessary parentheses surrounding immediate objects. + Allow 'object ... end # f', 'f object ... end', etc. + (Yan Dong, review by Nicolás Ojeda Bär, Florian Angeletti and Gabriel Scherer) + +### Runtime system: + +* #9391, #9424: Fix failed assertion in runtime due to ephemerons *set_* and + *blit_* function during Mark phase + (François Bobot, reported by Stephen Dolan, reviewed by Damien Doligez) + +- #10549: Stack overflow detection and naked pointers checking for ARM64 + (Xavier Leroy, review by Stephen Dolan) + +* #10675, #10937: Emit deprecation warnings when old C runtime function names + are used. This will break C stub code that uses these old names and + treats warnings as errors. The workaround is to use the new names. + (Xavier Leroy and David Allsopp, review by Sébastien Hinderer and + Damien Doligez) + +- #10698, #10726, #10891: Free the alternate signal stack when the main OCaml + code or an OCaml thread stops + (Xavier Leroy, review by David Allsopp and Damien Doligez) + +- #10730, 10731: Fix bug in `Obj.reachable_words` causing a slowdown when called + multiple time (Alain Frisch, report by ygrek, review by Xavier Leroy) + +### Code generation and optimizations: + +- #10578: Increase the number of integer registers used for + parameter passing on PowerPC (16 registers) and on s390x (8 registers). + (Xavier Leroy, review by Mark Shinwell) + +- #10591, #10615: Tune the heuristic for CSE of integer constants + so as to avoid excessive CSE on compiler-generated constants + and long register allocation times. + (Xavier Leroy, report by Edwin Török, review by Nicolás Ojeda Bär) + +- #10681: Enforce boolean conditions for the native backend + (Vincent Laviron, review by Gabriel Scherer) + +- #10719: Ensure that build_apply respects Lambda.max_arity + (Stephen Dolan, review by Xavier Leroy) + +- #10728: Ensure that functions are evaluated after their arguments + (Stephen Dolan, review by Mark Shinwell) + +- #10732: Ensure right-to-left evaluation of arguments in cmm_helpers + (Greta Yorsh, review by Xavier Leroy) + +### Standard library: + +* #10622: Annotate `Uchar.t` with immediate attribute + (Hongbo Zhang, reivew by Gabriel Scherer and Nicolás Ojeda Bär) + +* #7812, #10475: `Filename.chop_suffix name suff` now checks that `suff` + is actually a suffix of `name` and raises Invalid_argument otherwise. + (Xavier Leroy, report by whitequark, review by David Allsopp) + +- #10526: add Random.bits32, Random.bits64, Random.nativebits + (Xavier Leroy, review by Gabriel Scherer and François Bobot) + +* #10568: remove Obj.marshal and Obj.unmarshal + (these functions have been deprecated for a while and are superseded + by the functions from module Marshal) + (François Pottier, review by Gabriel Scherer and Kate Deplaix) + +- #10538: add Out_channel.set_buffered and Out_channel.is_buffered to control + the buffering mode of output channels. + (Nicolás Ojeda Bär, review by John Whitington, Daniel Bünzli, David Allsopp + and Xavier Leroy) + +* #10583, #10998: Add over 40 new functions in Seq. + (François Pottier and Simon Cruanes, review by Nicolás Ojeda Bär, + Daniel Bünzli, Naëla Courant, Craig Ferguson, Wiktor Kuchta, + Xavier Leroy, Guillaume Munch-Maccagnoni, Raphaël Proust, Gabriel Scherer + and Thierry Martinez) + +- #10596, #10978: Add with_open_bin, with_open_text and with_open_gen to + In_channel and Out_channel. Also, add In_channel.input_all. + (Nicolás Ojeda Bär, review by Daniel Bünzli, Jérémie Dimino, Damien Doligez + and Xavier Leroy) + +- #10658: add detailed information about the current version of OCaml + to the Sys module of the standard library. + (Sébastien Hinderer, review by Damien Doligez, Gabriel Scherer, David + Allsopp, Nicolás Ojeda Bär, Vincent Laviron) + +- #10642: On Windows, Sys.remove and Unix.unlink now remove symlinks + to directories instead of raising EACCES. Introduce + caml/winsupport.h to hold more common code between the runtime, + lib-sys, and win32unix. + (Antonin Décimo, review by David Allsopp and Xavier Leroy) + +- #10737: add new ephemeron API for forward compatibility with Multicore + OCaml. + (Damien Doligez, review by Stephen Dolan) + +* #10922: Add deprecation warnings on {Int32,Int64,Nativeint}.format. + (Nicolás Ojeda Bär, review by Xavier Leroy and Florian Angeletti) + +### Other libraries: + +- #10192: Add support for Unix domain sockets on Windows and use them + to emulate Unix.socketpair (only available on Windows 1803+) + (Antonin Décimo, review by David Allsopp) + +- #10469: Add Thread.set_uncaught_exception_handler and + Thread.default_uncaught_exception_handler. + (Enguerrand Decorne, review by David Allsopp) + +- #10697: Bindings of dup and dup2 in win32unix now correctly call + WSADuplicateSocket on sockets instead of DuplicateHandle. + (Antonin Décimo, review by Xavier Leroy and Nicolás Ojeda Bär) + +- #10951: Introduce the Thread.Exit exception as an alternative way to + terminate threads prematurely. This alternative way will become + the standard way in 5.00. + (Xavier Leroy, review by Florian Angeletti) + +### Tools: + +- #10839: Fix regression of #show when printing class type + (Élie Brami, review by Florian Angeletti) + +- #3959, #7202, #10476: ocaml, in script mode, directive errors + (`#use "missing_file";;`) use stderr and exit with an error. + (Florian Angeletti, review by Gabriel Scherer) + +- #10438: add a new toplevel cli argument `-e + +
 Up + 
+

Module Entities

+ +
module Entities: sig .. end
+ +
type ul
+ + +
type li
+ + +
type amp
+ + +
type [< `A of & amp ] t = <
+ + + + +
+   +ul : < li : [< `A of & amp ] as 'a >;
+> + + + diff --git a/ocaml/testsuite/tests/tool-ocamldoc/Entities.ml b/ocaml/testsuite/tests/tool-ocamldoc/Entities.ml new file mode 100644 index 00000000000..218817eed88 --- /dev/null +++ b/ocaml/testsuite/tests/tool-ocamldoc/Entities.ml @@ -0,0 +1,8 @@ +(* TEST + * ocamldoc with html +*) + +type ul +type li +type amp +type 'a t = > diff --git a/ocaml/testsuite/tests/tool-ocamldoc/Inline_records.html.reference b/ocaml/testsuite/tests/tool-ocamldoc/Inline_records.html.reference index 07f7ed18e92..cab1cd55d8c 100644 --- a/ocaml/testsuite/tests/tool-ocamldoc/Inline_records.html.reference +++ b/ocaml/testsuite/tests/tool-ocamldoc/Inline_records.html.reference @@ -299,7 +299,7 @@    -even_more : int -> int; +even_more : int -> int; (*

Some field documentations for F

@@ -325,7 +325,7 @@    -last : int -> int; +last : int -> int; (*

The last and least field documentation

diff --git a/ocaml/testsuite/tests/tool-ocamldoc/Module_whitespace.html.reference b/ocaml/testsuite/tests/tool-ocamldoc/Module_whitespace.html.reference index c31de5be95c..c528be1c1f6 100644 --- a/ocaml/testsuite/tests/tool-ocamldoc/Module_whitespace.html.reference +++ b/ocaml/testsuite/tests/tool-ocamldoc/Module_whitespace.html.reference @@ -20,5 +20,5 @@ 
type t = int
-
val compare : 'a -> 'a -> int
+
val compare : 'a -> 'a -> int
end)
diff --git a/ocaml/testsuite/tests/tool-ocamlobjinfo/question.ml b/ocaml/testsuite/tests/tool-ocamlobjinfo/question.ml index 0b42dd1f9df..43c440b2a21 100644 --- a/ocaml/testsuite/tests/tool-ocamlobjinfo/question.ml +++ b/ocaml/testsuite/tests/tool-ocamlobjinfo/question.ml @@ -8,6 +8,13 @@ program = "question.cmxs" **** check-ocamlopt.byte-output ***** ocamlobjinfo ****** check-program-output + +***** ocamlobjinfo +program = "question.cmx" +(* The cmx output varies too much to check. We're just happy it didn't + segfault on us. *) *) -let answer = 42 +(* We use a function rather than a value of type int to ensure that there + is an Flambda 2 code section. *) +let answer () = 42 diff --git a/ocaml/testsuite/tests/tool-ocamlopt-save-ir/start_from_emit.ml b/ocaml/testsuite/tests/tool-ocamlopt-save-ir/start_from_emit.ml index 6f6cdf0f282..bac85a816fd 100644 --- a/ocaml/testsuite/tests/tool-ocamlopt-save-ir/start_from_emit.ml +++ b/ocaml/testsuite/tests/tool-ocamlopt-save-ir/start_from_emit.ml @@ -17,8 +17,9 @@ flags = "-S start_from_emit.cmir-linear -save-ir-after scheduling" module = "empty.ml" ocamlopt_byte_exit_status = "0" - ********* script - script = "cp start_from_emit.cmir-linear expected.cmir_linear" + ********* copy + src = "start_from_emit.cmir-linear" + dst = "expected.cmir_linear" ********** check-ocamlopt.byte-output *********** script script = "cmp start_from_emit.cmir-linear expected.cmir_linear" diff --git a/ocaml/testsuite/tests/tool-toplevel-invocation/test.ml b/ocaml/testsuite/tests/tool-toplevel-invocation/test.ml index 8beae14f136..b5c54d54994 100644 --- a/ocaml/testsuite/tests/tool-toplevel-invocation/test.ml +++ b/ocaml/testsuite/tests/tool-toplevel-invocation/test.ml @@ -1,6 +1,6 @@ (* TEST -files = "first_arg_fail.txt last_arg_fail.txt" +readonly_files = "first_arg_fail.txt last_arg_fail.txt" * setup-ocaml-build-env diff --git a/ocaml/testsuite/tests/tool-toplevel/error_highlighting.ml b/ocaml/testsuite/tests/tool-toplevel/error_highlighting.ml index 5716a7ac9f1..dbf3810387a 100644 --- a/ocaml/testsuite/tests/tool-toplevel/error_highlighting.ml +++ b/ocaml/testsuite/tests/tool-toplevel/error_highlighting.ml @@ -1,8 +1,8 @@ (* TEST - files = "error_highlighting_use1.ml \ - error_highlighting_use2.ml \ - error_highlighting_use3.ml \ - error_highlighting_use4.ml" + readonly_files = "error_highlighting_use1.ml \ + error_highlighting_use2.ml \ + error_highlighting_use3.ml \ + error_highlighting_use4.ml" * toplevel *) diff --git a/ocaml/testsuite/tests/tool-toplevel/known-bugs/broken_rec_in_show.ml b/ocaml/testsuite/tests/tool-toplevel/known-bugs/broken_rec_in_show.ml index f4c3f497de6..688ac53844f 100644 --- a/ocaml/testsuite/tests/tool-toplevel/known-bugs/broken_rec_in_show.ml +++ b/ocaml/testsuite/tests/tool-toplevel/known-bugs/broken_rec_in_show.ml @@ -10,9 +10,9 @@ type t = T of t;; type t = T of t |}] #show t;; -(* this output is INCORRECT, it should not use nonrec *) +(* this output is CORRECT, it should not use nonrec *) [%%expect{| -type nonrec t = T of t +type t = T of t |}];; type nonrec s = Foo of t;; @@ -20,9 +20,9 @@ type nonrec s = Foo of t;; type nonrec s = Foo of t |}];; #show s;; -(* this output is CORRECT, it uses nonrec *) +(* this output is CORRECT, it elides the unnecessary nonrec keyword *) [%%expect{| -type nonrec s = Foo of t +type s = Foo of t |}];; @@ -32,16 +32,49 @@ module M : sig type t val x : t end = struct type t = int let x = 0 end;; module M : sig type t val x : t end |}];; (* this output is CORRECT, it does not use 'rec' *) -[%%expect{| -|}];; module rec M : sig type t val x : M.t end = struct type t = int let x = 0 end;; -(* this output is strange, it is surprising to use M/2 here. *) +(* this output is CORRECT . *) [%%expect{| -module rec M : sig type t val x : M/2.t end +module rec M : sig type t val x : M.t end |}];; #show_module M;; -(* this output is INCORRECT, it should use 'rec' *) +(* this output is CORRECT *) +[%%expect{| +module rec M : sig type t val x : M.t end +|}];; + + +(* Indirect recursion *) + +type t +type f = [ `A of t ] +type t = X of u | Y of [ f | `B ] and u = Y of t;; + +[%%expect{| +type t +type f = [ `A of t ] +type t = X of u | Y of [ `A of t/1 | `B ] +and u = Y of t/2 +|}];; + +#show t;; +(* this output is PARTIAL: t is mutually recursive with u *) +[%%expect{| +type nonrec t = X of u | Y of [ `A of t/2 | `B ] +|}];; + + +module rec M: sig type t = X of N.t end = M +and N: sig type t = X of M.t end = N + +[%%expect{| +module rec M : sig type t = X of N.t end +and N : sig type t = X of M.t end +|}];; + +(* this output is PARTIAL: M is mutually recursive with N *) +#show M;; [%%expect{| -module M : sig type t val x : M.t end +module M : sig type t = X of N.t end |}];; diff --git a/ocaml/testsuite/tests/tool-toplevel/mod_use.ml b/ocaml/testsuite/tests/tool-toplevel/mod_use.ml index e068ffc3aa8..4ea967e5c0d 100644 --- a/ocaml/testsuite/tests/tool-toplevel/mod_use.ml +++ b/ocaml/testsuite/tests/tool-toplevel/mod_use.ml @@ -1,5 +1,5 @@ (* TEST - files = "mod.ml" + readonly_files = "mod.ml" * expect *) diff --git a/ocaml/testsuite/tests/tool-toplevel/pr6468.compilers.reference b/ocaml/testsuite/tests/tool-toplevel/pr6468.compilers.reference index 29d1c5e6fe1..ada52ad007a 100644 --- a/ocaml/testsuite/tests/tool-toplevel/pr6468.compilers.reference +++ b/ocaml/testsuite/tests/tool-toplevel/pr6468.compilers.reference @@ -10,5 +10,5 @@ Raised at f in file "//toplevel//", line 2, characters 11-26 Called from g in file "//toplevel//", line 1, characters 11-15 Called from Stdlib__Fun.protect in file "fun.ml", line 37, characters 8-15 Re-raised at Stdlib__Fun.protect in file "fun.ml", line 42, characters 6-52 -Called from Toploop.load_lambda in file "toplevel/toploop.ml", line 212, characters 4-150 +Called from Topeval.load_lambda in file "ocaml/toplevel/byte/topeval.ml", line 90, characters 4-150 diff --git a/ocaml/testsuite/tests/tool-toplevel/show.ml b/ocaml/testsuite/tests/tool-toplevel/show.ml index 6c000120ec0..28b59d9fdb1 100644 --- a/ocaml/testsuite/tests/tool-toplevel/show.ml +++ b/ocaml/testsuite/tests/tool-toplevel/show.ml @@ -5,6 +5,26 @@ (* this is a set of tests to test the #show functionality * of toplevel *) +class o = object val x = 0 end;; +[%%expect{| +class o : object val x : int end +|}];; +#show o;; +[%%expect{| +type o = < > +class o : object val x : int end +class type o = object val x : int end +|}];; +class type t = object val x : int end;; +[%%expect{| +class type t = object val x : int end +|}];; +#show t;; +[%%expect{| +type t = < > +class type t = object val x : int end +|}];; + #show Foo;; [%%expect {| Unknown element. @@ -40,7 +60,7 @@ type 'a option = None | Some of 'a #show option;; [%%expect {| -type nonrec 'a option = None | Some of 'a +type 'a option = None | Some of 'a |}];; #show Open_binary;; @@ -59,7 +79,7 @@ type Stdlib.open_flag = #show open_flag;; [%%expect {| -type nonrec open_flag = +type open_flag = Open_rdonly | Open_wronly | Open_append @@ -90,7 +110,7 @@ type extensible += B of int #show extensible;; [%%expect {| -type nonrec extensible = .. +type extensible = .. |}];; type 'a t = ..;; @@ -104,3 +124,52 @@ type _ t += A : int t [%%expect{| type 'a t += A : int t |}];; + + + + +(* regression tests for #11533 *) +#show Set.OrderedType;; +[%%expect {| +module type OrderedType = sig type t val compare : t -> t -> int end +|}];; + +(* extra tests after #11533 + + The regression in #11533 would only show up when showing values defined + outside the current module. Those new tests below test modules and module + types from the standard library. To minimize test churn / promotion, + we are looking for some that will change as little as possible + in the future. + + - For module type it's easy: OrderedType is fixed in stone as + changing it would break all code using Set.Make. + + - For modules we use Stdlib.Unit, one of the stdlib modules + that is less likely to change very often (there are only + so many features you can add to 'unit'). +*) +module U = Stdlib.Unit;; +module type OT = Set.OrderedType;; +[%%expect {| +module U = Unit +module type OT = Set.OrderedType +|}];; + +#show U;; +[%%expect {| +module U = Unit +module U : + sig + type t = unit = () + val equal : t -> t -> bool + val compare : t -> t -> int + val to_string : t -> string + end +|}];; + +#show OT;; +[%%expect {| +module type OT = Set.OrderedType +module type OT = sig type t val compare : t -> t -> int end +|}];; diff --git a/ocaml/testsuite/tests/tool-toplevel/show_short_paths.ml b/ocaml/testsuite/tests/tool-toplevel/show_short_paths.ml index c0c50de20c1..000e7752347 100644 --- a/ocaml/testsuite/tests/tool-toplevel/show_short_paths.ml +++ b/ocaml/testsuite/tests/tool-toplevel/show_short_paths.ml @@ -8,12 +8,12 @@ #show list;; [%%expect {| -type nonrec 'a list = [] | (::) of 'a * 'a list +type 'a list = [] | (::) of 'a * 'a list |}];; type 'a t;; #show t;; [%%expect {| type 'a t -type nonrec 'a t +type 'a t |}];; diff --git a/ocaml/testsuite/tests/tool-toplevel/topeval.compilers.reference b/ocaml/testsuite/tests/tool-toplevel/topeval.compilers.reference new file mode 100644 index 00000000000..0a7e236f97d --- /dev/null +++ b/ocaml/testsuite/tests/tool-toplevel/topeval.compilers.reference @@ -0,0 +1,10 @@ +module A : + sig type ('foo, 'bar) t val get_foo : ('foo, 'a) t -> 'foo option end +- : ('foo, 'a) A.t -> 'foo option = +val _bar : ('a, 'b) A.t -> 'a option = +- : int = 42 +- : bool = false +- : string = "" +- : char = 'd' +- : float = 42. + diff --git a/ocaml/testsuite/tests/tool-toplevel/topeval.ml b/ocaml/testsuite/tests/tool-toplevel/topeval.ml new file mode 100644 index 00000000000..802f04b5afc --- /dev/null +++ b/ocaml/testsuite/tests/tool-toplevel/topeval.ml @@ -0,0 +1,47 @@ +(* TEST + * toplevel + * toplevel.opt +*) + +(* Various test-cases ensuring that the native and bytecode toplevels produce + the same output *) + +(* PR 10712 *) +module A : sig + type ('foo, 'bar) t + + val get_foo : ('foo, _) t -> 'foo option +end = struct + type ('foo, 'bar) t = + | Foo of 'foo + | Bar of 'bar + + let get_foo = function + | Foo foo -> Some foo + | Bar _ -> None +end +;; + +(* Type variables should be 'foo and 'a (name persists) *) +A.get_foo +;; + +(* Type variables be 'a and 'b (original names lost in let-binding) *) +let _bar = A.get_foo +;; + +(* PR 10849 *) +let _ : int = 42 +;; + +let (_ : bool) : bool = false +;; + +let List.(_) = "" +;; + +let List.(String.(_)) = 'd' +;; + +let List.(_) : float = 42.0 +;; diff --git a/ocaml/testsuite/tests/translprim/array_spec.compilers.no-flat.reference b/ocaml/testsuite/tests/translprim/array_spec.compilers.no-flat.reference index e839bbdb1a7..2411378fd23 100644 --- a/ocaml/testsuite/tests/translprim/array_spec.compilers.no-flat.reference +++ b/ocaml/testsuite/tests/translprim/array_spec.compilers.no-flat.reference @@ -1,20 +1,23 @@ (setglobal Array_spec! (let - (int_a = (makearray[int] 1 2 3) - float_a = (makearray[addr] 1. 2. 3.) - addr_a = (makearray[addr] "a" "b" "c")) + (int_a =[intarray] (makearray[int] 1 2 3) + float_a =[addrarray] (makearray[addr] 1. 2. 3.) + addr_a =[addrarray] (makearray[addr] "a" "b" "c")) (seq (array.length[int] int_a) (array.length[addr] float_a) - (array.length[addr] addr_a) (function a : int (array.length[addr] a)) + (array.length[addr] addr_a) + (function a[addrarray] : int (array.length[addr] a)) (array.get[int] int_a 0) (array.get[addr] float_a 0) - (array.get[addr] addr_a 0) (function a (array.get[addr] a 0)) + (array.get[addr] addr_a 0) + (function a[addrarray] (array.get[addr] a 0)) (array.unsafe_get[int] int_a 0) (array.unsafe_get[addr] float_a 0) (array.unsafe_get[addr] addr_a 0) - (function a (array.unsafe_get[addr] a 0)) (array.set[int] int_a 0 1) - (array.set[addr] float_a 0 1.) (array.set[addr] addr_a 0 "a") - (function a x (array.set[addr] a 0 x)) + (function a[addrarray] (array.unsafe_get[addr] a 0)) + (array.set[int] int_a 0 1) (array.set[addr] float_a 0 1.) + (array.set[addr] addr_a 0 "a") + (function a[addrarray] x : int (array.set[addr] a 0 x)) (array.unsafe_set[int] int_a 0 1) (array.unsafe_set[addr] float_a 0 1.) (array.unsafe_set[addr] addr_a 0 "a") - (function a x (array.unsafe_set[addr] a 0 x)) + (function a[addrarray] x : int (array.unsafe_set[addr] a 0 x)) (let (eta_gen_len = (function prim stub (array.length[addr] prim)) eta_gen_safe_get = diff --git a/ocaml/testsuite/tests/translprim/ref_spec.compilers.reference b/ocaml/testsuite/tests/translprim/ref_spec.compilers.reference index f0ebdecf0a2..311d4a4c3d4 100644 --- a/ocaml/testsuite/tests/translprim/ref_spec.compilers.reference +++ b/ocaml/testsuite/tests/translprim/ref_spec.compilers.reference @@ -1,7 +1,7 @@ (setglobal Ref_spec! (let (int_ref = (makemutable 0 (int) 1) - var_ref = (makemutable 0 65) + var_ref = (makemutable 0 (int) 65) vargen_ref = (makemutable 0 65) cst_ref = (makemutable 0 (int) 0) gen_ref = (makemutable 0 ([(consts (0)) (non_consts ([0: *]))]) 0) @@ -12,7 +12,7 @@ (setfield_ptr 0 gen_ref 0) (setfield_ptr 0 flt_ref 1.) (let (int_rec = (makemutable 0 (int,int) 0 1) - var_rec = (makemutable 0 (int,*) 0 65) + var_rec = (makemutable 0 (int,int) 0 65) vargen_rec = (makemutable 0 (int,*) 0 65) cst_rec = (makemutable 0 (int,int) 0 0) gen_rec = @@ -26,9 +26,9 @@ (setfield_ptr 1 flt_rec 1.) (setfloatfield 1 flt_rec' 1.) (let (set_open_poly = (function r y : int (setfield_ptr 0 r y)) - set_open_poly = (function r y : int (setfield_imm 0 r y)) - set_open_poly = (function r y : int (setfield_imm 0 r y)) - set_open_poly = (function r y : int (setfield_imm 0 r y)) + set_open_poly = (function r y[int] : int (setfield_imm 0 r y)) + set_open_poly = (function r y[int] : int (setfield_imm 0 r y)) + set_open_poly = (function r y[int] : int (setfield_imm 0 r y)) set_open_poly = (function r y : int (setfield_ptr 0 r y)) set_open_poly = (function r y : int (setfield_ptr 0 r y)) set_open_poly = (function r y : int (setfield_ptr 0 r y)) diff --git a/ocaml/testsuite/tests/translprim/sendcache.ml b/ocaml/testsuite/tests/translprim/sendcache.ml new file mode 100644 index 00000000000..0e49b4caaed --- /dev/null +++ b/ocaml/testsuite/tests/translprim/sendcache.ml @@ -0,0 +1,11 @@ +(* TEST *) + +(* Example from PR #10325. + This triggered a segfault in bytecode, but only if the code was not compiled + in debug mode (the offending code is actually in camlinternalOO.ml, and is + used only when optimising). + *) + +let x = object method g = "abc" end +let s = (object method f = x#g end)#f +let () = prerr_endline s diff --git a/ocaml/testsuite/tests/translprim/sendcache.reference b/ocaml/testsuite/tests/translprim/sendcache.reference new file mode 100644 index 00000000000..8baef1b4abc --- /dev/null +++ b/ocaml/testsuite/tests/translprim/sendcache.reference @@ -0,0 +1 @@ +abc diff --git a/ocaml/testsuite/tests/typing-core-bugs/type_expected_explanation.ml b/ocaml/testsuite/tests/typing-core-bugs/type_expected_explanation.ml index c51c95faf8b..fe9bc478ed9 100644 --- a/ocaml/testsuite/tests/typing-core-bugs/type_expected_explanation.ml +++ b/ocaml/testsuite/tests/typing-core-bugs/type_expected_explanation.ml @@ -172,7 +172,7 @@ Line 3, characters 22-26: ^^^^ Error: This variant expression is expected to have type unit because it is in the result of a conditional with no else branch - The constructor :: does not belong to type unit + There is no constructor :: within type unit |}];; (function @@ -196,5 +196,5 @@ Line 1, characters 35-39: ^^^^ Error: This variant expression is expected to have type unit because it is in the result of a conditional with no else branch - The constructor true does not belong to type unit + There is no constructor true within type unit |}] diff --git a/ocaml/testsuite/tests/typing-extensions/disambiguation.ml b/ocaml/testsuite/tests/typing-extensions/disambiguation.ml index 9b0a7c3af0a..6ce0acca72e 100644 --- a/ocaml/testsuite/tests/typing-extensions/disambiguation.ml +++ b/ocaml/testsuite/tests/typing-extensions/disambiguation.ml @@ -30,7 +30,7 @@ Line 1, characters 11-15: 1 | let x: t = Alph;; ^^^^ Error: This variant expression is expected to have type t - The constructor Alph does not belong to type t + There is no constructor Alph within type t Hint: Did you mean Aleph or Alpha? |}] @@ -41,7 +41,7 @@ Line 2, characters 12-16: 2 | let y : w = Alha;; ^^^^ Error: This variant expression is expected to have type M.w - The constructor Alha does not belong to type M.w + There is no constructor Alha within type M.w Hint: Did you mean Alpha? |}] @@ -51,7 +51,7 @@ Line 1, characters 11-14: 1 | let z: t = Bet;; ^^^ Error: This variant expression is expected to have type t - The constructor Bet does not belong to type t + There is no constructor Bet within type t Hint: Did you mean Beth? |}] @@ -65,7 +65,7 @@ Line 3, characters 9-13: 3 | let g = (Gamm:t);; ^^^^ Error: This variant expression is expected to have type t - The constructor Gamm does not belong to type t + There is no constructor Gamm within type t Hint: Did you mean Gamma? |}];; @@ -75,7 +75,7 @@ Line 1, characters 6-15: 1 | raise Not_Found;; ^^^^^^^^^ Error: This variant expression is expected to have type exn - The constructor Not_Found does not belong to type exn + There is no constructor Not_Found within type exn Hint: Did you mean Not_found? |}] @@ -156,7 +156,7 @@ Line 7, characters 13-17: 7 | let x: P.p = Alha;; ^^^^ Error: This variant expression is expected to have type P.p - The constructor Alha does not belong to type x + There is no constructor Alha within type x Hint: Did you mean Alpha? |}] @@ -170,7 +170,7 @@ Line 3, characters 13-14: 3 | let y: N.s = T ;; ^ Error: This variant expression is expected to have type N.s - The constructor T does not belong to type M.t + There is no constructor T within type M.t |}] (** Pattern matching *) @@ -197,7 +197,7 @@ Line 3, characters 8-12: 3 | raise Locl;; ^^^^ Error: This variant expression is expected to have type exn - The constructor Locl does not belong to type exn + There is no constructor Locl within type exn Hint: Did you mean Local? |}] diff --git a/ocaml/testsuite/tests/typing-extensions/extensions.ml b/ocaml/testsuite/tests/typing-extensions/extensions.ml index 259712b21b5..beea8d031c5 100644 --- a/ocaml/testsuite/tests/typing-extensions/extensions.ml +++ b/ocaml/testsuite/tests/typing-extensions/extensions.ml @@ -322,9 +322,9 @@ Error: Signature mismatch: type ('a, 'b) bar += A of int Constructors do not match: A of float - is not compatible with: + is not the same as: A of int - The types are not equal. + The type float is not equal to the type int |}] module M : sig @@ -348,9 +348,9 @@ Error: Signature mismatch: type ('a, 'b) bar += A of 'a Constructors do not match: A of 'b - is not compatible with: + is not the same as: A of 'a - The types are not equal. + The type 'b is not equal to the type 'a |}] module M : sig @@ -374,9 +374,9 @@ Error: Signature mismatch: type ('a, 'b) bar = A of 'a Constructors do not match: A of 'a - is not compatible with: + is not the same as: A of 'a - The types are not equal. + The type 'a is not equal to the type 'b |}];; @@ -401,9 +401,9 @@ Error: Signature mismatch: type ('a, 'b) bar += A : 'c -> ('c, 'd) bar Constructors do not match: A : 'd -> ('c, 'd) bar - is not compatible with: + is not the same as: A : 'c -> ('c, 'd) bar - The types are not equal. + The type 'd is not equal to the type 'c |}] (* Extensions can be rebound *) diff --git a/ocaml/testsuite/tests/typing-extensions/open_types.ml b/ocaml/testsuite/tests/typing-extensions/open_types.ml index 210254418b8..eda342d2bfa 100644 --- a/ocaml/testsuite/tests/typing-extensions/open_types.ml +++ b/ocaml/testsuite/tests/typing-extensions/open_types.ml @@ -117,7 +117,8 @@ Line 1, characters 0-37: ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This variant or record definition does not match that of type ('a, 'a) foo - Their constraints differ. + Their parameters differ + The type 'a is not equal to the type 'b |}] (* Check that signatures can hide exstensibility *) @@ -236,7 +237,7 @@ Error: Signature mismatch: type foo = M.foo = private .. is not included in type foo = .. - A private type would be revealed. + A private extensible variant would be revealed. |}] diff --git a/ocaml/testsuite/tests/typing-external/pr11392.ml b/ocaml/testsuite/tests/typing-external/pr11392.ml new file mode 100644 index 00000000000..91c8ea77eb7 --- /dev/null +++ b/ocaml/testsuite/tests/typing-external/pr11392.ml @@ -0,0 +1,34 @@ +(* TEST + * expect +*) + +type 'self nat = + | Z + | S of 'self +;; +[%%expect{| +type 'self nat = Z | S of 'self +|}] + + + +(* without rectypes: rejected *) +external cast : int -> 'self nat as 'self = "%identity" +;; +[%%expect{| +Line 1, characters 16-41: +1 | external cast : int -> 'self nat as 'self = "%identity" + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This alias is bound to type int -> 'a nat + but is used as an instance of type 'a + The type variable 'a occurs inside int -> 'a nat +|}] + +#rectypes;; + +(* with rectypes: accepted (used to crash) *) +external cast : int -> 'self nat as 'self = "%identity" +;; +[%%expect{| +external cast : int -> 'a nat as 'a = "%identity" +|}] diff --git a/ocaml/testsuite/tests/typing-fstclassmod/fstclassmod.ml b/ocaml/testsuite/tests/typing-fstclassmod/fstclassmod.ml index 9be5399277a..3330f957d80 100644 --- a/ocaml/testsuite/tests/typing-fstclassmod/fstclassmod.ml +++ b/ocaml/testsuite/tests/typing-fstclassmod/fstclassmod.ml @@ -1,5 +1,5 @@ (* TEST - flags = "-w A -warn-error A" + flags = "-w +A-70 -warn-error +A" *) (* Example of algorithm parametrized with modules *) diff --git a/ocaml/testsuite/tests/typing-gadts/ambiguity.ml b/ocaml/testsuite/tests/typing-gadts/ambiguity.ml index d43f33841a4..2c0d5a46313 100644 --- a/ocaml/testsuite/tests/typing-gadts/ambiguity.ml +++ b/ocaml/testsuite/tests/typing-gadts/ambiguity.ml @@ -233,6 +233,10 @@ Error: Signature mismatch: val r : '_weak1 list ref is not included in val r : T.u list ref + The type '_weak1 list ref is not compatible with the type T.u list ref + Type '_weak1 is not compatible with type T.u = T.t + This instance of T.t is ambiguous: + it would escape the scope of its equation |}] module M = struct @@ -264,4 +268,8 @@ Error: Signature mismatch: val r : '_weak2 list ref is not included in val r : T.t list ref + The type '_weak2 list ref is not compatible with the type T.t list ref + Type '_weak2 is not compatible with type T.t = T.u + This instance of T.u is ambiguous: + it would escape the scope of its equation |}] diff --git a/ocaml/testsuite/tests/typing-gadts/ambivalent_apply.ml b/ocaml/testsuite/tests/typing-gadts/ambivalent_apply.ml new file mode 100644 index 00000000000..e334db0da7d --- /dev/null +++ b/ocaml/testsuite/tests/typing-gadts/ambivalent_apply.ml @@ -0,0 +1,40 @@ +(* TEST + * expect +*) + +type (_,_) eq = Refl : ('a,'a) eq;; +[%%expect{| +type (_, _) eq = Refl : ('a, 'a) eq +|}] + +(* Both should fail *) +let f (type a b) (w1 : (a, b -> b) eq) (w2 : (a, int -> int) eq) (g : a) = + let Refl = w1 in let Refl = w2 in g 3;; +[%%expect{| +Line 2, characters 37-40: +2 | let Refl = w1 in let Refl = w2 in g 3;; + ^^^ +Error: This expression has type b = int + but an expression was expected of type 'a + This instance of int is ambiguous: + it would escape the scope of its equation +|}] +let f (type a b) (w1 : (a, b -> b) eq) (w2 : (a, int -> int) eq) (g : a) = + let Refl = w2 in let Refl = w1 in g 3;; +[%%expect{| +val f : ('a, 'b -> 'b) eq -> ('a, int -> int) eq -> 'a -> int = +|}, Principal{| +Line 2, characters 37-40: +2 | let Refl = w2 in let Refl = w1 in g 3;; + ^^^ +Error: This expression has type int but an expression was expected of type 'a + This instance of int is ambiguous: + it would escape the scope of its equation +|}] + +(* Ok *) +let f (type a b) (w1 : (a, b -> b) eq) (w2 : (a, int -> int) eq) (g : a) : b = + let Refl = w2 in let Refl = w1 in g 3;; +[%%expect{| +val f : ('a, 'b -> 'b) eq -> ('a, int -> int) eq -> 'a -> 'b = +|}] diff --git a/ocaml/testsuite/tests/typing-gadts/gadthead.ml b/ocaml/testsuite/tests/typing-gadts/gadthead.ml new file mode 100644 index 00000000000..57a0f04d824 --- /dev/null +++ b/ocaml/testsuite/tests/typing-gadts/gadthead.ml @@ -0,0 +1,30 @@ +(* TEST + * expect +*) + +module M : sig + type t + val x : t + val print : t -> unit +end = struct + type t = string + let x = "hello" + let print = print_endline +end + +type _ g = I : int g +[%%expect{| +module M : sig type t val x : t val print : t -> unit end +type _ g = I : int g +|}] + +let g (x : M.t) = + match x with I -> M.print I +let () = g M.x +[%%expect{| +Line 2, characters 15-16: +2 | match x with I -> M.print I + ^ +Error: This pattern matches values of type 'a g + but a pattern was expected which matches values of type M.t +|}] diff --git a/ocaml/testsuite/tests/typing-gadts/name_existentials.ml b/ocaml/testsuite/tests/typing-gadts/name_existentials.ml new file mode 100644 index 00000000000..91b2f5bb1d3 --- /dev/null +++ b/ocaml/testsuite/tests/typing-gadts/name_existentials.ml @@ -0,0 +1,119 @@ +(* TEST + * expect +*) + +type _ ty = Int : int ty +type dyn = Dyn : 'a ty * 'a -> dyn +[%%expect{| +type _ ty = Int : int ty +type dyn = Dyn : 'a ty * 'a -> dyn +|}] + +let ok1 = function Dyn (type a) (w, x : a ty * a) -> ignore (x : a) +let ok2 = function Dyn (type a) (w, x : _ * a) -> ignore (x : a) +[%%expect{| +val ok1 : dyn -> unit = +val ok2 : dyn -> unit = +|}] + +let ko1 = function Dyn (type a) (w, x) -> () +[%%expect{| +Line 1, characters 32-38: +1 | let ko1 = function Dyn (type a) (w, x) -> () + ^^^^^^ +Error: Existential types introduced in a constructor pattern + must be bound by a type constraint on the argument. +|}] +let ko1 = function Dyn (type a) (w, x : _) -> () +[%%expect{| +Line 1, characters 40-41: +1 | let ko1 = function Dyn (type a) (w, x : _) -> () + ^ +Error: This type does not bind all existentials in the constructor: + type a. 'a ty * 'a +|}] +let ko2 = function Dyn (type a b) (a, x : a ty * b) -> ignore (x : b) +[%%expect{| +Line 1, characters 42-50: +1 | let ko2 = function Dyn (type a b) (a, x : a ty * b) -> ignore (x : b) + ^^^^^^^^ +Error: This pattern matches values of type a ty * b + but a pattern was expected which matches values of type a ty * a + Type b is not compatible with type a +|}] + +type u = C : 'a * ('a -> 'b list) -> u +let f = function C (type a b) (x, f : _ * (a -> b list)) -> ignore (x : a) +[%%expect{| +type u = C : 'a * ('a -> 'b list) -> u +val f : u -> unit = +|}] + +let f = function C (type a) (x, f : a * (a -> a list)) -> ignore (x : a) +[%%expect{| +Line 1, characters 36-53: +1 | let f = function C (type a) (x, f : a * (a -> a list)) -> ignore (x : a) + ^^^^^^^^^^^^^^^^^ +Error: This type does not bind all existentials in the constructor: + type a. a * (a -> a list) +|}] + +(* with GADT unification *) +type _ expr = + | Int : int -> int expr + | Add : (int -> int -> int) expr + | App : ('a -> 'b) expr * 'a expr -> 'b expr + +let rec eval : type t. t expr -> t = function + Int n -> n + | Add -> (+) + | App (type a) (f, x : _ * a expr) -> eval f (eval x : a) +[%%expect{| +type _ expr = + Int : int -> int expr + | Add : (int -> int -> int) expr + | App : ('a -> 'b) expr * 'a expr -> 'b expr +val eval : 't expr -> 't = +|}] + +let rec test : type a. a expr -> a = function + | Int (type b) (n : a) -> n + | Add -> (+) + | App (type b) (f, x : (b -> a) expr * _) -> test f (test x : b) +[%%expect{| +Line 2, characters 22-23: +2 | | Int (type b) (n : a) -> n + ^ +Error: This type does not bind all existentials in the constructor: type b. a +|}] + +(* Strange wildcard *) + +[@@@warning "-28"] +let () = + match None with + | None (type a) (_ : a * int) -> () + | Some _ -> () +[%%expect{| +Line 4, characters 4-31: +4 | | None (type a) (_ : a * int) -> () + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The constructor None expects 0 argument(s), + but is applied here to 1 argument(s) +|}] + +let () = + match None with + | None _ -> () + | Some _ -> () +[%%expect{| +|}] + +(* Also allow annotations on multiary constructors *) +type ('a,'b) pair = Pair of 'a * 'b + +let f = function Pair (x, y : int * _) -> x + y +[%%expect{| +type ('a, 'b) pair = Pair of 'a * 'b +val f : (int, int) pair -> int = +|}] diff --git a/ocaml/testsuite/tests/typing-gadts/omega07.ml b/ocaml/testsuite/tests/typing-gadts/omega07.ml index a8a78b17f1d..a8e63880355 100644 --- a/ocaml/testsuite/tests/typing-gadts/omega07.ml +++ b/ocaml/testsuite/tests/typing-gadts/omega07.ml @@ -904,9 +904,9 @@ val suc : (('a, 'b, (suc, int -> int, 'c) rcons) rcons, int) lam = val _1 : ((zero, int, (suc, int -> int, '_weak1) rcons) rcons, int) lam = App (Shift (Var Suc), Var Zero) -val _2 : ((zero, int, (suc, int -> int, '_weak2) rcons) rcons, int) lam = +val _2 : ((zero, int, (suc, int -> int, '_weak1) rcons) rcons, int) lam = App (Shift (Var Suc), App (Shift (Var Suc), Var Zero)) -val _3 : ((zero, int, (suc, int -> int, '_weak3) rcons) rcons, int) lam = +val _3 : ((zero, int, (suc, int -> int, '_weak1) rcons) rcons, int) lam = App (Shift (Var Suc), App (Shift (Var Suc), App (Shift (Var Suc), Var Zero))) val add : @@ -921,7 +921,7 @@ val double : App (App (Shift (Shift (Shift (Var Add))), Var ), Var )) val ex3 : ((zero, int, - (suc, int -> int, (add, int -> int -> int, '_weak4) rcons) rcons) + (suc, int -> int, (add, int -> int -> int, '_weak2) rcons) rcons) rcons, int) lam = App diff --git a/ocaml/testsuite/tests/typing-gadts/pr10189.ml b/ocaml/testsuite/tests/typing-gadts/pr10189.ml new file mode 100644 index 00000000000..b4c11b7acf3 --- /dev/null +++ b/ocaml/testsuite/tests/typing-gadts/pr10189.ml @@ -0,0 +1,173 @@ +(* TEST + * expect +*) + +type i = 'c > +type ('a, 'b) j = 'b > +type _ t = A : i t;; +[%%expect{| +type i = < m : 'c. 'c -> 'c > +type ('a, 'b) j = < m : 'a -> 'b > +type _ t = A : i t +|}] + +let f (type a b) (y : (a, b) j t) : a -> b = + let A = y in fun x -> x;; +[%%expect{| +Line 2, characters 6-7: +2 | let A = y in fun x -> x;; + ^ +Error: This pattern matches values of type i t + but a pattern was expected which matches values of type (a, b) j t + Type i = < m : 'c. 'c -> 'c > is not compatible with type + (a, b) j = < m : a -> b > + The method m has type 'c. 'c -> 'c, but the expected method type was + a -> b + The universal variable 'c would escape its scope +|}] + +let g (type a b) (y : (a,b) j t option) = + let None = y in () ;; +[%%expect{| +val g : ('a, 'b) j t option -> unit = +|}] + +module M = struct + type 'a d = D + type j = 'c d > +end ;; +let g (y : M.j t option) = + let None = y in () ;; +[%%expect{| +module M : sig type 'a d = D type j = < m : 'c. 'c -> 'c d > end +val g : M.j t option -> unit = +|}] + +module M = struct + type 'a d + type j = 'c d > +end ;; +let g (y : M.j t option) = + let None = y in () ;; +[%%expect{| +module M : sig type 'a d type j = < m : 'c. 'c -> 'c d > end +Line 6, characters 2-20: +6 | let None = y in () ;; + ^^^^^^^^^^^^^^^^^^ +Warning 8 [partial-match]: this pattern-matching is not exhaustive. +Here is an example of a case that is not matched: +Some A +val g : M.j t option -> unit = +|}] + +module M = struct + type e + type 'a d + type i = 'c d > + type j = e > +end ;; +type _ t = A : M.i t +let g (y : M.j t option) = + let None = y in () ;; +[%%expect{| +module M : + sig + type e + type 'a d + type i = < m : 'c. 'c -> 'c d > + type j = < m : 'c. 'c -> e > + end +type _ t = A : M.i t +Line 9, characters 2-20: +9 | let None = y in () ;; + ^^^^^^^^^^^^^^^^^^ +Warning 8 [partial-match]: this pattern-matching is not exhaustive. +Here is an example of a case that is not matched: +Some A +val g : M.j t option -> unit = +|}] + +module M = struct + type 'a d + type i = 'c d > + type 'a j = 'a > +end ;; +type _ t = A : M.i t +(* Should warn *) +let g (y : 'a M.j t option) = + let None = y in () ;; +[%%expect{| +module M : + sig + type 'a d + type i = < m : 'c. 'c -> 'c d > + type 'a j = < m : 'c. 'c -> 'a > + end +type _ t = A : M.i t +Line 9, characters 2-20: +9 | let None = y in () ;; + ^^^^^^^^^^^^^^^^^^ +Warning 8 [partial-match]: this pattern-matching is not exhaustive. +Here is an example of a case that is not matched: +Some A +val g : 'a M.j t option -> unit = +|}] + +(* more examples by @lpw25 *) +module M = struct + type a + type i = C of 'c > + type j = C of a > +end +type _ t = A : M.i t;; +let f (y : M.j t) = match y with _ -> .;; +[%%expect{| +module M : + sig + type a + type i = C of < m : 'c. 'c -> 'c > + type j = C of < m : 'c. 'c -> a > + end +type _ t = A : M.i t +val f : M.j t -> 'a = +|}] + +module M = struct + type a + type i = C of 'c -> 'c > + type j = C of a > +end +type _ t = A : M.i t;; +let f (y : M.j t) = match y with _ -> .;; +[%%expect{| +module M : + sig + type a + type i = C of < m : 'c. 'c -> 'c -> 'c > + type j = C of < m : 'c. 'c -> a > + end +type _ t = A : M.i t +val f : M.j t -> 'a = +|}] + +module M = struct + type 'a a + type i = C of 'c -> 'c > + type j = C of 'c a > +end +type _ t = A : M.i t;; +let f (y : M.j t) = match y with _ -> .;; +[%%expect{| +module M : + sig + type 'a a + type i = C of < m : 'c. 'c -> 'c -> 'c > + type j = C of < m : 'c. 'c -> 'c a > + end +type _ t = A : M.i t +Line 7, characters 33-34: +7 | let f (y : M.j t) = match y with _ -> .;; + ^ +Error: This match case could not be refuted. + Here is an example of a value that would reach it: A +|}] diff --git a/ocaml/testsuite/tests/typing-gadts/pr10271.ml b/ocaml/testsuite/tests/typing-gadts/pr10271.ml new file mode 100644 index 00000000000..37b6bdbc620 --- /dev/null +++ b/ocaml/testsuite/tests/typing-gadts/pr10271.ml @@ -0,0 +1,38 @@ +(* TEST + * expect +*) + +module M = struct + type _ rr = Soa : int rr + type b = B : 'a rr * 'a -> b +end + +let test = + let M.(B (k, v)) = M.(B (Soa, 0)) in + match k, v with + | M.Soa, soa -> (soa : int) +[%%expect{| +module M : sig type _ rr = Soa : int rr type b = B : 'a rr * 'a -> b end +val test : int = 0 +|}] + +let test = + let open M in + let B (k, v) = B (Soa, 0) in + match k, v with + | Soa, soa -> (soa : int) +[%%expect{| +val test : int = 0 +|}] + +type _ ty = Int : int ty +type dyn = Dyn : 'a ty * 'a -> dyn +[%%expect{| +type _ ty = Int : int ty +type dyn = Dyn : 'a ty * 'a -> dyn +|}] + +let f String.(Dyn (type a) (w, x : a ty * a)) = ignore (x : a) +[%%expect{| +val f : dyn -> unit = +|}] diff --git a/ocaml/testsuite/tests/typing-gadts/pr10735.ml b/ocaml/testsuite/tests/typing-gadts/pr10735.ml new file mode 100644 index 00000000000..5405670b11e --- /dev/null +++ b/ocaml/testsuite/tests/typing-gadts/pr10735.ml @@ -0,0 +1,30 @@ +(* TEST + * expect +*) + +module X : sig + type 'a t +end = struct + type 'a t +end + +type 'a t + +type (_,_) eq = Refl : ('a,'a) eq +[%%expect{| +module X : sig type 'a t end +type 'a t +type (_, _) eq = Refl : ('a, 'a) eq +|}] + +let () = + let (Refl : (bool X.t, bool t) eq) as t = Obj.magic () in () +[%%expect{| +Line 2, characters 7-11: +2 | let (Refl : (bool X.t, bool t) eq) as t = Obj.magic () in () + ^^^^ +Error: This pattern matches values of type (bool X.t, bool X.t) eq + but a pattern was expected which matches values of type + (bool X.t, bool t) eq + Type bool X.t is not compatible with type bool t +|}] diff --git a/ocaml/testsuite/tests/typing-gadts/pr10907.ml b/ocaml/testsuite/tests/typing-gadts/pr10907.ml new file mode 100644 index 00000000000..abd431f2657 --- /dev/null +++ b/ocaml/testsuite/tests/typing-gadts/pr10907.ml @@ -0,0 +1,53 @@ +(* TEST + * expect +*) + +(* from @dyzsr *) +type 'a t = T : ('a -> 'b) * ('b -> 'a) -> 'a t;; +[%%expect{| +type 'a t = T : ('a -> 'b) * ('b -> 'a) -> 'a t +|}] + +let t = T ((fun x -> x), (fun x -> x));; +[%%expect{| +val t : 'a t = T (, ) +|}] + +let t1 = let T (g, h) = t in h (g 1);; +[%%expect{| +val t1 : int = 1 +|}] + +let f x = let T (g, h) = t in h (g x);; +[%%expect{| +val f : 'a -> 'a = +|}] + +(* reformulation by @gasche *) + +(* an isomorphism between 'a and 'b *) +type ('a, 'b) iso = ('a -> 'b) * ('b -> 'a) + +(* exists 'b. ('a, 'b) iso *) +type 'a some_iso = Iso : ('a, 'b) iso -> 'a some_iso +[%%expect{| +type ('a, 'b) iso = ('a -> 'b) * ('b -> 'a) +type 'a some_iso = Iso : ('a, 'b) iso -> 'a some_iso +|}] + +(* forall 'a. exists 'b. ('a, 'b) iso *) +let t : 'a . 'a some_iso = + Iso ((fun x -> x), (fun x -> x)) +[%%expect{| +val t : 'a some_iso = Iso (, ) +|}] + +let unsound_cast : 'a 'b. 'a -> 'b = fun x -> + match t with Iso (g, h) -> h (g x) +[%%expect{| +Lines 1-2, characters 37-36: +1 | .....................................fun x -> +2 | match t with Iso (g, h) -> h (g x) +Error: This definition has type 'c. 'c -> 'c which is less general than + 'a 'b. 'a -> 'b +|}] diff --git a/ocaml/testsuite/tests/typing-gadts/pr5689.ml b/ocaml/testsuite/tests/typing-gadts/pr5689.ml index acbb195c2fb..f61d80af8e5 100644 --- a/ocaml/testsuite/tests/typing-gadts/pr5689.ml +++ b/ocaml/testsuite/tests/typing-gadts/pr5689.ml @@ -103,10 +103,10 @@ type _ linkp2 = Kind : 'a linkp -> ([< inkind ] as 'a) linkp2 Line 7, characters 35-43: 7 | | (Kind _, Ast_Text txt) -> Text txt ^^^^^^^^ -Error: This expression has type ([< inkind > `Nonlink ] as 'a) inline_t +Error: This expression has type [< inkind > `Nonlink ] inline_t but an expression was expected of type a inline_t - Type 'a = [< `Link | `Nonlink > `Nonlink ] is not compatible with type - a = [< `Link | `Nonlink ] + Type [< inkind > `Nonlink ] = [< `Link | `Nonlink > `Nonlink ] + is not compatible with type a = [< `Link | `Nonlink ] The second variant type is bound to $'a, it may not allow the tag(s) `Nonlink |}];; diff --git a/ocaml/testsuite/tests/typing-gadts/pr5948.ml b/ocaml/testsuite/tests/typing-gadts/pr5948.ml index 29547ea6f9f..9581adc3c61 100644 --- a/ocaml/testsuite/tests/typing-gadts/pr5948.ml +++ b/ocaml/testsuite/tests/typing-gadts/pr5948.ml @@ -42,9 +42,9 @@ type _ wrapPoly = Line 25, characters 23-27: 25 | | WrapPoly ATag -> intA ^^^^ -Error: This expression has type ([< `TagA of 'b ] as 'a) -> 'b +Error: This expression has type [< `TagA of 'a ] -> 'a but an expression was expected of type a -> int - Type [< `TagA of 'b ] as 'a is not compatible with type + Type [< `TagA of 'a ] is not compatible with type a = [< `TagA of int | `TagB ] The first variant type does not allow tag(s) `TagB |}];; diff --git a/ocaml/testsuite/tests/typing-gadts/pr6980.ml b/ocaml/testsuite/tests/typing-gadts/pr6980.ml index 75a302e35de..191443240e6 100644 --- a/ocaml/testsuite/tests/typing-gadts/pr6980.ml +++ b/ocaml/testsuite/tests/typing-gadts/pr6980.ml @@ -17,7 +17,7 @@ let g (Aux(Second, f)) = f it;; [%%expect{| type 'a t = 'a constraint 'a = [< `Bar | `Foo ] type 'a s = 'a constraint 'a = [< `Bar | `Baz | `Foo > `Bar ] -type 'a first = First : 'b t second -> ([< `Bar | `Foo ] as 'b) t first +type 'a first = First : 'a t second -> ([< `Bar | `Foo ] as 'a) t first and 'a second = Second : [< `Bar | `Baz | `Foo > `Bar ] s second type aux = Aux : ([< `Bar | `Foo ] as 'a) t second * ('a -> int) -> aux val it : [< `Bar | `Foo > `Bar ] = `Bar @@ -26,6 +26,6 @@ Line 11, characters 27-29: ^^ Error: This expression has type [< `Bar | `Foo > `Bar ] but an expression was expected of type [< `Bar | `Foo ] - The second variant type is bound to $Aux, + The second variant type is bound to $Aux_'a, it may not allow the tag(s) `Bar |}];; diff --git a/ocaml/testsuite/tests/typing-gadts/pr7160.ml b/ocaml/testsuite/tests/typing-gadts/pr7160.ml index a615a462821..5a613052b80 100644 --- a/ocaml/testsuite/tests/typing-gadts/pr7160.ml +++ b/ocaml/testsuite/tests/typing-gadts/pr7160.ml @@ -20,7 +20,8 @@ Lines 4-5, characters 0-77: Error: This variant or record definition does not match that of type 'a t Constructors do not match: Same : 'l t -> 'l t - is not compatible with: + is not the same as: Same : 'l1 t -> 'l2 t - The types are not equal. + The type 'l t is not equal to the type 'l1 t + Type 'l is not equal to type 'l1 |}];; diff --git a/ocaml/testsuite/tests/typing-gadts/pr7260.ml b/ocaml/testsuite/tests/typing-gadts/pr7260.ml index 87e7d30e1e6..2685e3b23b3 100644 --- a/ocaml/testsuite/tests/typing-gadts/pr7260.ml +++ b/ocaml/testsuite/tests/typing-gadts/pr7260.ml @@ -19,13 +19,12 @@ class foo = type bar = < bar : unit > type _ ty = Int : int ty type dyn = Dyn : 'a ty -> dyn -Lines 7-12, characters 0-5: - 7 | class foo = - 8 | object (this) +Lines 8-12, characters 2-5: + 8 | ..object (this) 9 | method foo (Dyn ty) = 10 | match ty with 11 | | Int -> (this :> bar) 12 | end................................. -Error: This class should be virtual. - The following methods are undefined : bar +Error: This non-virtual class has undeclared virtual methods. + The following methods were not declared : bar |}];; diff --git a/ocaml/testsuite/tests/typing-gadts/pr7378.ml b/ocaml/testsuite/tests/typing-gadts/pr7378.ml index 9252b43ddbc..fe771d8d0ad 100644 --- a/ocaml/testsuite/tests/typing-gadts/pr7378.ml +++ b/ocaml/testsuite/tests/typing-gadts/pr7378.ml @@ -21,9 +21,10 @@ Lines 2-3, characters 2-37: Error: This variant or record definition does not match that of type X.t Constructors do not match: A : 'a * 'b * ('a -> unit) -> X.t - is not compatible with: + is not the same as: A : 'a * 'b * ('b -> unit) -> X.t - The types are not equal. + The type 'a -> unit is not equal to the type 'b -> unit + Type 'a is not equal to type 'b |}] (* would segfault diff --git a/ocaml/testsuite/tests/typing-gadts/pr7391.ml b/ocaml/testsuite/tests/typing-gadts/pr7391.ml index f5ffc205f53..f16654c5a03 100644 --- a/ocaml/testsuite/tests/typing-gadts/pr7391.ml +++ b/ocaml/testsuite/tests/typing-gadts/pr7391.ml @@ -29,7 +29,7 @@ class virtual child2 : object ('a) method private virtual parent : < previous : 'a option; .. > end -- : < child : child2; previous : child2 option > = +- : < child : child1; previous : child1 option > = |}] (* Worked in 4.03 *) @@ -43,7 +43,7 @@ let _ = end end;; [%%expect{| -- : < child : unit -> child2; previous : child2 option > = +- : < child : unit -> child1; previous : child1 option > = |}] (* Worked in 4.03 *) @@ -57,7 +57,7 @@ let _ = end end;; [%%expect{| -- : < child : unit -> child2; previous : child2 option > = +- : < child : unit -> child1; previous : child1 option > = |}] (* Didn't work in 4.03, but works in 4.07 *) @@ -73,7 +73,7 @@ let _ = in o end;; [%%expect{| -- : < child : child2; previous : child2 option > = +- : < child : child1; previous : child1 option > = |}] (* Also didn't work in 4.03 *) @@ -91,5 +91,5 @@ let _ = end;; [%%expect{| type gadt = Not_really_though : gadt -- : < child : gadt -> child2; previous : child2 option > = +- : < child : gadt -> child1; previous : child1 option > = |}] diff --git a/ocaml/testsuite/tests/typing-gadts/principality-and-gadts.ml b/ocaml/testsuite/tests/typing-gadts/principality-and-gadts.ml index 65db66e2677..e4236f32e50 100644 --- a/ocaml/testsuite/tests/typing-gadts/principality-and-gadts.ml +++ b/ocaml/testsuite/tests/typing-gadts/principality-and-gadts.ml @@ -440,3 +440,19 @@ let bar x = [%%expect{| val bar : string foo -> string = |}] + +(* #10822 *) +type t +type u = private t +type ('a, 'b) eq = Refl : ('a, 'a) eq +[%%expect{| +type t +type u = private t +type ('a, 'b) eq = Refl : ('a, 'a) eq +|}] + +let foo (type s) x (Refl : (s, u) eq) = + (x : s :> t) +[%%expect{| +val foo : 's -> ('s, u) eq -> t = +|}] diff --git a/ocaml/testsuite/tests/typing-gadts/return_type.ml b/ocaml/testsuite/tests/typing-gadts/return_type.ml new file mode 100644 index 00000000000..ebd5340a699 --- /dev/null +++ b/ocaml/testsuite/tests/typing-gadts/return_type.ml @@ -0,0 +1,36 @@ +(* TEST + * expect +*) + +type i = int + +type 'a t = T : i +[%%expect{| +type i = int +Line 3, characters 16-17: +3 | type 'a t = T : i + ^ +Error: Constraints are not satisfied in this type. + Type i should be an instance of 'a t +|}] + +type 'a t = T : i t +type 'a s = 'a t = T : i t +[%%expect{| +type 'a t = T : i t +Line 2, characters 23-26: +2 | type 'a s = 'a t = T : i t + ^^^ +Error: Constraints are not satisfied in this type. + Type i t should be an instance of 'a s +|}] + +type 'a t = T : i s +and 'a s = 'a t +[%%expect{| +Line 1, characters 16-19: +1 | type 'a t = T : i s + ^^^ +Error: Constraints are not satisfied in this type. + Type i s should be an instance of 'a t +|}] diff --git a/ocaml/testsuite/tests/typing-gadts/test.ml b/ocaml/testsuite/tests/typing-gadts/test.ml index d210724ac34..67e8d3bb7ad 100644 --- a/ocaml/testsuite/tests/typing-gadts/test.ml +++ b/ocaml/testsuite/tests/typing-gadts/test.ml @@ -384,7 +384,7 @@ Line 5, characters 28-29: 5 | let f = function A -> 1 | B -> 2 ^ Error: This variant pattern is expected to have type a - The constructor B does not belong to type a + There is no constructor B within type a |}];; module PR6849 = struct @@ -1089,6 +1089,14 @@ Line 3, characters 2-26: Error: This expression has type < bar : int; foo : int; .. > but an expression was expected of type 'a The type constructor $1 would escape its scope +|}, Principal{| +Line 3, characters 2-26: +3 | (x:) + ^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type < bar : int; foo : int; .. > + but an expression was expected of type 'a + This instance of $1 is ambiguous: + it would escape the scope of its equation |}];; let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) : t = @@ -1105,6 +1113,13 @@ let g (type t) (x:t) (e : t int_foo) (e' : t int_bar) = ;; [%%expect{| val g : 't -> 't int_foo -> 't int_bar -> 't * int * int = +|}, Principal{| +Line 3, characters 5-10: +3 | x, x#foo, x#bar + ^^^^^ +Error: This expression has type int but an expression was expected of type 'a + This instance of int is ambiguous: + it would escape the scope of its equation |}];; (* PR#5554 *) @@ -1224,3 +1239,136 @@ Error: This expression has type a = int This instance of int is ambiguous: it would escape the scope of its equation |}];; + +module M = struct + type t +end +type (_,_) eq = Refl: ('a,'a) eq +let f (x:M.t) (y: (M.t, int -> int) eq) = + let Refl = y in + if true then x else fun x -> x + 1 +[%%expect{| +module M : sig type t end +type (_, _) eq = Refl : ('a, 'a) eq +Line 7, characters 22-36: +7 | if true then x else fun x -> x + 1 + ^^^^^^^^^^^^^^ +Error: This expression has type 'a -> 'b + but an expression was expected of type M.t = int -> int + This instance of int -> int is ambiguous: + it would escape the scope of its equation +|}] + +(* Check got/expected when the order changes *) +module M = struct + type t +end +type (_,_) eq = Refl: ('a,'a) eq +let f (x:M.t) (y: (M.t, int -> int) eq) = + let Refl = y in + if true then fun x -> x + 1 else x +[%%expect{| +module M : sig type t end +type (_, _) eq = Refl : ('a, 'a) eq +Line 7, characters 35-36: +7 | if true then fun x -> x + 1 else x + ^ +Error: This expression has type M.t = int -> int + but an expression was expected of type int -> int + This instance of int -> int is ambiguous: + it would escape the scope of its equation +|}] + +module M = struct + type t +end +type (_,_) eq = Refl: ('a,'a) eq +let f w (x:M.t) (y: (M.t, ) eq) = + let Refl = y in + let z = if true then x else w in + z#m +[%%expect{| +module M : sig type t end +type (_, _) eq = Refl : ('a, 'a) eq +Line 8, characters 2-3: +8 | z#m + ^ +Error: This expression has type M.t but an expression was expected of type + < m : 'a; .. > + This instance of < m : int > is ambiguous: + it would escape the scope of its equation +|}] + +(* Check got/expected when the order changes *) +module M = struct + type t +end +type (_,_) eq = Refl: ('a,'a) eq +let f w (x:M.t) (y: (M.t, ) eq) = + let Refl = y in + let z = if true then w else x in + z#m +[%%expect{| +module M : sig type t end +type (_, _) eq = Refl : ('a, 'a) eq +Line 8, characters 2-3: +8 | z#m + ^ +Error: This expression has type M.t but an expression was expected of type + < m : 'a; .. > + This instance of < m : int > is ambiguous: + it would escape the scope of its equation +|}] + +type (_,_) eq = Refl: ('a,'a) eq +module M = struct + type t = C : ( as 'a) * ('a, ) eq -> t +end +let f (C (x,y) : M.t) = + let g w = + let Refl = y in + let z = if true then w else x in + z#b + in () +[%%expect{| +type (_, _) eq = Refl : ('a, 'a) eq +module M : + sig + type t = + C : (< m : int; .. > as 'a) * ('a, < b : bool; m : int >) eq -> t + end +Line 9, characters 4-5: +9 | z#b + ^ +Error: This expression has type $C_'a = < b : bool > + but an expression was expected of type < b : 'a; .. > + This instance of < b : bool > is ambiguous: + it would escape the scope of its equation +|}] + +(* Check got/expected when the order changes *) +type (_,_) eq = Refl: ('a,'a) eq +module M = struct + type t = C : ( as 'a) * ('a, ) eq -> t +end +let f (C (x,y) : M.t) = + let g w = + let Refl = y in + let z = if true then x else w in + z#b + in () +[%%expect{| +type (_, _) eq = Refl : ('a, 'a) eq +module M : + sig + type t = + C : (< m : int; .. > as 'a) * ('a, < b : bool; m : int >) eq -> t + end +Line 9, characters 4-5: +9 | z#b + ^ +Error: This expression has type $C_'a = < b : bool > + but an expression was expected of type < b : 'a; .. > + This instance of < b : bool > is ambiguous: + it would escape the scope of its equation +|}] diff --git a/ocaml/testsuite/tests/typing-local/crossing.ml b/ocaml/testsuite/tests/typing-local/crossing.ml new file mode 100644 index 00000000000..c3c77a7429d --- /dev/null +++ b/ocaml/testsuite/tests/typing-local/crossing.ml @@ -0,0 +1,346 @@ +(* TEST + * expect *) + +type ('a, 'b) bar0 = Bar0 of 'a * 'b +type bar = (int, string) bar0 + +type ('a, 'b) foo0 = { + x : 'a; + y : 'b; +} +type foo = (int, string) foo0 +[%%expect{| +type ('a, 'b) bar0 = Bar0 of 'a * 'b +type bar = (int, string) bar0 +type ('a, 'b) foo0 = { x : 'a; y : 'b; } +type foo = (int, string) foo0 +|}] + +(* mode crosing is implemented at several points + in the type checker corresponding to the + following tests *) + +(* We are very stingy in the following when giving + type annotation because we want to control type + information precisely, so that the examples behave + in expected way only for supposed reasons. *) + +(* A single modification of `type_argument` + enables mode crossing at the following points, + all depending on the expected type *) + +(* 1. function argument crosses mode at application *) +let f' x = x + 1 +[%%expect{| +val f' : int -> int = +|}] + +let f : local_ _ -> _ = + fun n -> f' n +[%%expect{| +val f : local_ int -> int = +|}] + +(* As comparison, string won't cross modes *) +let f' x = x ^ "hello" +[%%expect{| +val f' : string -> string = +|}] + +let f : local_ _ -> _ = + fun x -> f' x +[%%expect{| +Line 2, characters 14-15: +2 | fun x -> f' x + ^ +Error: This value escapes its region +|}] + +(* 2. constructor argument crosses mode at construction *) +let f : local_ _ -> bar = + fun n -> Bar0 (n, "hello") +[%%expect{| +val f : local_ int -> bar = +|}] + +let f : local_ _ -> bar = + fun n -> Bar0 (42, n) +[%%expect{| +Line 2, characters 21-22: +2 | fun n -> Bar0 (42, n) + ^ +Error: This value escapes its region +|}] + +(* 3. record field crosses mode at construction *) +let f : local_ _ -> foo = + fun n -> {x = n; y = "hello"} +[%%expect{| +val f : local_ int -> foo = +|}] + +let f : local_ _ -> foo = + fun n -> {x = 42; y = n} +[%%expect{| +Line 2, characters 24-25: +2 | fun n -> {x = 42; y = n} + ^ +Error: This value escapes its region +|}] + +(* 4. expression crosses mode when being constrained *) +let f : local_ _ -> _ = + fun n -> (n : int) +[%%expect{| +val f : local_ int -> int = +|}] + +let f : local_ _ -> _ = + fun n -> (n : string) +[%%expect{| +Line 2, characters 12-13: +2 | fun n -> (n : string) + ^ +Error: This value escapes its region +|}] + +(* 5. polymorphic variant arguments crosses mode on construction*) +let f : local_ _ -> [> `Number of int] = + fun n -> `Number n +[%%expect{| +val f : local_ int -> [> `Number of int ] = +|}] + +let f : local_ _ -> [> `Text of string] = + fun n -> `Text n +[%%expect{| +Line 2, characters 17-18: +2 | fun n -> `Text n + ^ +Error: This value escapes its region +|}] + +(* tuple elements crosses mode at construction *) +let f : local_ _ -> int * int = + fun n -> (n, n) +[%%expect{| +val f : local_ int -> int * int = +|}] + +let f : local_ _ -> string * string = + fun n -> (n, n) +[%%expect{| +Line 2, characters 12-13: +2 | fun n -> (n, n) + ^ +Error: This value escapes its region +|}] + +(* array elements crosses mode at construction *) +let f : local_ _ -> int array = + fun n -> [|n; n|] +[%%expect{| +val f : local_ int -> int array = +|}] + +let f: local_ _ -> string array = + fun n -> [|n; n|] +[%%expect{| +Line 2, characters 13-14: +2 | fun n -> [|n; n|] + ^ +Error: This value escapes its region +|}] + +(* after discussion with sdolan, we agree that + the following cannot type check because of lock; + lazy is not commonly used anyway. *) +let f: local_ _ -> int lazy_t = + fun n -> lazy n +[%%expect{| +Line 2, characters 16-17: +2 | fun n -> lazy n + ^ +Error: The value n is local, so cannot be used inside a closure that might escape +|}] + +(* record field crosses mode at projection *) +let f : local_ foo -> _ = + fun r -> r.x +[%%expect{| +val f : local_ foo -> int = +|}] + +let f : local_ foo -> _ = + fun r -> r.y +[%%expect{| +Line 2, characters 11-14: +2 | fun r -> r.y + ^^^ +Error: This value escapes its region +|}] + +(* the expected type is not considered when mode crossing the result of +pexp_field. However, upon function definition, the expected type of +the body will be used to mode cross *) +let f : local_ _ -> int = + fun r -> r.x +[%%expect{| +val f : local_ (int, 'a) foo0 -> int = +|}] + +(* expression crosses mode when prefixed with local_ *) +let g : int -> int + = fun x -> x + 42 + +let f : _ -> int = + fun () -> + g (local_ 42) +[%%expect{| +val g : int -> int = +val f : unit -> int = +|}] + +let g : string -> string + = fun y -> y ^ "hello" + +let f : _ -> string = + fun () -> + g (local_ "world") + +[%%expect{| +val g : string -> string = +Line 6, characters 6-22: +6 | g (local_ "world") + ^^^^^^^^^^^^^^^^ +Error: This value escapes its region +|}] + +(* the result of function application crosses mode *) +let f : _ -> local_ _ = + fun () -> local_ 42 +[%%expect{| +val f : unit -> local_ int = +|}] + +let g : _ -> _ = + fun () -> f () +[%%expect{| +val g : unit -> int = +|}] + +let f : _ -> local_ _ = + fun () -> local_ "hello" +[%%expect{| +val f : unit -> local_ string = +|}] + +let g : _ -> _ = + fun () -> f () +[%%expect{| +Line 2, characters 12-16: +2 | fun () -> f () + ^^^^ +Error: This value escapes its region +|}] + +(* constructor argument crosses modes upon pattern matching *) +let f : local_ bar -> _ = + fun b -> + match b with + | Bar0 (x, _) -> x +[%%expect{| +val f : local_ bar -> int = +|}] + +(* This example is identical to the last one, + except the type annotation. *) +(* This example works because function body + crosses modes based on its expected type *) +let f : local_ _ -> int = + fun b -> + match b with + | Bar0 (x, _) -> x +[%%expect{| +val f : local_ (int, 'a) bar0 -> int = +|}] + +let f : local_ bar -> _ = + fun b -> + match b with + | Bar0 (_, y) -> y +[%%expect{| +Line 4, characters 21-22: +4 | | Bar0 (_, y) -> y + ^ +Error: This value escapes its region +|}] + +(* record fields crosses modes upon pattern matching *) +let f : local_ foo -> _ = + fun r -> + match r with + | {x; _} -> x +[%%expect{| +val f : local_ foo -> int = +|}] + +(* this example works again because function body crosses modes + based on its expected type *) +let f : local_ _ -> int = + fun r -> + match r with + | {x; _} -> x +[%%expect{| +val f : local_ (int, 'a) foo0 -> int = +|}] + +let f : local_ foo -> _ = + fun r -> + match r with + | {y; _} -> y +[%%expect{| +Line 4, characters 16-17: +4 | | {y; _} -> y + ^ +Error: This value escapes its region +|}] + +(* constraint crosses modes upon pattern matching *) +let f : local_ _ -> _ = + fun (x : int) -> x +[%%expect{| +val f : local_ int -> int = +|}] + +let f : local_ _ -> _ = + fun (x : string) -> x +[%%expect{| +Line 2, characters 22-23: +2 | fun (x : string) -> x + ^ +Error: This value escapes its region +|}] + + +(* Following tests immediacy detection, + given by goldfirere *) +module M : sig + type t [@@immediate] +end = struct + type t = int +end + +type t2 = { x : int } [@@unboxed] + +let f : local_ _ -> M.t = + fun x -> x + +let f : local_ _ -> t2 = + fun x -> x +[%%expect{| +module M : sig type t [@@immediate] end +type t2 = { x : int; } [@@unboxed] +val f : local_ M.t -> M.t = +val f : local_ t2 -> t2 = +|}] diff --git a/ocaml/testsuite/tests/typing-local/crossing_64.ml b/ocaml/testsuite/tests/typing-local/crossing_64.ml new file mode 100644 index 00000000000..e38011d1db1 --- /dev/null +++ b/ocaml/testsuite/tests/typing-local/crossing_64.ml @@ -0,0 +1,14 @@ +(* TEST + * arch64 + ** expect *) + +(* Mode crossing works on immediate64 types *) +module F (M : sig type t [@@immediate64] end) = struct + let f : local_ M.t -> _ = fun t -> t +end + +[%%expect{| +module F : + functor (M : sig type t [@@immediate64] end) -> + sig val f : local_ M.t -> M.t end +|}] diff --git a/ocaml/testsuite/tests/typing-local/local.ml b/ocaml/testsuite/tests/typing-local/local.ml index 6527a7fd148..7c1564db6a6 100644 --- a/ocaml/testsuite/tests/typing-local/local.ml +++ b/ocaml/testsuite/tests/typing-local/local.ml @@ -108,7 +108,7 @@ Line 1, characters 37-67: 1 | type distinct_sarg = unit constraint local_ int -> int = int -> int ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: The type constraints are not consistent. -Type local_ int -> int is not compatible with type int -> int + Type local_ int -> int is not compatible with type int -> int |}] type distinct_sret = unit constraint int -> local_ int = int -> int [%%expect{| @@ -116,7 +116,7 @@ Line 1, characters 37-67: 1 | type distinct_sret = unit constraint int -> local_ int = int -> int ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: The type constraints are not consistent. -Type int -> local_ int is not compatible with type int -> int + Type int -> local_ int is not compatible with type int -> int |}] type distinct_sarg_sret = unit constraint local_ int -> int = local_ int -> local_ int [%%expect{| @@ -124,7 +124,8 @@ Line 1, characters 42-86: 1 | type distinct_sarg_sret = unit constraint local_ int -> int = local_ int -> local_ int ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: The type constraints are not consistent. -Type local_ int -> int is not compatible with type local_ int -> local_ int + Type local_ int -> int is not compatible with type + local_ int -> local_ int |}] type local_higher_order = unit constraint @@ -140,9 +141,10 @@ Line 2, characters 2-66: 2 | (int -> int -> int) -> int = (int -> local_ (int -> int)) -> int ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: The type constraints are not consistent. -Type (int -> int -> int) -> int is not compatible with type - (int -> local_ (int -> int)) -> int -Type int -> int -> int is not compatible with type int -> local_ (int -> int) + Type (int -> int -> int) -> int is not compatible with type + (int -> local_ (int -> int)) -> int + Type int -> int -> int is not compatible with type + int -> local_ (int -> int) |}] type local_higher_order = unit constraint @@ -158,9 +160,10 @@ Line 2, characters 2-66: 2 | int -> (int -> int -> int) = int -> (int -> local_ (int -> int)) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: The type constraints are not consistent. -Type int -> int -> int -> int is not compatible with type - int -> int -> local_ (int -> int) -Type int -> int -> int is not compatible with type int -> local_ (int -> int) + Type int -> int -> int -> int is not compatible with type + int -> int -> local_ (int -> int) + Type int -> int -> int is not compatible with type + int -> local_ (int -> int) |}] let foo () = @@ -1240,7 +1243,6 @@ let foo () = val foo : unit -> int = |}] - (* Parameter modes must be matched by the type *) let foo : 'a -> unit = fun (local_ x) -> () @@ -1473,7 +1475,7 @@ Error: Signature mismatch: type t = { nonlocal_ foo : string; } Fields do not match: foo : string; - is not compatible with: + is not the same as: nonlocal_ foo : string; The second is nonlocal and the first is not. |}] @@ -1499,7 +1501,7 @@ Error: Signature mismatch: type t = { foo : string; } Fields do not match: nonlocal_ foo : string; - is not compatible with: + is not the same as: foo : string; The first is nonlocal and the second is not. |}] @@ -1525,7 +1527,7 @@ Error: Signature mismatch: type t = { global_ foo : string; } Fields do not match: foo : string; - is not compatible with: + is not the same as: global_ foo : string; The second is global and the first is not. |}] @@ -1551,7 +1553,7 @@ Error: Signature mismatch: type t = { foo : string; } Fields do not match: global_ foo : string; - is not compatible with: + is not the same as: foo : string; The first is global and the second is not. |}] @@ -1786,6 +1788,10 @@ Error: Signature mismatch: val add : local_ int32 -> local_ int32 -> local_ int32 is not included in val add : local_ int32 -> local_ int32 -> int32 + The type local_ int32 -> local_ int32 -> local_ int32 + is not compatible with the type local_ int32 -> local_ int32 -> int32 + Type local_ int32 -> local_ int32 is not compatible with type + local_ int32 -> int32 |}] module Opt32 : sig external add : (int32[@local_opt]) -> (int32[@local_opt]) -> (int32[@local_opt]) = "%int32_add" end = Int32 module Bad32_2 : sig val add : local_ int32 -> local_ int32 -> int32 end = @@ -1815,6 +1821,10 @@ Error: Signature mismatch: (int32 [@local_opt]) -> (int32 [@local_opt]) = "%int32_add" is not included in val add : local_ int32 -> local_ int32 -> int32 + The type local_ int32 -> local_ int32 -> local_ int32 + is not compatible with the type local_ int32 -> local_ int32 -> int32 + Type local_ int32 -> local_ int32 is not compatible with type + local_ int32 -> int32 |}] module Contravariant_instantiation : sig @@ -1894,23 +1904,18 @@ val primloc : int32 -> int = |}] (* (&&) and (||) tail call on the right *) -let testbool1 x = - let local_ b = not x in - (b || false) && true - -let testbool2 x = - let local_ b = not x in - true && (false || b) -[%%expect{| -val testbool1 : bool -> bool = -Line 7, characters 20-21: -7 | true && (false || b) - ^ +let testbool1 f = let local_ r = ref 42 in (f r || false) && true + +let testbool2 f = let local_ r = ref 42 in true && (false || f r) +[%%expect{| +val testbool1 : (local_ int ref -> bool) -> bool = +Line 3, characters 63-64: +3 | let testbool2 f = let local_ r = ref 42 in true && (false || f r) + ^ Error: This local value escapes its region - Hint: Cannot return local value without an explicit "local_" annotation + Hint: This argument cannot be local, because this is a tail call |}] - (* mode-crossing using unary + *) let promote (local_ x) = +x [%%expect{| @@ -2081,6 +2086,8 @@ Error: Signature mismatch: val foo : float -> string is not included in val foo : local_ float -> string + The type float -> string is not compatible with the type + local_ float -> string |}] module F (X : sig val foo : float -> local_ string end) : sig @@ -2099,6 +2106,8 @@ Error: Signature mismatch: val foo : float -> local_ string is not included in val foo : float -> string + The type float -> local_ string is not compatible with the type + float -> string |}] module F (X : sig val foo : local_ float -> float -> string end) : sig @@ -2117,6 +2126,8 @@ Error: Signature mismatch: val foo : local_ float -> float -> string is not included in val foo : float -> float -> string + The type local_ float -> float -> string + is not compatible with the type float -> float -> string |}] module F (X : sig val foo : local_ float -> float -> string end) : sig @@ -2162,6 +2173,10 @@ Error: Signature mismatch: val foo : (float -> string) inv is not included in val foo : (float -> local_ string) inv + The type (float -> string) inv is not compatible with the type + (float -> local_ string) inv + Type float -> string is not compatible with type + float -> local_ string |}] module F (X : sig val foo : (float -> string) co end) : sig @@ -2189,6 +2204,10 @@ Error: Signature mismatch: val foo : (float -> string) contra is not included in val foo : (float -> local_ string) contra + The type (float -> string) contra is not compatible with the type + (float -> local_ string) contra + Type float -> string is not compatible with type + float -> local_ string |}] module F (X : sig val foo : (float -> string) bi end) : sig @@ -2216,6 +2235,10 @@ Error: Signature mismatch: val foo : (float -> local_ string) inv is not included in val foo : (float -> string) inv + The type (float -> local_ string) inv is not compatible with the type + (float -> string) inv + Type float -> local_ string is not compatible with type + float -> string |}] module F (X : sig val foo : (float -> local_ string) co end) : sig @@ -2234,6 +2257,10 @@ Error: Signature mismatch: val foo : (float -> local_ string) co is not included in val foo : (float -> string) co + The type (float -> local_ string) co is not compatible with the type + (float -> string) co + Type float -> local_ string is not compatible with type + float -> string |}] module F (X : sig val foo : (float -> local_ string) contra end) : sig @@ -2253,3 +2280,327 @@ module F : functor (X : sig val foo : (float -> local_ string) bi end) -> sig val foo : (float -> string) bi end |}] + + +(* + * constructor arguments global/nonlocal + *) + +(* Global argument are preserved in module inclusion *) +module M : sig + type t = Bar of int * global_ string +end = struct + type t = Bar of int * string +end +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = Bar of int * string +5 | end +Error: Signature mismatch: + Modules do not match: + sig type t = Bar of int * string end + is not included in + sig type t = Bar of int * global_ string end + Type declarations do not match: + type t = Bar of int * string + is not included in + type t = Bar of int * global_ string + Constructors do not match: + Bar of int * string + is not the same as: + Bar of int * global_ string + Locality mismatch at argument position 2 : The second is global and the first is not. +|}] + + +module M : sig + type t = Bar of int * string +end = struct + type t = Bar of int * global_ string +end +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = Bar of int * global_ string +5 | end +Error: Signature mismatch: + Modules do not match: + sig type t = Bar of int * global_ string end + is not included in + sig type t = Bar of int * string end + Type declarations do not match: + type t = Bar of int * global_ string + is not included in + type t = Bar of int * string + Constructors do not match: + Bar of int * global_ string + is not the same as: + Bar of int * string + Locality mismatch at argument position 2 : The first is global and the second is not. +|}] + +(* Nonlocal argument are preserved in module inclusion *) +module M : sig + type t = Bar of int * nonlocal_ string +end = struct + type t = Bar of int * string +end +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = Bar of int * string +5 | end +Error: Signature mismatch: + Modules do not match: + sig type t = Bar of int * string end + is not included in + sig type t = Bar of int * nonlocal_ string end + Type declarations do not match: + type t = Bar of int * string + is not included in + type t = Bar of int * nonlocal_ string + Constructors do not match: + Bar of int * string + is not the same as: + Bar of int * nonlocal_ string + Locality mismatch at argument position 2 : The second is nonlocal and the first is not. +|}] + + +module M : sig + type t = Bar of int * string +end = struct + type t = Bar of int * nonlocal_ string +end +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = Bar of int * nonlocal_ string +5 | end +Error: Signature mismatch: + Modules do not match: + sig type t = Bar of int * nonlocal_ string end + is not included in + sig type t = Bar of int * string end + Type declarations do not match: + type t = Bar of int * nonlocal_ string + is not included in + type t = Bar of int * string + Constructors do not match: + Bar of int * nonlocal_ string + is not the same as: + Bar of int * string + Locality mismatch at argument position 2 : The first is nonlocal and the second is not. +|}] + +(* global_ and nonlocal_ bind closer than star *) +type gfoo = GFoo of global_ string * string +type rfoo = RFoo of nonlocal_ string * string +[%%expect{| +type gfoo = GFoo of global_ string * string +type rfoo = RFoo of nonlocal_ string * string +|}] + +(* TESTING OF GLOBAL_ *) + +(* global arguments must be global when constructing + cannot be regional or local +*) +let f (local_ s : string) = + GFoo (s, "bar") +[%%expect{| +Line 2, characters 8-9: +2 | GFoo (s, "bar") + ^ +Error: This value escapes its region +|}] + +let f = + let local_ s = "foo" in + GFoo (s, "bar") +[%%expect{| +Line 3, characters 8-9: +3 | GFoo (s, "bar") + ^ +Error: This value escapes its region +|}] + +(* s' extracted from x as global *) +(* despite x is local or regional*) +let f (s : string) = + let local_ x = GFoo (s, "bar") in + match x with + | GFoo (s', _) -> ref s' + +[%%expect{| +val f : string -> string ref = +|}] + +let f (local_ x : gfoo) = + match x with + | GFoo (s', _) -> ref s' + +[%%expect{| +val f : local_ gfoo -> string ref = +|}] + +(* the argument not marked global remains contingent on construction *) +(* local gives local *) +let f (s : string) = + let local_ x = GFoo ("bar", s) in + match x with + | GFoo (_, s') -> s' + +[%%expect{| +Line 4, characters 20-22: +4 | | GFoo (_, s') -> s' + ^^ +Error: This local value escapes its region + Hint: Cannot return local value without an explicit "local_" annotation +|}] + +(* and regional gives regional *) +let f (local_ x : gfoo) = + match x with + | GFoo (_, s') -> ref s' + +[%%expect{| +Line 3, characters 24-26: +3 | | GFoo (_, s') -> ref s' + ^^ +Error: This value escapes its region +|}] + +(* TESTING NONLOCAL_ *) +(* nonlocal argument must be outer than the construction*) +(* below, local is not outer than local*) +let f (local_ s : string) = + let local_ s' = "foo" in + let local_ x = RFoo(s', "bar") in + "bar" +[%%expect{| +Line 3, characters 22-24: +3 | let local_ x = RFoo(s', "bar") in + ^^ +Error: This local value escapes its region +|}] + +(* local is not outer than global either *) +let f = + let local_ s = "foo" in + let x = RFoo(s, "bar") in + "bar" +[%%expect{| +Line 3, characters 15-16: +3 | let x = RFoo(s, "bar") in + ^ +Error: This local value escapes its region +|}] + + +(* but global is outer than local *) +let f (s : string) = (* s is global *) + let local_ _x = RFoo (s, "bar") in (* x is local *) + "foo" +[%%expect{| +val f : string -> string = +|}] + +(* and regional is outer than local *) +let f (local_ s : string) = (* s is regional *) + let local_ _x = RFoo (s, "bar") in (* x is local *) + "foo" +[%%expect{| +val f : local_ string -> string = +|}] + +(* s' extracted from x is not local *) +(* even though x is local *) +let f (local_ s : string) = + let local_ x = RFoo (s, "bar") in + match x with + | RFoo (s', _) -> s' + +[%%expect{| +val f : local_ string -> local_ string = +|}] + +(* Moreover, it is not global *) +let f (local_ s : string) = + let local_ x = RFoo(s, "bar") in + match x with + | RFoo (s', _) -> GFoo (s', "bar") +[%%expect{| +Line 4, characters 26-28: +4 | | RFoo (s', _) -> GFoo (s', "bar") + ^^ +Error: This value escapes its region +|}] + +(* x is already global *) +(* regional s' extracted from x is still global *) +let f (s : string) = + let x = RFoo (s, "bar") in + match x with + | RFoo (s', _) -> GFoo(s', "bar") +[%%expect{| +val f : string -> gfoo = +|}] + +(* regional s extracted from regional x *) +(* still regional *) +(* first it is not local *) +let f (local_ x : rfoo) = + match x with + | RFoo (s, _) -> s +[%%expect{| +val f : local_ rfoo -> local_ string = +|}] + +(* second, it is not global *) +let f (local_ x : rfoo) = + match x with + | RFoo (s, _) -> ref s +[%%expect{| +Line 3, characters 23-24: +3 | | RFoo (s, _) -> ref s + ^ +Error: This value escapes its region +|}] + + +(* test of arrays *) +(* as elements of arrays are mutable *) +(* it is only safe for them to be at global mode *) +(* cf: similarly reference cell can contain only global values *) + +(* on construction of array, we ensure elements are global *) + +let f (local_ x : string) = + [|x; "foo"|] +[%%expect{| +Line 2, characters 4-5: +2 | [|x; "foo"|] + ^ +Error: This value escapes its region +|}] + +let f (x : string) = + [|x; "foo"|] +[%%expect{| +val f : string -> string array = +|}] + + +(* on pattern matching of array, + elements are strengthened to global + even if array itself is local *) +let f (local_ a : string array) = + match a with + | [| x; _ |] -> ref x + | _ -> ref "foo" + +[%%expect{| +val f : local_ string array -> string ref = +|}] \ No newline at end of file diff --git a/ocaml/testsuite/tests/typing-local/loop_regions.ml b/ocaml/testsuite/tests/typing-local/loop_regions.ml index 497fc4341b7..b346d100a09 100644 --- a/ocaml/testsuite/tests/typing-local/loop_regions.ml +++ b/ocaml/testsuite/tests/typing-local/loop_regions.ml @@ -8,6 +8,7 @@ *) external local_stack_offset : unit -> int = "caml_local_stack_offset" +let local_stack_offset () = local_stack_offset () / (Sys.word_size / 8) external opaque_local : ('a[@local_opt]) -> ('a[@local_opt]) = "%opaque" let print_offsets (name,allocs) = diff --git a/ocaml/testsuite/tests/typing-local/loop_regions.stack.reference b/ocaml/testsuite/tests/typing-local/loop_regions.stack.reference index 14aa447d545..0a56053d5d4 100644 --- a/ocaml/testsuite/tests/typing-local/loop_regions.stack.reference +++ b/ocaml/testsuite/tests/typing-local/loop_regions.stack.reference @@ -1,6 +1,6 @@ - local for: [0; 16; 16] - non-local for: [0; 16; 0] - local while body: [0; 16; 16] - nonlocal while body: [0; 16; 0] - local while cond: [0; 16; 16] - nonlocal while cond: [0; 16; 0] + local for: [0; 2; 2] + non-local for: [0; 2; 0] + local while body: [0; 2; 2] + nonlocal while body: [0; 2; 0] + local while cond: [0; 2; 2] + nonlocal while cond: [0; 2; 0] diff --git a/ocaml/testsuite/tests/typing-local/nosyntax.ml b/ocaml/testsuite/tests/typing-local/nosyntax.ml index b2c6dd4d542..3a6c23d0c98 100644 --- a/ocaml/testsuite/tests/typing-local/nosyntax.ml +++ b/ocaml/testsuite/tests/typing-local/nosyntax.ml @@ -21,12 +21,95 @@ Line 1, characters 21-22: 1 | let cast (x : fn) = (x : lfn) ^ Error: This expression has type fn = string -> int - but an expression was expected of type (string [@local]) -> int + but an expression was expected of type lfn = (string [@local]) -> int |}] let local_ref (f : lfn -> unit) = f (fun s -> let _ = [|s;s;s|] in 1) [%%expect{| -val local_ref : (lfn -> unit) -> unit = +Line 2, characters 24-25: +2 | f (fun s -> let _ = [|s;s;s|] in 1) + ^ +Error: This value escapes its region |}] + +type foo = { + x : string +} +[%%expect{| +type foo = { x : string; } +|}] + +type gfoo = { + x : string [@ocaml.global] +} +[%%expect{| +type gfoo = { x : (string [@global]); } +|}] +type gfoo' = { + global_ x : string +} +[%%expect{| +Line 2, characters 2-21: +2 | global_ x : string + ^^^^^^^^^^^^^^^^^^^ +Error: The local extension is disabled + To enable it, pass the '-extension local' flag +|}] +type gfoo'' = { + x : string [@ocaml.global] [@ocaml.nonlocal] +} +[%%expect{| +Line 2, characters 2-46: +2 | x : string [@ocaml.global] [@ocaml.nonlocal] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: A type cannot be both global and nonlocal +|}] + +let cast ((r : foo)[@ocaml.local]) : gfoo = + match r with + | {x} -> {x} +[%%expect{| +Line 3, characters 12-13: +3 | | {x} -> {x} + ^ +Error: This value escapes its region +|}] + +type foo = Foo of string +[%%expect{| +type foo = Foo of string +|}] +type gfoo = GFoo of (string [@ocaml.global]) +[%%expect{| +type gfoo = GFoo of (string [@global]) +|}] +type gfoo' = Gfoo of global_ string +[%%expect{| +Line 1, characters 29-35: +1 | type gfoo' = Gfoo of global_ string + ^^^^^^ +Error: The local extension is disabled + To enable it, pass the '-extension local' flag +|}] + +type gfoo'' = Gfoo of (string [@ocaml.global] [@ocaml.nonlocal]) +[%%expect{| +Line 1, characters 23-29: +1 | type gfoo'' = Gfoo of (string [@ocaml.global] [@ocaml.nonlocal]) + ^^^^^^ +Error: A type cannot be both global and nonlocal +|}] + +let cast ((r : foo)[@ocaml.local]) : gfoo = + match r with + | Foo x -> GFoo x + +[%%expect{| +Line 3, characters 18-19: +3 | | Foo x -> GFoo x + ^ +Error: This value escapes its region +|}] + diff --git a/ocaml/testsuite/tests/typing-local/pr902.ml b/ocaml/testsuite/tests/typing-local/pr902.ml new file mode 100644 index 00000000000..aeb74c9dd33 --- /dev/null +++ b/ocaml/testsuite/tests/typing-local/pr902.ml @@ -0,0 +1,32 @@ +(* TEST + * stack-allocation + ** native +*) + +(* PR902 (return mode on second application expression in a split + overapplication) *) + +external local_stack_offset : unit -> int = "caml_local_stack_offset" +external opaque_identity : ('a[@local_opt]) -> ('a[@local_opt]) = "%opaque" +external is_local : local_ 'a -> bool = "caml_obj_is_local" + +let f2 p () = p + +let f1 () x : (unit -> local_ (int * int)) = + (* This local allocation should end up in the caller's region, because + we should have got here via one of the caml_applyL functions. If the + return mode of the second application in the expansion of the + overapplication below is wrongly Heap, then caml_apply will be used + instead, which will open its own region for this allocation. *) + let p = local_ (x, x) in + local_ ((opaque_identity f2) p) [@nontail] + +let[@inline never] to_be_overapplied () () = Sys.opaque_identity f1 + +let () = + let start_offset = local_stack_offset () in + let p = to_be_overapplied () () () 42 () in + let end_offset = local_stack_offset () in + assert (is_local p); + let ok = end_offset - start_offset = Sys.word_size (* eight words *) in + Printf.printf "PR902: %s\n" (if ok then "ok" else "FAIL") diff --git a/ocaml/testsuite/tests/typing-local/pr902.reference b/ocaml/testsuite/tests/typing-local/pr902.reference new file mode 100644 index 00000000000..fd5f1bd02c4 --- /dev/null +++ b/ocaml/testsuite/tests/typing-local/pr902.reference @@ -0,0 +1 @@ +PR902: ok diff --git a/ocaml/testsuite/tests/typing-local/print_syntax.ml b/ocaml/testsuite/tests/typing-local/print_syntax.ml index fdde6d0e41c..0b22a2d7937 100644 --- a/ocaml/testsuite/tests/typing-local/print_syntax.ml +++ b/ocaml/testsuite/tests/typing-local/print_syntax.ml @@ -1,6 +1,6 @@ (* TEST include ocamlcommon - files = "example_syntax.ml" + readonly_files = "example_syntax.ml" reference = "${test_source_directory}/example_syntax.ml" *) diff --git a/ocaml/testsuite/tests/typing-local/regions.ml b/ocaml/testsuite/tests/typing-local/regions.ml index 44c73f23b68..57ceccb331c 100644 --- a/ocaml/testsuite/tests/typing-local/regions.ml +++ b/ocaml/testsuite/tests/typing-local/regions.ml @@ -114,6 +114,13 @@ let () = check_empty "toplevel rec binding" ());; let () = check_empty "toplevel eval" +let () = + let f x b g = + let local_ p = x, x in + if b then () else (g p; ()) + in f 0 true (fun _ -> ()) +let () = check_empty "constant switch arm" + module type T = sig val x : int end let _ = let module M : T = diff --git a/ocaml/testsuite/tests/typing-local/regions.reference b/ocaml/testsuite/tests/typing-local/regions.reference index bea73d31191..d5ea082ec10 100644 --- a/ocaml/testsuite/tests/typing-local/regions.reference +++ b/ocaml/testsuite/tests/typing-local/regions.reference @@ -13,6 +13,7 @@ toplevel binding: OK toplevel rec binding: OK toplevel eval: OK + constant switch arm: OK first class mod: OK class d definition: OK class definitions: OK diff --git a/ocaml/testsuite/tests/typing-local/regression_class_dep.ml b/ocaml/testsuite/tests/typing-local/regression_class_dep.ml new file mode 100644 index 00000000000..dcd2a6aeebb --- /dev/null +++ b/ocaml/testsuite/tests/typing-local/regression_class_dep.ml @@ -0,0 +1,9 @@ +class c = + object + method private m () () = 0 + end + +class virtual cv = + object + method virtual private m : unit -> unit -> int + end diff --git a/ocaml/testsuite/tests/typing-local/regression_class_type.ml b/ocaml/testsuite/tests/typing-local/regression_class_type.ml new file mode 100644 index 00000000000..d0c6803e294 --- /dev/null +++ b/ocaml/testsuite/tests/typing-local/regression_class_type.ml @@ -0,0 +1,18 @@ +(* TEST +readonly_files = "regression_class_dep.ml" +* setup-ocamlc.opt-build-env +** ocamlc.opt +module = "regression_class_dep.ml" +*** ocamlc.opt +module = "" +flags = "-c" +*) + +(* https://github.com/ocaml-flambda/ocaml-jst/issues/65 *) + +module Dep = Regression_class_dep +class c fname = + object + inherit Dep.c + inherit Dep.cv + end diff --git a/ocaml/testsuite/tests/typing-local/tmc.compilers.reference b/ocaml/testsuite/tests/typing-local/tmc.compilers.reference new file mode 100644 index 00000000000..3fa90699db1 --- /dev/null +++ b/ocaml/testsuite/tests/typing-local/tmc.compilers.reference @@ -0,0 +1,6 @@ +File "tmc.ml", lines 10-13, characters 34-32: +10 | ..................................(local_ li) = local_ +11 | match li with +12 | | [] -> [] +13 | | x :: xs -> x :: copy_list xs +Error: [@tail_mod_cons]: Functions cannot be both local-returning and [@tail_mod_cons] diff --git a/ocaml/testsuite/tests/typing-local/tmc.ml b/ocaml/testsuite/tests/typing-local/tmc.ml new file mode 100644 index 00000000000..fc1cb2bbe2d --- /dev/null +++ b/ocaml/testsuite/tests/typing-local/tmc.ml @@ -0,0 +1,14 @@ +(* TEST + * stack-allocation + ** setup-ocamlopt.opt-build-env + *** ocamlopt.opt + ocamlopt_opt_exit_status = "2" + **** check-ocamlopt.opt-output +*) + +(* Cannot use TMC on local-returning functions *) +let[@tail_mod_cons] rec copy_list (local_ li) = local_ + match li with + | [] -> [] + | x :: xs -> x :: copy_list xs + diff --git a/ocaml/testsuite/tests/typing-misc-bugs/core_array_reduced_ok.ml b/ocaml/testsuite/tests/typing-misc-bugs/core_array_reduced_ok.ml index de5eb1170a4..38b630185a7 100644 --- a/ocaml/testsuite/tests/typing-misc-bugs/core_array_reduced_ok.ml +++ b/ocaml/testsuite/tests/typing-misc-bugs/core_array_reduced_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-misc-bugs/pr6303_bad.ml b/ocaml/testsuite/tests/typing-misc-bugs/pr6303_bad.ml index 0f67b86db14..e2980e0f031 100644 --- a/ocaml/testsuite/tests/typing-misc-bugs/pr6303_bad.ml +++ b/ocaml/testsuite/tests/typing-misc-bugs/pr6303_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-misc-bugs/pr6946_bad.ml b/ocaml/testsuite/tests/typing-misc-bugs/pr6946_bad.ml index 59bcda10253..5142becdf93 100644 --- a/ocaml/testsuite/tests/typing-misc-bugs/pr6946_bad.ml +++ b/ocaml/testsuite/tests/typing-misc-bugs/pr6946_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-misc/constraints.ml b/ocaml/testsuite/tests/typing-misc/constraints.ml index a612030ec94..753477cc13f 100644 --- a/ocaml/testsuite/tests/typing-misc/constraints.ml +++ b/ocaml/testsuite/tests/typing-misc/constraints.ml @@ -7,8 +7,7 @@ type 'a t = [`A of 'a t t] as 'a;; (* fails *) Line 1, characters 0-32: 1 | type 'a t = [`A of 'a t t] as 'a;; (* fails *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The definition of t contains a cycle: - 'a t t as 'a +Error: The type abbreviation t is cyclic |}, Principal{| Line 1, characters 0-32: 1 | type 'a t = [`A of 'a t t] as 'a;; (* fails *) @@ -143,8 +142,8 @@ let () = print_endline (match PR6505b.x with `Bar s -> s);; (* fails *) module PR6505b : sig type 'o is_an_object = 'o constraint 'o = [> ] - type ('a, 'b) abs = 'b constraint 'a = 'b is_an_object - constraint 'b = [> ] + type ('a, 'o) abs = 'o constraint 'a = 'o is_an_object + constraint 'o = [> ] val x : (([> `Foo of int ] as 'a) is_an_object, 'a is_an_object) abs end Line 6, characters 23-57: @@ -156,7 +155,6 @@ Here is an example of a case that is not matched: Exception: Match_failure ("", 6, 23). |}] - (* #9866, #9873 *) type 'a t = 'b constraint 'a = 'b t;; @@ -214,7 +212,7 @@ Line 1, characters 0-59: 1 | type 'a t = constraint = 'b t;; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: A type variable is unbound in this type declaration. -In method b: 'b the variable 'b is unbound + In method b: 'b the variable 'b is unbound |}] module rec M : sig type 'a t = 'b constraint 'a = 'b t end = M;; @@ -259,3 +257,117 @@ struct type !'a t = 'b constraint 'a = 'b s end *) + +type 'a t = T + constraint 'a = int + constraint 'a = float +[%%expect{| +Line 3, characters 13-23: +3 | constraint 'a = float + ^^^^^^^^^^ +Error: The type constraints are not consistent. + Type int is not compatible with type float +|}] + +type ('a,'b) t = T + constraint 'a = int -> float + constraint 'b = bool -> char + constraint 'a = 'b +[%%expect{| +Line 4, characters 13-20: +4 | constraint 'a = 'b + ^^^^^^^ +Error: The type constraints are not consistent. + Type int -> float is not compatible with type bool -> char + Type int is not compatible with type bool +|}] + +class type ['a, 'b] a = object + constraint 'a = 'b + constraint 'a = int * int + constraint 'b = float * float +end;; +[%%expect{| +Line 4, characters 2-31: +4 | constraint 'b = float * float + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The class constraints are not consistent. + Type int * int is not compatible with type float * float + Type int is not compatible with type float +|}] + +(* #11101 *) +type ('node,'self) extension = < node: 'node; self: 'self > as 'self +type 'ext node = < > constraint 'ext = ('ext node, 'self) extension;; +[%%expect{| +type ('node, 'a) extension = 'a constraint 'a = < node : 'node; self : 'a > +type 'a node = < > + constraint 'a = ('a node, < node : 'a node; self : 'b > as 'b) extension +|}, Principal{| +type ('node, 'a) extension = < node : 'node; self : 'b > as 'b + constraint 'a = < node : 'node; self : 'a > +type 'a node = < > + constraint 'a = ('a node, < node : 'a node; self : 'b > as 'b) extension +|}] + +class type ['node] extension = + object ('self) + method clone : 'self + method node : 'node + end +type 'ext node = < > + constraint 'ext = 'ext node #extension ;; +[%%expect{| +class type ['node] extension = + object ('a) method clone : 'a method node : 'node end +type 'a node = < > constraint 'a = < clone : 'a; node : 'a node; .. > +|}] + +module Raise: sig val default_extension: 'a node extension as 'a end = struct + let default_extension = failwith "Default_extension failure" +end;; +[%%expect{| +Exception: Failure "Default_extension failure". +|}] + + +(* PR#11771 -- Constraints making expansion affect typeability *) +type foo = Foo +type bar = Bar + +type _ tag = + | Foo_tag : foo tag + | Bar_tag : bar tag + +type ('a, 'self) obj = + < foo : foo -> 'a ; bar : bar -> 'a; .. > as 'self +[%%expect {| +type foo = Foo +type bar = Bar +type _ tag = Foo_tag : foo tag | Bar_tag : bar tag +type ('a, 'self) obj = 'self + constraint 'self = < bar : bar -> 'a; foo : foo -> 'a; .. > +|}] + +let test_obj_no_expansion : + type a b. a tag -> < foo : foo -> b ; bar : bar -> b; .. > -> a -> b = + fun t obj x -> + match t with + | Foo_tag -> obj#foo x + | Bar_tag -> obj#bar x +[%%expect {| +val test_obj_no_expansion : + 'a tag -> < bar : bar -> 'b; foo : foo -> 'b; .. > -> 'a -> 'b = +|}] + +let test_obj_with_expansion : + type a b. a tag -> (b, _) obj -> a -> b = + fun t obj x -> + match t with + | Foo_tag -> obj#foo x + | Bar_tag -> obj#bar x +[%%expect {| +val test_obj_with_expansion : + 'a tag -> ('b, < bar : bar -> 'b; foo : foo -> 'b; .. >) obj -> 'a -> 'b = + +|}] diff --git a/ocaml/testsuite/tests/typing-misc/deep.ml b/ocaml/testsuite/tests/typing-misc/deep.ml new file mode 100644 index 00000000000..01ade06106a --- /dev/null +++ b/ocaml/testsuite/tests/typing-misc/deep.ml @@ -0,0 +1,98 @@ +(* TEST + * expect +*) + +module M : sig + val x : bool * int +end = struct + let x = false , "not an int" +end +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let x = false , "not an int" +5 | end +Error: Signature mismatch: + Modules do not match: + sig val x : bool * string end + is not included in + sig val x : bool * int end + Values do not match: + val x : bool * string + is not included in + val x : bool * int + The type bool * string is not compatible with the type bool * int + Type string is not compatible with type int +|}] + +module T : sig + val f : int -> (float * string option) list +end = struct + let f x = x + List.length [0.0, Some true] +end +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let f x = x + List.length [0.0, Some true] +5 | end +Error: Signature mismatch: + Modules do not match: + sig val f : int -> int end + is not included in + sig val f : int -> (float * string option) list end + Values do not match: + val f : int -> int + is not included in + val f : int -> (float * string option) list + The type int -> int is not compatible with the type + int -> (float * string option) list + Type int is not compatible with type (float * string option) list +|}] + +(* Alpha-equivalence *) +module T : sig + val f : ('a list * 'b list -> int) +end = struct + let f : ('c list * 'd option -> int) = assert false +end +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let f : ('c list * 'd option -> int) = assert false +5 | end +Error: Signature mismatch: + Modules do not match: + sig val f : 'c list * 'd option -> int end + is not included in + sig val f : 'a list * 'b list -> int end + Values do not match: + val f : 'c list * 'd option -> int + is not included in + val f : 'a list * 'b list -> int + The type 'a list * 'b option -> int is not compatible with the type + 'a list * 'c list -> int + Type 'b option is not compatible with type 'c list +|}] + +module T : sig + type t = int * float +end = struct + type t = bool * float +end +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = bool * float +5 | end +Error: Signature mismatch: + Modules do not match: + sig type t = bool * float end + is not included in + sig type t = int * float end + Type declarations do not match: + type t = bool * float + is not included in + type t = int * float + The type bool * float is not equal to the type int * float + Type bool is not equal to type int +|}] diff --git a/ocaml/testsuite/tests/typing-misc/distant_errors.ml b/ocaml/testsuite/tests/typing-misc/distant_errors.ml new file mode 100644 index 00000000000..f5f2ffd0fbd --- /dev/null +++ b/ocaml/testsuite/tests/typing-misc/distant_errors.ml @@ -0,0 +1,34 @@ +(* TEST + * expect +*) + +(** The aim of this file is to keep track of programs that are "far" from being well-typed *) + + +(** Arity mismatch between structure and signature *) + +module M : sig + type (_, _) t + val f : (_, _) t -> unit +end = struct + type _ t + let f _ = () +end + +[%%expect{| +Lines 9-12, characters 6-3: + 9 | ......struct +10 | type _ t +11 | let f _ = () +12 | end +Error: Signature mismatch: + Modules do not match: + sig type _ t val f : 'a -> unit end + is not included in + sig type (_, _) t val f : ('a, 'b) t -> unit end + Type declarations do not match: + type _ t + is not included in + type (_, _) t + They have different arities. +|}] diff --git a/ocaml/testsuite/tests/typing-misc/enrich_typedecl.ml b/ocaml/testsuite/tests/typing-misc/enrich_typedecl.ml index 295cab1ef28..c6087a9dc71 100644 --- a/ocaml/testsuite/tests/typing-misc/enrich_typedecl.ml +++ b/ocaml/testsuite/tests/typing-misc/enrich_typedecl.ml @@ -31,6 +31,7 @@ Error: Signature mismatch: type t = A.t = A | B is not included in type t = int * string + The type A.t is not equal to the type int * string |}] module rec B : sig @@ -62,6 +63,7 @@ Error: Signature mismatch: type 'a t = 'a B.t = A of 'a | B is not included in type 'a t = 'a + The type 'a B.t is not equal to the type 'a |}];; module rec C : sig @@ -126,6 +128,7 @@ Error: Signature mismatch: type 'a t = 'a D.t = A of 'a | B is not included in type 'a t = int + The type 'a D.t is not equal to the type int |}];; module rec E : sig @@ -157,6 +160,7 @@ Error: Signature mismatch: type 'a t = 'a E.t = A of 'a | B is not included in type 'a t = 'a constraint 'a = [> `Foo ] + The type 'a is not equal to the type [> `Foo ] |}];; module rec E2 : sig @@ -188,6 +192,7 @@ Error: Signature mismatch: type 'a t = 'a E2.t = A of 'a | B is not included in type 'a t = [ `Foo ] + The type 'a E2.t is not equal to the type [ `Foo ] |}];; module rec E3 : sig @@ -219,6 +224,7 @@ Error: Signature mismatch: type 'a t = 'a E3.t = A of 'a | B is not included in type 'a t = 'a constraint 'a = [< `Foo ] + The type 'a is not equal to the type [< `Foo ] |}];; @@ -254,7 +260,7 @@ Error: Signature mismatch: type ('a, 'b) t = Foo of 'a Constructors do not match: Foo of 'b - is not compatible with: + is not the same as: Foo of 'a - The types are not equal. + The type 'b is not equal to the type 'a |}];; diff --git a/ocaml/testsuite/tests/typing-misc/exotic_unifications.ml b/ocaml/testsuite/tests/typing-misc/exotic_unifications.ml index 9f27b561e31..2e3e69692fc 100644 --- a/ocaml/testsuite/tests/typing-misc/exotic_unifications.ml +++ b/ocaml/testsuite/tests/typing-misc/exotic_unifications.ml @@ -9,9 +9,9 @@ class x = object(self: ) end [%%expect {| class virtual t : object method virtual x : float end -Line 4, characters 16-17: +Line 4, characters 8-17: 4 | inherit t - ^ + ^^^^^^^^^ Error: The method x has type int but is expected to have type float Type int is not compatible with type float |}] diff --git a/ocaml/testsuite/tests/typing-misc/filter_params.ml b/ocaml/testsuite/tests/typing-misc/filter_params.ml new file mode 100644 index 00000000000..879693680bc --- /dev/null +++ b/ocaml/testsuite/tests/typing-misc/filter_params.ml @@ -0,0 +1,8 @@ +(* TEST + * expect +*) + +type ('a, 'b) t constraint 'a = 'b +[%%expect{| +type ('b, 'a) t constraint 'a = 'b +|}] diff --git a/ocaml/testsuite/tests/typing-misc/includeclass_errors.ml b/ocaml/testsuite/tests/typing-misc/includeclass_errors.ml index 9d1b8be4e5e..033669e2a53 100644 --- a/ocaml/testsuite/tests/typing-misc/includeclass_errors.ml +++ b/ocaml/testsuite/tests/typing-misc/includeclass_errors.ml @@ -146,7 +146,8 @@ Lines 2-5, characters 4-7: 3 | method foo = "foo" 4 | method private virtual cast: int 5 | end -Error: The class type object method foo : string end +Error: The class type + object method private virtual cast : int method foo : string end is not matched by the class type foo_t The virtual method cast cannot be hidden |}] diff --git a/ocaml/testsuite/tests/typing-misc/labels.ml b/ocaml/testsuite/tests/typing-misc/labels.ml index 3b2d32b8e58..24dcd852cde 100644 --- a/ocaml/testsuite/tests/typing-misc/labels.ml +++ b/ocaml/testsuite/tests/typing-misc/labels.ml @@ -31,9 +31,37 @@ Line 1, characters 4-23: 1 | foo (fun ?opt () -> ()) ;; (* fails *) ^^^^^^^^^^^^^^^^^^^ Error: This function should have type unit -> unit - but its first argument is labelled ?opt + but its first argument is labeled ?opt instead of being unlabeled |}];; +(* filter_arrow *) + +let (f : x:int -> int) = fun y -> y +[%%expect{| +Line 1, characters 25-35: +1 | let (f : x:int -> int) = fun y -> y + ^^^^^^^^^^ +Error: This function should have type x:int -> int + but its first argument is unlabeled instead of being labeled ~x +|}];; + +let (f : int -> int) = fun ~y -> y +[%%expect{| +Line 1, characters 23-34: +1 | let (f : int -> int) = fun ~y -> y + ^^^^^^^^^^^ +Error: This function should have type int -> int + but its first argument is labeled ~y instead of being unlabeled +|}];; + +let (f : x:int -> int) = fun ~y -> y +[%%expect{| +Line 1, characters 25-36: +1 | let (f : x:int -> int) = fun ~y -> y + ^^^^^^^^^^^ +Error: This function should have type x:int -> int + but its first argument is labeled ~y instead of ~x +|}];; (* More examples *) diff --git a/ocaml/testsuite/tests/typing-misc/optbinders.ml b/ocaml/testsuite/tests/typing-misc/optbinders.ml new file mode 100644 index 00000000000..ab1390675dc --- /dev/null +++ b/ocaml/testsuite/tests/typing-misc/optbinders.ml @@ -0,0 +1,103 @@ +(* TEST + * expect +*) + +(* Optional binders can be used in value declarations, + and signatures are equivalent with or without them. *) +module type Id1 = sig val id : 'a -> 'a end +module type Id2 = sig val id : 'a . 'a -> 'a end +module F (X : Id1) : Id2 = X +module G (X : Id2) : Id1 = X +module Id : Id2 = struct let id x = x end +[%%expect{| +module type Id1 = sig val id : 'a -> 'a end +module type Id2 = sig val id : 'a -> 'a end +module F : functor (X : Id1) -> Id2 +module G : functor (X : Id2) -> Id1 +module Id : Id2 +|}] + + +(* If present, the variables must be universally quantified *) +type 'a constrained = string constraint 'a = int +module type Ok_constraint = sig val c : 'a constrained end +[%%expect{| +type 'a constrained = string constraint 'a = int +module type Ok_constraint = sig val c : int constrained end +|}] +module type Bad_constraint = sig val c : 'a . 'a constrained end +[%%expect{| +Line 1, characters 41-60: +1 | module type Bad_constraint = sig val c : 'a . 'a constrained end + ^^^^^^^^^^^^^^^^^^^ +Error: The universal type variable 'a cannot be generalized: it is bound to + int. +|}] + +(* with the usual caveat for row variables *) +module type Row = sig val poly : 'a 'b . ([> `Foo of int] as 'a) * 'b end +module type NotRow = sig val poly : 'a 'b . (int as 'a) * 'b end +[%%expect{| +module type Row = sig val poly : [> `Foo of int ] * 'b end +Line 2, characters 36-60: +2 | module type NotRow = sig val poly : 'a 'b . (int as 'a) * 'b end + ^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The universal type variable 'a cannot be generalized: it is bound to + int. +|}] + +(* If present, the quantifier must quantify all variables *) +module type F1 = sig + val four : 'a 'b 'c 'd . 'a -> 'b -> 'c -> 'd -> 'a * 'b * 'c * 'd +end +[%%expect{| +module type F1 = sig val four : 'a -> 'b -> 'c -> 'd -> 'a * 'b * 'c * 'd end +|}] +;; +module type F2 = sig + val four : 'a 'b 'd . 'a -> 'b -> 'c -> 'd -> 'a * 'b * 'c * 'd +end +[%%expect{| +Line 2, characters 36-38: +2 | val four : 'a 'b 'd . 'a -> 'b -> 'c -> 'd -> 'a * 'b * 'c * 'd + ^^ +Error: The type variable 'c is unbound in this type declaration. +|}] + + +(* Explicit quantifiers may also be used in external definitions *) +module Ident : sig + external identity : 'a . 'a -> 'a = "%identity" +end = struct + external identity : 'a . 'a -> 'a = "%identity" +end +[%%expect{| +module Ident : sig external identity : 'a -> 'a = "%identity" end +|}] + + +(* Explicit quantifiers may also be used in GADTs *) +type g1 = Foo : 'a * ('a -> unit) -> g1 +type g2 = g1 = Foo : 'a . 'a * ('a -> unit) -> g2 +type g3 = g2 = Foo : 'b 'c 'd . 'd * ('d -> unit) -> g3 +let intro = Foo (5, print_int) +let elim (Foo (x, f)) = f x +[%%expect{| +type g1 = Foo : 'a * ('a -> unit) -> g1 +type g2 = g1 = Foo : 'a * ('a -> unit) -> g2 +type g3 = g2 = Foo : 'd * ('d -> unit) -> g3 +val intro : g3 = Foo (, ) +val elim : g3 -> unit = +|}] + +(* In GADT syntax, all type variables must be bound, even parameters *) +type 'a t = + | Ok1 : 'b 'a . 'a -> 'a t + | Ok2 of 'a + | Bad : 'b . 'a -> 'a t +[%%expect{| +Line 4, characters 15-17: +4 | | Bad : 'b . 'a -> 'a t + ^^ +Error: The type variable 'a is unbound in this type declaration. +|}] diff --git a/ocaml/testsuite/tests/typing-misc/polyvars.ml b/ocaml/testsuite/tests/typing-misc/polyvars.ml index e5647f61aff..a4387144097 100644 --- a/ocaml/testsuite/tests/typing-misc/polyvars.ml +++ b/ocaml/testsuite/tests/typing-misc/polyvars.ml @@ -197,3 +197,15 @@ Error: This recursive type is not regular. ('e, 'c, 'b, 'd, 'a) c = [ `C of ('e, 'c, 'b, 'd, 'a) a ] All uses need to match the definition for the recursive type to be regular. |}] + +(* PR 10762 *) +type a = int +type t = [ `A of a ] +let inspect: [< t ] -> unit = function + | `A 0 -> () + | `A _ -> () +[%%expect {| +type a = int +type t = [ `A of a ] +val inspect : [< `A of a & int ] -> unit = +|}] diff --git a/ocaml/testsuite/tests/typing-misc/pr6416.ml b/ocaml/testsuite/tests/typing-misc/pr6416.ml index 43edff68bbc..c7e797cd1d2 100644 --- a/ocaml/testsuite/tests/typing-misc/pr6416.ml +++ b/ocaml/testsuite/tests/typing-misc/pr6416.ml @@ -26,6 +26,8 @@ Error: Signature mismatch: val f : t/1 -> unit is not included in val f : t/2 -> unit + The type t/1 -> unit is not compatible with the type t/2 -> unit + Type t/1 is not compatible with type t/2 Line 6, characters 4-14: Definition of type t/1 Line 2, characters 2-12: @@ -52,9 +54,9 @@ Error: Signature mismatch: type u = A of t/2 Constructors do not match: A of t/1 - is not compatible with: + is not the same as: A of t/2 - The types are not equal. + The type t/1 is not equal to the type t/2 Line 4, characters 9-19: Definition of type t/1 Line 2, characters 2-11: @@ -83,11 +85,13 @@ Error: Signature mismatch: sig module A : functor (X : s) -> sig end end In module A: Modules do not match: - functor (X : s/1) -> sig end + functor (X : s/1) -> ... is not included in - functor (X : s/2) -> sig end - At position module A(X : ) : ... - Modules do not match: s/2 is not included in s/1 + functor (X : s/2) -> ... + Module types do not match: + s/1 + does not include + s/2 Line 5, characters 6-19: Definition of module type s/1 Line 2, characters 2-15: @@ -119,9 +123,9 @@ Error: Signature mismatch: type t = A of T/2.t Constructors do not match: A of T/1.t - is not compatible with: + is not the same as: A of T/2.t - The types are not equal. + The type T/1.t is not equal to the type T/2.t Line 5, characters 6-34: Definition of module T/1 Line 2, characters 2-30: @@ -148,6 +152,9 @@ Error: Signature mismatch: val f : (module s/1) -> t/2 -> t/1 is not included in val f : (module s/2) -> t/2 -> t/2 + The type (module s/1) -> t/2 -> t/1 is not compatible with the type + (module s/2) -> t/2 -> t/2 + Type (module s/1) is not compatible with type (module s/2) Line 5, characters 23-33: Definition of type t/1 Line 3, characters 2-12: @@ -178,6 +185,9 @@ Error: Signature mismatch: val f : a/2 -> 'a -> a/1 is not included in val f : a/2 -> (module a) -> a/2 + The type a/2 -> (module a) -> a/1 is not compatible with the type + a/2 -> (module a) -> a/2 + Type a/1 is not compatible with type a/2 Line 5, characters 12-22: Definition of type a/1 Line 3, characters 2-12: @@ -209,8 +219,8 @@ Error: Signature mismatch: class b : a does not match class b : a/2 - The first class type has no method m The public method c cannot be hidden + The first class type has no method m Line 5, characters 4-74: Definition of class type a/1 Line 2, characters 2-36: @@ -307,7 +317,7 @@ Error: Signature mismatch: does not match class type c = object method m : t/1 end The method m has type t/2 but is expected to have type t/1 - Type t/2 is not compatible with type t/1 = K.t + Type t/2 is not equal to type t/1 = K.t Line 12, characters 4-10: Definition of type t/1 Line 9, characters 2-8: @@ -331,6 +341,7 @@ Error: Signature mismatch: type a = M/1.t is not included in type a = M/2.t + The type M/1.t = M/2.M.t is not equal to the type M/2.t Line 2, characters 14-42: Definition of module M/1 File "_none_", line 1: @@ -364,6 +375,9 @@ Error: Signature mismatch: val f : t/2 -> t/3 -> t/4 -> t/1 is not included in val f : t/1 -> t/1 -> t/1 -> t/1 + The type t/2 -> t/3 -> t/4 -> t/1 is not compatible with the type + t/1 -> t/1 -> t/1 -> t/1 + Type t/2 is not compatible with type t/1 Line 4, characters 0-10: Definition of type t/1 Line 1, characters 0-10: diff --git a/ocaml/testsuite/tests/typing-misc/pr6634.ml b/ocaml/testsuite/tests/typing-misc/pr6634.ml index 3e1daa8218e..d86d88d4092 100644 --- a/ocaml/testsuite/tests/typing-misc/pr6634.ml +++ b/ocaml/testsuite/tests/typing-misc/pr6634.ml @@ -23,8 +23,11 @@ Error: Signature mismatch: type t = [ `T of t/2 ] is not included in type t = [ `T of t/1 ] - Line 1, characters 0-12: - Definition of type t/1 + The type [ `T of t/1 ] is not equal to the type [ `T of t/2 ] + Type t/1 = [ `T of t/1 ] is not equal to type t/2 = int + Types for tag `T are incompatible Line 4, characters 2-20: + Definition of type t/1 + Line 1, characters 0-12: Definition of type t/2 |}] diff --git a/ocaml/testsuite/tests/typing-misc/pr7103.ml b/ocaml/testsuite/tests/typing-misc/pr7103.ml index 524ca3f7631..8156462392f 100644 --- a/ocaml/testsuite/tests/typing-misc/pr7103.ml +++ b/ocaml/testsuite/tests/typing-misc/pr7103.ml @@ -24,8 +24,8 @@ Line 1, characters 27-28: 1 | let _ = fun (x : a t) -> f x;; ^ Error: This expression has type a t but an expression was expected of type - (< .. > as 'a) t - Type a is not compatible with type < .. > as 'a + < .. > t + Type a is not compatible with type < .. > |}];; let _ = fun (x : a t) -> g x;; @@ -34,8 +34,8 @@ Line 1, characters 27-28: 1 | let _ = fun (x : a t) -> g x;; ^ Error: This expression has type a t but an expression was expected of type - ([< `b ] as 'a) t - Type a is not compatible with type [< `b ] as 'a + [< `b ] t + Type a is not compatible with type [< `b ] |}];; let _ = fun (x : a t) -> h x;; @@ -44,6 +44,6 @@ Line 1, characters 27-28: 1 | let _ = fun (x : a t) -> h x;; ^ Error: This expression has type a t but an expression was expected of type - ([> `b ] as 'a) t - Type a is not compatible with type [> `b ] as 'a + [> `b ] t + Type a is not compatible with type [> `b ] |}];; diff --git a/ocaml/testsuite/tests/typing-misc/pr7668_bad.ml b/ocaml/testsuite/tests/typing-misc/pr7668_bad.ml index 95b64fb5042..e7134886960 100644 --- a/ocaml/testsuite/tests/typing-misc/pr7668_bad.ml +++ b/ocaml/testsuite/tests/typing-misc/pr7668_bad.ml @@ -89,4 +89,12 @@ Error: Signature mismatch: [> `B of [> `BA | `BB of int list ] | `C of unit ] is not included in val a : t -> t + The type + [ `A of int | `B of [ `BA | `BB of unit list ] | `C of unit ] -> + [> `B of [> `BA | `BB of int list ] | `C of unit ] + is not compatible with the type t -> t + Type [> `B of [> `BA | `BB of int list ] | `C of unit ] + is not compatible with type + t = [ `A of int | `B of [ `BA | `BB of unit list ] | `C of unit ] + Types for tag `BB are incompatible |}] diff --git a/ocaml/testsuite/tests/typing-misc/pr7937.ml b/ocaml/testsuite/tests/typing-misc/pr7937.ml index 731252b2b95..af812700fc7 100644 --- a/ocaml/testsuite/tests/typing-misc/pr7937.ml +++ b/ocaml/testsuite/tests/typing-misc/pr7937.ml @@ -12,15 +12,6 @@ Line 3, characters 35-39: ^^^^ Error: This expression has type bool but an expression was expected of type ([< `X of int & 'a ] as 'a) r - Types for tag `X are incompatible -|}, Principal{| -type 'a r = 'a constraint 'a = [< `X of int & 'a ] -Line 3, characters 35-39: -3 | let f: 'a. 'a r -> 'a r = fun x -> true;; - ^^^^ -Error: This expression has type bool but an expression was expected of type - ([< `X of 'b & 'a & 'c & 'd & 'e ] as 'a) r - Types for tag `X are incompatible |}] let g: 'a. 'a r -> 'a r = fun x -> { contents = 0 };; @@ -30,15 +21,6 @@ Line 1, characters 35-51: ^^^^^^^^^^^^^^^^ Error: This expression has type int ref but an expression was expected of type ([< `X of int & 'a ] as 'a) r - Types for tag `X are incompatible -|}, Principal{| -Line 1, characters 35-51: -1 | let g: 'a. 'a r -> 'a r = fun x -> { contents = 0 };; - ^^^^^^^^^^^^^^^^ -Error: This expression has type int ref - but an expression was expected of type - ([< `X of 'b & 'a & 'c & 'd & 'e ] as 'a) r - Types for tag `X are incompatible |}] let h: 'a. 'a r -> _ = function true | false -> ();; @@ -46,10 +28,8 @@ let h: 'a. 'a r -> _ = function true | false -> ();; Line 1, characters 32-36: 1 | let h: 'a. 'a r -> _ = function true | false -> ();; ^^^^ -Error: This pattern matches values of type bool - but a pattern was expected which matches values of type - ([< `X of int & 'a ] as 'a) r - Types for tag `X are incompatible +Error: This pattern should not be a boolean literal, the expected type is + ([< `X of int & 'a ] as 'a) r |}] @@ -58,8 +38,6 @@ let i: 'a. 'a r -> _ = function { contents = 0 } -> ();; Line 1, characters 32-48: 1 | let i: 'a. 'a r -> _ = function { contents = 0 } -> ();; ^^^^^^^^^^^^^^^^ -Error: This pattern matches values of type int ref - but a pattern was expected which matches values of type - ([< `X of int & 'a ] as 'a) r - Types for tag `X are incompatible +Error: This pattern should not be a record, the expected type is + ([< `X of int & 'a ] as 'a) r |}] diff --git a/ocaml/testsuite/tests/typing-misc/pr8548_split.ml b/ocaml/testsuite/tests/typing-misc/pr8548_split.ml index 65f9a00cfeb..751dfa56033 100644 --- a/ocaml/testsuite/tests/typing-misc/pr8548_split.ml +++ b/ocaml/testsuite/tests/typing-misc/pr8548_split.ml @@ -1,5 +1,5 @@ (* TEST -files = "mapping.ml range_intf.ml ranged_intf.ml range.ml ranged.ml" +readonly_files = "mapping.ml range_intf.ml ranged_intf.ml range.ml ranged.ml" * setup-ocamlc.byte-build-env ** ocamlc.byte flags = "-no-alias-deps -w -49 -o Pr8548__Mapping" diff --git a/ocaml/testsuite/tests/typing-misc/printing.ml b/ocaml/testsuite/tests/typing-misc/printing.ml index 4c6cee131f8..d0ddffeab73 100644 --- a/ocaml/testsuite/tests/typing-misc/printing.ml +++ b/ocaml/testsuite/tests/typing-misc/printing.ml @@ -96,12 +96,12 @@ Line 3, characters 22-23: ^ Error: This expression has type t1 but an expression was expected of type t2 The method m has type 'c. 'c * ('a * < m : 'c. 'b >) as 'b, - but the expected method type was 'a. 'a * ('a * < m : 'a. 'b >) as 'b + but the expected method type was 'a. 'a * ('a * < m : 'a. 'd >) as 'd The universal variable 'a would escape its scope |}] (* #9739 - Recursive occurence checks are only done on type variables. + Recursive occurrence checks are only done on type variables. However, we are not guaranteed to still have a type variable when printing. *) @@ -116,3 +116,25 @@ Line 4, characters 26-27: Error: This expression has type int but an expression was expected of type 'a -> 'b |}] + + +(* PR#8917 + In nested recursive definitions, we have to remember all recursive items + under definitions, not just the last one + *) + +module RecMod = struct + module A= struct end + module type s = sig + module rec A: sig type t end + and B: sig type t = A.t end + end +end +[%%expect {| +module RecMod : + sig + module A : sig end + module type s = + sig module rec A : sig type t end and B : sig type t = A.t end end + end +|}] diff --git a/ocaml/testsuite/tests/typing-misc/records.ml b/ocaml/testsuite/tests/typing-misc/records.ml index 51623ef2cf5..5f0a486a4d4 100644 --- a/ocaml/testsuite/tests/typing-misc/records.ml +++ b/ocaml/testsuite/tests/typing-misc/records.ml @@ -137,8 +137,7 @@ Error: Unbound record field Complex.z Line 1, characters 2-6: 1 | { true with contents = 0 };; ^^^^ -Error: This expression has type bool but an expression was expected of type - 'a ref +Error: This expression has type bool which is not a record type. |}];; type ('a, 'b) t = { fst : 'a; snd : 'b };; @@ -198,7 +197,8 @@ Line 1, characters 0-40: ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This variant or record definition does not match that of type (int, [> `A ]) def - Their constraints differ. + Their parameters differ + The type int is not equal to the type 'a |}] type ('a,'b) kind = ('a, 'b) def = A constraint 'b = [> `A];; @@ -221,7 +221,7 @@ Line 2, characters 0-37: Error: This variant or record definition does not match that of type d Fields do not match: y : int; - is not compatible with: + is not the same as: mutable y : int; This is mutable and the original is not. |}] @@ -232,7 +232,7 @@ Line 1, characters 0-28: 1 | type missing = d = { x:int } ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This variant or record definition does not match that of type d - The field y is only present in the original definition. + An extra field, y, is provided in the original definition. |}] type wrong_type = d = {x:float} @@ -241,19 +241,22 @@ Line 1, characters 0-31: 1 | type wrong_type = d = {x:float} ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This variant or record definition does not match that of type d - Fields do not match: + 1. Fields do not match: x : int; - is not compatible with: + is not the same as: x : float; - The types are not equal. + The type int is not equal to the type float + 2. An extra field, y, is provided in the original definition. |}] -type unboxed = d = {x:float} [@@unboxed] +type mono = {foo:int} +type unboxed = mono = {foo:int} [@@unboxed] [%%expect{| -Line 1, characters 0-40: -1 | type unboxed = d = {x:float} [@@unboxed] - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This variant or record definition does not match that of type d +type mono = { foo : int; } +Line 2, characters 0-43: +2 | type unboxed = mono = {foo:int} [@@unboxed] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type mono Their internal representations differ: this definition uses unboxed representation. |}] @@ -264,5 +267,5 @@ Line 1, characters 0-30: 1 | type perm = d = {y:int; x:int} ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This variant or record definition does not match that of type d - Fields number 1 have different names, x and y. + Fields x and y have been swapped. |}] diff --git a/ocaml/testsuite/tests/typing-misc/typecore_empty_polyvariant_error.ml b/ocaml/testsuite/tests/typing-misc/typecore_empty_polyvariant_error.ml index 11c23d9bb88..9b4624d3e25 100644 --- a/ocaml/testsuite/tests/typing-misc/typecore_empty_polyvariant_error.ml +++ b/ocaml/testsuite/tests/typing-misc/typecore_empty_polyvariant_error.ml @@ -1,5 +1,5 @@ (* TEST - files="empty_ppx.ml" + readonly_files = "empty_ppx.ml" * setup-ocamlc.byte-build-env ** ocamlc.byte with ocamlcommon all_modules="empty_ppx.ml" diff --git a/ocaml/testsuite/tests/typing-misc/typecore_errors.ml b/ocaml/testsuite/tests/typing-misc/typecore_errors.ml index 9b00a4f6925..d5a3e8c7d17 100644 --- a/ocaml/testsuite/tests/typing-misc/typecore_errors.ml +++ b/ocaml/testsuite/tests/typing-misc/typecore_errors.ml @@ -74,18 +74,18 @@ Error: Uninterpreted extension 'ext'. let rec f x = ( (), () : _ -> _ -> _ ) [%%expect{| -Line 3, characters 14-38: +Line 3, characters 16-22: 3 | let rec f x = ( (), () : _ -> _ -> _ ) - ^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^ Error: This expression has type 'a * 'b but an expression was expected of type 'c -> 'd -> 'e |}] let rec g x = ( ((), ()) : _ -> _ :> _ ) [%%expect{| -Line 1, characters 14-40: +Line 1, characters 16-24: 1 | let rec g x = ( ((), ()) : _ -> _ :> _ ) - ^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^^^ Error: This expression has type 'a * 'b but an expression was expected of type 'c -> 'd |}] diff --git a/ocaml/testsuite/tests/typing-misc/unbound_type_variables.ml b/ocaml/testsuite/tests/typing-misc/unbound_type_variables.ml new file mode 100644 index 00000000000..c00d0360796 --- /dev/null +++ b/ocaml/testsuite/tests/typing-misc/unbound_type_variables.ml @@ -0,0 +1,61 @@ +(* TEST + * expect +*) + +type synonym = 'a -> 'a + +[%%expect{| +Line 1, characters 15-17: +1 | type synonym = 'a -> 'a + ^^ +Error: The type variable 'a is unbound in this type declaration. +|}] + +type record = { contents: 'a } + +[%%expect{| +Line 1, characters 26-28: +1 | type record = { contents: 'a } + ^^ +Error: The type variable 'a is unbound in this type declaration. +|}] + +type wrapper = Wrapper of 'a + +[%%expect{| +Line 1, characters 26-28: +1 | type wrapper = Wrapper of 'a + ^^ +Error: The type variable 'a is unbound in this type declaration. +|}] + +(* This type secretly has a type variable in it *) +type polyvariant = [> `C] + +[%%expect{| +Line 1, characters 0-25: +1 | type polyvariant = [> `C] + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: A type variable is unbound in this type declaration. + In type [> `C ] as 'a the variable 'a is unbound +|}] + +type 'a only_one = 'a * 'b + +[%%expect{| +Line 1, characters 24-26: +1 | type 'a only_one = 'a * 'b + ^^ +Error: The type variable 'b is unbound in this type declaration. +|}] + +type extensible = .. +type extensible += Extension of 'a + +[%%expect{| +type extensible = .. +Line 2, characters 32-34: +2 | type extensible += Extension of 'a + ^^ +Error: The type variable 'a is unbound in this type declaration. +|}] diff --git a/ocaml/testsuite/tests/typing-misc/variant.ml b/ocaml/testsuite/tests/typing-misc/variant.ml index d8356cd819e..b48142cd6da 100644 --- a/ocaml/testsuite/tests/typing-misc/variant.ml +++ b/ocaml/testsuite/tests/typing-misc/variant.ml @@ -25,6 +25,7 @@ Error: Signature mismatch: type t = X.t = A | B is not included in type t = int * bool + The type X.t is not equal to the type int * bool |}];; @@ -65,7 +66,8 @@ Line 1, characters 0-41: ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This variant or record definition does not match that of type (int, [> `A ]) def - Their constraints differ. + Their parameters differ + The type int is not equal to the type 'a |}] type ('a,'b) kind = ('a, 'b) def = {a:int} constraint 'b = [> `A];; @@ -87,7 +89,7 @@ Line 3, characters 0-27: 3 | type missing = d = X of int ^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This variant or record definition does not match that of type d - The constructor Y is only present in the original definition. + An extra constructor, Y, is provided in the original definition. |}] type wrong_type = d = X of float @@ -96,19 +98,22 @@ Line 1, characters 0-32: 1 | type wrong_type = d = X of float ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This variant or record definition does not match that of type d - Constructors do not match: + 1. Constructors do not match: X of int - is not compatible with: + is not the same as: X of float - The types are not equal. + The type int is not equal to the type float + 2. An extra constructor, Y, is provided in the original definition. |}] -type unboxed = d = X of float [@@unboxed] +type mono = Foo of float +type unboxed = mono = Foo of float [@@unboxed] [%%expect{| -Line 1, characters 0-41: -1 | type unboxed = d = X of float [@@unboxed] - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This variant or record definition does not match that of type d +type mono = Foo of float +Line 2, characters 0-46: +2 | type unboxed = mono = Foo of float [@@unboxed] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type mono Their internal representations differ: this definition uses unboxed representation. |}] @@ -119,7 +124,7 @@ Line 1, characters 0-35: 1 | type perm = d = Y of int | X of int ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Error: This variant or record definition does not match that of type d - Constructors number 1 have different names, X and Y. + Constructors X and Y have been swapped. |}] module M : sig @@ -143,7 +148,7 @@ Error: Signature mismatch: type t = Foo of int Constructors do not match: Foo : int -> t - is not compatible with: + is not the same as: Foo of int The first has explicit return type and the second doesn't. |}] diff --git a/ocaml/testsuite/tests/typing-misc/wrong_kind.ml b/ocaml/testsuite/tests/typing-misc/wrong_kind.ml new file mode 100644 index 00000000000..76d1a07688a --- /dev/null +++ b/ocaml/testsuite/tests/typing-misc/wrong_kind.ml @@ -0,0 +1,249 @@ +(* TEST + * expect +*) + +module Constr = struct + type t = A | B | C + + let get _ _ = A + + let put f = ignore (f () : t) +end + +module Record = struct + type t = { a : int; b : int; c : int } + + let get _ _ = { a = 0; b = 0; c = 0 } + + let put f = ignore (f () : t) +end + +module Bool = struct + type t = true | false + + let get _ _ = true + + let put f = ignore (f () : t) +end + +module List = struct + type 'a t = [] | (::) of 'a * 'a t + + let get _ _ = [] + + let put f = ignore (f () : int t) +end + +module Unit = struct + [@@@warning "-redefining-unit"] + type t = () + + let get _ _ = () + + let put f = ignore (f (() : unit) : t) +end;; +[%%expect{| +module Constr : + sig + type t = A | B | C + val get : 'a -> 'b -> t + val put : (unit -> t) -> unit + end +module Record : + sig + type t = { a : int; b : int; c : int; } + val get : 'a -> 'b -> t + val put : (unit -> t) -> unit + end +module Bool : + sig + type t = true | false + val get : 'a -> 'b -> t + val put : (unit -> t) -> unit + end +module List : + sig + type 'a t = [] | (::) of 'a * 'a t + val get : 'a -> 'b -> 'c t + val put : (unit -> int t) -> unit + end +module Unit : + sig type t = () val get : 'a -> 'b -> t val put : (unit -> t) -> unit end +|}] + +let () = + match Constr.get () with + | A | B | C -> ();; +[%%expect{| +Line 3, characters 4-5: +3 | | A | B | C -> ();; + ^ +Error: This pattern should not be a constructor, the expected type is + 'a -> Constr.t +|}] + +let () = + match Record.get () with + | { a; _ } -> ();; +[%%expect{| +Line 3, characters 4-12: +3 | | { a; _ } -> ();; + ^^^^^^^^ +Error: This pattern should not be a record, the expected type is + 'a -> Record.t +|}] + +let () = + match Bool.get () with + | true -> ();; +[%%expect{| +Line 3, characters 4-8: +3 | | true -> ();; + ^^^^ +Error: This pattern should not be a boolean literal, the expected type is + 'a -> Bool.t +|}] + +let () = + match Bool.get () with + | false -> ();; +[%%expect{| +Line 3, characters 4-9: +3 | | false -> ();; + ^^^^^ +Error: This pattern should not be a boolean literal, the expected type is + 'a -> Bool.t +|}] + +let () = + match List.get () with + | [] -> ();; +[%%expect{| +Line 3, characters 4-6: +3 | | [] -> ();; + ^^ +Error: This pattern should not be a list literal, the expected type is + 'a -> 'b List.t +|}] + +let () = + match List.get () with + | _ :: _ -> ();; +[%%expect{| +Line 3, characters 4-10: +3 | | _ :: _ -> ();; + ^^^^^^ +Error: This pattern should not be a list literal, the expected type is + 'a -> 'b List.t +|}] + +let () = + match Unit.get () with + | () -> ();; +[%%expect{| +Line 3, characters 4-6: +3 | | () -> ();; + ^^ +Error: This pattern should not be a unit literal, the expected type is + 'a -> Unit.t +|}] + +let () = Constr.put A;; +[%%expect{| +Line 1, characters 20-21: +1 | let () = Constr.put A;; + ^ +Error: This expression should not be a constructor, the expected type is + unit -> Constr.t +|}] + +let () = Record.put { a = 0; b = 0; c = 0 };; +[%%expect{| +Line 1, characters 20-43: +1 | let () = Record.put { a = 0; b = 0; c = 0 };; + ^^^^^^^^^^^^^^^^^^^^^^^ +Error: This expression should not be a record, the expected type is + unit -> Record.t +|}] + +let () = Bool.put true;; +[%%expect{| +Line 1, characters 18-22: +1 | let () = Bool.put true;; + ^^^^ +Error: This expression should not be a boolean literal, the expected type is + unit -> Bool.t +|}] + +let () = Bool.put false;; +[%%expect{| +Line 1, characters 18-23: +1 | let () = Bool.put false;; + ^^^^^ +Error: This expression should not be a boolean literal, the expected type is + unit -> Bool.t +|}] + +let () = List.put [];; +[%%expect{| +Line 1, characters 18-20: +1 | let () = List.put [];; + ^^ +Error: This expression should not be a list literal, the expected type is + unit -> int List.t +|}] + +let () = List.put (1 :: 2);; +[%%expect{| +Line 1, characters 18-26: +1 | let () = List.put (1 :: 2);; + ^^^^^^^^ +Error: This expression should not be a list literal, the expected type is + unit -> int List.t +|}] + +let () = Unit.put ();; +[%%expect{| +Line 1, characters 18-20: +1 | let () = Unit.put ();; + ^^ +Error: This expression should not be a unit literal, the expected type is + unit -> Unit.t +|}] + +let () = + ignore ((Record.get ()).a);; +[%%expect{| +Line 2, characters 10-25: +2 | ignore ((Record.get ()).a);; + ^^^^^^^^^^^^^^^ +Error: This expression has type 'a -> Record.t which is not a record type. +|}] + +let () = + (Record.get ()).a <- 5;; +[%%expect{| +Line 2, characters 2-17: +2 | (Record.get ()).a <- 5;; + ^^^^^^^^^^^^^^^ +Error: This expression has type 'a -> Record.t which is not a record type. +|}] + +let () = + ignore { (Record.get ()) with a = 5 };; +[%%expect{| +Line 2, characters 11-26: +2 | ignore { (Record.get ()) with a = 5 };; + ^^^^^^^^^^^^^^^ +Error: This expression has type 'a -> Record.t which is not a record type. +|}] + +let foo x = + Record.put { x with a = 5 };; +[%%expect{| +Line 2, characters 13-29: +2 | Record.put { x with a = 5 };; + ^^^^^^^^^^^^^^^^ +Error: This expression should not be a record, the expected type is + unit -> Record.t +|}] diff --git a/ocaml/testsuite/tests/typing-missing-cmi-2/test.ml b/ocaml/testsuite/tests/typing-missing-cmi-2/test.ml index 2ef1c6d38b9..3321ba46221 100644 --- a/ocaml/testsuite/tests/typing-missing-cmi-2/test.ml +++ b/ocaml/testsuite/tests/typing-missing-cmi-2/test.ml @@ -1,5 +1,5 @@ (* TEST -files = "foo.mli bar.mli baz.ml" +readonly_files = "foo.mli bar.mli baz.ml" * setup-ocamlc.byte-build-env ** ocamlc.byte module = "foo.mli" diff --git a/ocaml/testsuite/tests/typing-missing-cmi-3/middle.ml b/ocaml/testsuite/tests/typing-missing-cmi-3/middle.ml index 82e64582a51..23b2075eeb2 100644 --- a/ocaml/testsuite/tests/typing-missing-cmi-3/middle.ml +++ b/ocaml/testsuite/tests/typing-missing-cmi-3/middle.ml @@ -6,3 +6,10 @@ let g: (module Original.T) -> unit = fun _ -> () type pack1 = (module Original.T with type t = int) module type T = sig module M : Original.T end type pack2 = (module T with type M.t = int) + +(* Check the detection of type kind in type-directed disambiguation. *) +type r = Original.r = { x:unit } +let r = Original.r + +type s = Original.s = S +let s = Original.s diff --git a/ocaml/testsuite/tests/typing-missing-cmi-3/original.ml b/ocaml/testsuite/tests/typing-missing-cmi-3/original.ml index 04c6c5e931b..1fbf0b00b00 100644 --- a/ocaml/testsuite/tests/typing-missing-cmi-3/original.ml +++ b/ocaml/testsuite/tests/typing-missing-cmi-3/original.ml @@ -1,2 +1,8 @@ type 'a t = T module type T = sig type t end + +type r = { x:unit } +let r = { x = () } + +type s = S +let s = S diff --git a/ocaml/testsuite/tests/typing-missing-cmi-3/user.ml b/ocaml/testsuite/tests/typing-missing-cmi-3/user.ml index 9543db9d969..72b0559819c 100644 --- a/ocaml/testsuite/tests/typing-missing-cmi-3/user.ml +++ b/ocaml/testsuite/tests/typing-missing-cmi-3/user.ml @@ -1,6 +1,6 @@ (* TEST -files = "original.ml middle.ml" +readonly_files = "original.ml middle.ml" * setup-ocamlc.byte-build-env ** ocamlc.byte module = "original.ml" @@ -13,6 +13,7 @@ script = "rm -f original.cmi" #directory "ocamlc.byte";; +#load "original.cmo" #load "middle.cmo" let x:'a. 'a Middle.t = @@ -87,3 +88,14 @@ Line 2, characters 12-45: Error: Type Middle.pack2 = (module Middle.T with type M.t = int) is not a subtype of (module T2) |}] + +(* Check the detection of type kind in type-directed disambiguation . *) +let t = Middle.r.Middle.x +[%%expect {| +val t : unit = () +|}] + +let k = match Middle.s with Middle.S -> () +[%%expect {| +val k : unit = () +|}] diff --git a/ocaml/testsuite/tests/typing-missing-cmi/test.ml b/ocaml/testsuite/tests/typing-missing-cmi/test.ml index 087374e010a..b946a8c1cb7 100644 --- a/ocaml/testsuite/tests/typing-missing-cmi/test.ml +++ b/ocaml/testsuite/tests/typing-missing-cmi/test.ml @@ -1,24 +1,21 @@ (* TEST -files = "a.ml b.ml c.ml main.ml main_ok.ml" +readonly_files = "a.ml b.ml c.ml main.ml main_ok.ml" +subdirectories = "subdir" * setup-ocamlc.byte-build-env -** script -script = "mkdir -p subdir" -*** script -script = "cp ${test_source_directory}/subdir/m.ml subdir" -**** ocamlc.byte +** ocamlc.byte module = "subdir/m.ml" -***** ocamlc.byte +*** ocamlc.byte flags = "-I subdir" module = "a.ml" -****** ocamlc.byte +**** ocamlc.byte module = "b.ml" -******* ocamlc.byte +***** ocamlc.byte module = "c.ml" -******** ocamlc.byte +****** ocamlc.byte flags = "" module = "main_ok.ml" -********* ocamlc.byte +******* ocamlc.byte module = "main.ml" ocamlc_byte_exit_status = "2" -********** check-ocamlc.byte-output +******** check-ocamlc.byte-output *) diff --git a/ocaml/testsuite/tests/typing-modules-bugs/gatien_baron_20131019_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/gatien_baron_20131019_ok.ml index 1241d53c982..fea9becac8d 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/gatien_baron_20131019_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/gatien_baron_20131019_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr10661_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr10661_ok.ml new file mode 100644 index 00000000000..1dfa42f4342 --- /dev/null +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr10661_ok.ml @@ -0,0 +1,10 @@ +(* TEST +* setup-ocamlc.byte-build-env +** ocamlc.byte +*** check-ocamlc.byte-output +*) + +module M = struct + class row = object + end +end diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr10693_bad.compilers.reference b/ocaml/testsuite/tests/typing-modules-bugs/pr10693_bad.compilers.reference new file mode 100644 index 00000000000..c17d3aa0866 --- /dev/null +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr10693_bad.compilers.reference @@ -0,0 +1,55 @@ +File "pr10693_bad.ml", line 27, characters 26-27: +27 | module Bad (A : S') : S = A + ^ +Error: Signature mismatch: + Modules do not match: + sig val x : 'a option module M : Dep -> S end + is not included in + S + In module M: + Modules do not match: + Dep -> S + is not included in + functor (X : Dep) -> + sig + val x : X.t option + module M : functor (Y : Dep) -> sig val x : X.t option end + end + In module M: + Modules do not match: + S + is not included in + sig + val x : X.t option + module M : functor (Y : Dep) -> sig val x : X.t option end + end + In module M.M: + Modules do not match: + functor (X : Dep) -> + sig + val x : X.t option + module M : functor (Y : Dep) -> sig val x : X.t option end + end + is not included in + functor (Y : Dep) -> sig val x : X.t option end + In module M.M: + Modules do not match: + sig + val x : X/2.t option + module M : functor (Y : Dep) -> sig val x : X/2.t option end + end + is not included in + sig val x : X.t option end + In module M.M: + Values do not match: + val x : X/1.t option + is not included in + val x : X/2.t option + The type X/1.t option is not compatible with the type X/2.t option + Type X/1.t is not compatible with type X/2.t + File "_none_", line 1: + Definition of module X/1 + File "_none_", line 1: + Definition of module X/2 + File "pr10693_bad.ml", line 17, characters 6-24: Expected declaration + File "pr10693_bad.ml", line 15, characters 4-22: Actual declaration diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr10693_bad.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr10693_bad.ml new file mode 100644 index 00000000000..4e964c9e13b --- /dev/null +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr10693_bad.ml @@ -0,0 +1,46 @@ +(* TEST +flags = "-no-app-funct" +ocamlc_byte_exit_status = "2" +* setup-ocamlc.byte-build-env +** ocamlc.byte +*** check-ocamlc.byte-output +*) +module type Dep = sig type t val x : t end +module String = struct type t = string let x = "Forty Two" end +module Int = struct type t = int let x = 42 end + +module type S = sig + val x : 'a option + module M : functor (X : Dep) -> sig + val x : X.t option + module M : functor (Y : Dep) -> sig + val x : X.t option + end + end +end + +module type S' = sig + val x : 'a option + module M : functor (_ : Dep) -> S +end + +module Bad (A : S') : S = A + +module M = struct + let x = None + module M (_ : Dep) = struct + let x = None + module M (X : Dep) = struct + let x = Some X.x + module M (Y : Dep) = struct + let x = Some X.x + end + end + end +end + +module N = Bad(M) +module N' = N.M(String) +module N'' = N'.M(Int) + +let () = print_endline (Option.get N''.x) diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr5164_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr5164_ok.ml index 4837aac5f5b..9d8e5715194 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr5164_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr5164_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr51_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr51_ok.ml index 14c517fb8c3..740d9bcca69 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr51_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr51_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr5663_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr5663_ok.ml index 813c7de09e0..670869b8a5a 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr5663_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr5663_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr5914_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr5914_ok.ml index e5e7e8b9a05..a027c0b0909 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr5914_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr5914_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr6240_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr6240_ok.ml index fa166aa3ef2..ce0ef4de5fa 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr6240_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr6240_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr6293_bad.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr6293_bad.ml index d216e2dbef7..db937995131 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr6293_bad.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr6293_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr6427_bad.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr6427_bad.ml index d05baaf0f38..426c0369d57 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr6427_bad.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr6427_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr6485_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr6485_ok.ml index 641a3552ade..cf9a9469333 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr6485_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr6485_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr6513_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr6513_ok.ml index 5e3a8f06c3e..61487326046 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr6513_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr6513_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr6572_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr6572_ok.ml index 94cd21c5330..28f33d35206 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr6572_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr6572_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr6651_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr6651_ok.ml index c3adc8ca390..db48d15f175 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr6651_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr6651_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr6752_bad.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr6752_bad.ml index 9ee4b12df66..42d39e6afd5 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr6752_bad.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr6752_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr6752_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr6752_ok.ml index d3b0fdcd062..2d5ac02ad3b 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr6752_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr6752_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr6899_first_bad.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr6899_first_bad.ml index 82b9ca12593..d7c1f71a335 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr6899_first_bad.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr6899_first_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr6899_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr6899_ok.ml index 38d91053e14..95d0860c0b6 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr6899_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr6899_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr6899_second_bad.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr6899_second_bad.ml index 4a5635271c6..42d8bdde485 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr6899_second_bad.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr6899_second_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr6944_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr6944_ok.ml index 88c325a95b0..9ff8d3564e3 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr6944_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr6944_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr6954_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr6954_ok.ml index e72c47e207a..2970e4f3402 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr6954_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr6954_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr6981_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr6981_ok.ml index 0cc39261756..449e9dc754b 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr6981_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr6981_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr6982_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr6982_ok.ml index d3181a0afb9..47b65abba8a 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr6982_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr6982_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr6985_extended.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr6985_extended.ml new file mode 100644 index 00000000000..01faa3fe04f --- /dev/null +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr6985_extended.ml @@ -0,0 +1,30 @@ +(* TEST + * expect +*) + + + +module Root = struct + type u + and t = private < .. > +end + +module Trunk = struct + include Root + type t = A + type u +end + +module M: sig + module type s = module type of Trunk +end = struct + module type s = sig + type t = A + type u + end +end +[%%expect {| +module Root : sig type u and t = private < .. > end +module Trunk : sig type t = A type u end +module M : sig module type s = sig type t = A type u end end +|}] diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr6985_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr6985_ok.ml index 20ed0a6b613..043502dae99 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr6985_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr6985_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr6992_bad.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr6992_bad.ml index 21fea7f76f5..18733c706bb 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr6992_bad.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr6992_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr7036_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr7036_ok.ml index 011cc1b1966..305d2425a77 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr7036_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr7036_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr7082_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr7082_ok.ml index b73052e34eb..849427d44b7 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr7082_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr7082_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr7112_bad.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr7112_bad.ml index e67e0279e27..ffc634901fb 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr7112_bad.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr7112_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr7112_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr7112_ok.ml index 949d4ab55d9..666c604c56f 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr7112_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr7112_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr7152_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr7152_ok.ml index 2e70dabff44..eada285f761 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr7152_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr7152_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr7182_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr7182_ok.ml index c32d1d1169c..801348f9f60 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr7182_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr7182_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr7305_principal.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr7305_principal.ml index 045ab5aa760..3371e378861 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr7305_principal.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr7305_principal.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -principal -w +18+19 -warn-error A " +flags = " -principal -w +18+19 -warn-error +A " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr7321_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr7321_ok.ml index 73f40443ee5..9d217847388 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr7321_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr7321_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr7414_2_bad.compilers.reference b/ocaml/testsuite/tests/typing-modules-bugs/pr7414_2_bad.compilers.reference index e606767e3f4..c0bf22bacc1 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr7414_2_bad.compilers.reference +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr7414_2_bad.compilers.reference @@ -1,20 +1,19 @@ -File "pr7414_2_bad.ml", line 46, characters 28-34: +File "pr7414_2_bad.ml", line 46, characters 22-35: 46 | let module Ignore = Force(Choose) in - ^^^^^^ -Error: Signature mismatch: - Modules do not match: - functor () -> sig module Choice : T val r : '_weak1 list ref ref end - is not included in - functor () -> S - At position functor () -> - Modules do not match: - sig module Choice : T val r : '_weak1 list ref ref end - is not included in - S - At position functor () -> - Values do not match: - val r : '_weak1 list ref ref - is not included in - val r : Choice.t list ref ref - File "pr7414_2_bad.ml", line 29, characters 2-31: Expected declaration - File "pr7414_2_bad.ml", line 40, characters 8-9: Actual declaration + ^^^^^^^^^^^^^ +Error: Modules do not match: + functor () -> sig module Choice : T val r : '_weak1 list ref ref end + is not included in functor () -> S + Modules do not match: + sig module Choice : T val r : '_weak1 list ref ref end + is not included in + S + Values do not match: + val r : '_weak1 list ref ref + is not included in + val r : Choice.t list ref ref + The type '_weak1 list ref ref is not compatible with the type + Choice.t list ref ref + The type constructor Choice.t would escape its scope + File "pr7414_2_bad.ml", line 29, characters 2-31: Expected declaration + File "pr7414_2_bad.ml", line 40, characters 8-9: Actual declaration diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr7414_2_bad.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr7414_2_bad.ml index e3cfca5fed0..1926ae4425d 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr7414_2_bad.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr7414_2_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr7414_bad.compilers.reference b/ocaml/testsuite/tests/typing-modules-bugs/pr7414_bad.compilers.reference index 5bdae1de0db..35a31821d23 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr7414_bad.compilers.reference +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr7414_bad.compilers.reference @@ -1,20 +1,19 @@ -File "pr7414_bad.ml", line 52, characters 22-28: +File "pr7414_bad.ml", line 52, characters 16-29: 52 | module Ignore = Force(Choose) - ^^^^^^ -Error: Signature mismatch: - Modules do not match: - functor () -> sig module Choice : T val r : '_weak1 list ref ref end - is not included in - functor () -> S - At position functor () -> - Modules do not match: - sig module Choice : T val r : '_weak1 list ref ref end - is not included in - S - At position functor () -> - Values do not match: - val r : '_weak1 list ref ref - is not included in - val r : Choice.t list ref ref - File "pr7414_bad.ml", line 38, characters 2-31: Expected declaration - File "pr7414_bad.ml", line 33, characters 6-7: Actual declaration + ^^^^^^^^^^^^^ +Error: Modules do not match: + functor () -> sig module Choice : T val r : '_weak1 list ref ref end + is not included in functor () -> S + Modules do not match: + sig module Choice : T val r : '_weak1 list ref ref end + is not included in + S + Values do not match: + val r : '_weak1 list ref ref + is not included in + val r : Choice.t list ref ref + The type '_weak1 list ref ref is not compatible with the type + Choice.t list ref ref + The type constructor Choice.t would escape its scope + File "pr7414_bad.ml", line 38, characters 2-31: Expected declaration + File "pr7414_bad.ml", line 33, characters 6-7: Actual declaration diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr7414_bad.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr7414_bad.ml index c95e0ac1a0e..7bc294599d9 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr7414_bad.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr7414_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr7519_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr7519_ok.ml index 1db6bc3d7ac..c6278ce3927 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr7519_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr7519_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr7601_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr7601_ok.ml index 9b3cf39b937..80003920141 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr7601_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr7601_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr7601a_ok.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr7601a_ok.ml index fd046d8abab..ce2b8bb71b5 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr7601a_ok.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr7601a_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-modules-bugs/pr9695_bad.ml b/ocaml/testsuite/tests/typing-modules-bugs/pr9695_bad.ml index 191248a21c3..86ea3f8cdf2 100644 --- a/ocaml/testsuite/tests/typing-modules-bugs/pr9695_bad.ml +++ b/ocaml/testsuite/tests/typing-modules-bugs/pr9695_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a -no-alias-deps" +flags = " -w -a -no-alias-deps" ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-modules/Test.ml b/ocaml/testsuite/tests/typing-modules/Test.ml index 6287a6e6f60..f87fa521d15 100644 --- a/ocaml/testsuite/tests/typing-modules/Test.ml +++ b/ocaml/testsuite/tests/typing-modules/Test.ml @@ -97,9 +97,9 @@ Line 3, characters 23-33: Error: This variant or record definition does not match that of type u Constructors do not match: X of bool - is not compatible with: + is not the same as: X of int - The types are not equal. + The type bool is not equal to the type int |}];; (* PR#5815 *) @@ -147,7 +147,7 @@ Error: Signature mismatch: type t += E Constructors do not match: E of int - is not compatible with: + is not the same as: E They have different arities. |}];; @@ -168,9 +168,9 @@ Error: Signature mismatch: type t += E of char Constructors do not match: E of int - is not compatible with: + is not the same as: E of char - The types are not equal. + The type int is not equal to the type char |}];; module M : sig type t += C of int end = struct type t += E of int end;; @@ -207,7 +207,7 @@ Error: Signature mismatch: type t += E of { x : int; } Constructors do not match: E of int - is not compatible with: + is not the same as: E of { x : int; } The second uses inline records and the first doesn't. |}];; diff --git a/ocaml/testsuite/tests/typing-modules/aliases.ml b/ocaml/testsuite/tests/typing-modules/aliases.ml index 440498b5aa1..cc9892d14ad 100644 --- a/ocaml/testsuite/tests/typing-modules/aliases.ml +++ b/ocaml/testsuite/tests/typing-modules/aliases.ml @@ -691,9 +691,9 @@ Error: Module type declarations do not match: does not match module type A = sig module M = F(List) end At position module type A = - Modules do not match: + Module types do not match: sig module M = F(List) end - is not included in + is not equal to sig module M = F(List) end At position module type A = sig module M : end Module F(List) cannot be aliased diff --git a/ocaml/testsuite/tests/typing-modules/anonymous.ml b/ocaml/testsuite/tests/typing-modules/anonymous.ml index c250e922f1f..7d006eddd91 100644 --- a/ocaml/testsuite/tests/typing-modules/anonymous.ml +++ b/ocaml/testsuite/tests/typing-modules/anonymous.ml @@ -29,7 +29,7 @@ end ;; [%%expect{| module type S = - sig module rec A : sig type t = B/2.t end and B : sig type t end end + sig module rec A : sig type t = B.t end and B : sig type t end end |}] let f (module _ : S) = () diff --git a/ocaml/testsuite/tests/typing-modules/applicative_functor_type.ml b/ocaml/testsuite/tests/typing-modules/applicative_functor_type.ml index 7d78e25b702..e23bed94cc4 100644 --- a/ocaml/testsuite/tests/typing-modules/applicative_functor_type.ml +++ b/ocaml/testsuite/tests/typing-modules/applicative_functor_type.ml @@ -19,13 +19,11 @@ type t = Set.Make(M).t Line 1, characters 9-22: 1 | type t = Set.Make(M).t ^^^^^^^^^^^^^ -Error: The type of M does not match Set.Make's parameter - Modules do not match: - sig type t = M.t val equal : 'a -> 'a -> bool end - is not included in - Set.OrderedType - The value `compare' is required but not provided - File "set.mli", line 57, characters 4-31: Expected declaration +Error: Modules do not match: + sig type t = M.t val equal : 'a -> 'a -> bool end + is not included in Set.OrderedType + The value `compare' is required but not provided + File "set.mli", line 57, characters 4-31: Expected declaration |} ] @@ -43,15 +41,14 @@ type t = F(M).t Line 1, characters 9-15: 1 | type t = F(M).t ^^^^^^ -Error: The type of M does not match F's parameter - Modules do not match: - sig type t = M.t val equal : 'a -> 'a -> bool end - is not included in - sig type t = M.t val equal : unit end - Values do not match: - val equal : 'a -> 'a -> bool - is not included in - val equal : unit +Error: Modules do not match: + sig type t = M.t val equal : 'a -> 'a -> bool end + is not included in sig type t = M.t val equal : unit end + Values do not match: + val equal : 'a -> 'a -> bool + is not included in + val equal : unit + The type 'a -> 'a -> bool is not compatible with the type unit |} ] diff --git a/ocaml/testsuite/tests/typing-modules/extension_constructors_errors_test.ml b/ocaml/testsuite/tests/typing-modules/extension_constructors_errors_test.ml index fb4b914f1d9..b37f9d17a26 100644 --- a/ocaml/testsuite/tests/typing-modules/extension_constructors_errors_test.ml +++ b/ocaml/testsuite/tests/typing-modules/extension_constructors_errors_test.ml @@ -21,7 +21,7 @@ Error: Signature mismatch: type t += F Constructors do not match: F of int - is not compatible with: + is not the same as: F They have different arities. |}];; @@ -40,5 +40,22 @@ Error: Signature mismatch: type t += private A is not included in type t += A - A private type would be revealed. + Private extension constructor(s) would be revealed. +|}];; + +module M2 : sig type t += A end = struct type t += private A | B end;; +[%%expect{| +Line 1, characters 34-68: +1 | module M2 : sig type t += A end = struct type t += private A | B end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Signature mismatch: + Modules do not match: + sig type t += private A | B end + is not included in + sig type t += A end + Extension declarations do not match: + type t += private A + is not included in + type t += A + Private extension constructor(s) would be revealed. |}];; diff --git a/ocaml/testsuite/tests/typing-modules/functors.ml b/ocaml/testsuite/tests/typing-modules/functors.ml new file mode 100644 index 00000000000..02aa1cd72f4 --- /dev/null +++ b/ocaml/testsuite/tests/typing-modules/functors.ml @@ -0,0 +1,1747 @@ +(* TEST + * expect +*) + + + +module type a +module type b +module type c + +module type x = sig type x end +module type y = sig type y end +module type z = sig type z end + + +module type empty = sig end + +module Empty = struct end +module X: x = struct type x end +module Y: y = struct type y end +module Z: z = struct type z end +module F(X:x)(Y:y)(Z:z) = struct end +[%%expect {| +module type a +module type b +module type c +module type x = sig type x end +module type y = sig type y end +module type z = sig type z end +module type empty = sig end +module Empty : sig end +module X : x +module Y : y +module Z : z +module F : functor (X : x) (Y : y) (Z : z) -> sig end +|}] + + +module M = F(X)(Z) +[%%expect {| +Line 1, characters 11-18: +1 | module M = F(X)(Z) + ^^^^^^^ +Error: The functor application is ill-typed. + These arguments: + X Z + do not match these parameters: + functor (X : x) (Y : y) (Z : z) -> ... + 1. Module X matches the expected module type x + 2. An argument appears to be missing with module type y + 3. Module Z matches the expected module type z +|}] + +module type f = functor (X:empty)(Y:empty) -> empty +module F: f = + functor(X:empty)(Y:empty)(Z:empty) -> Empty +[%%expect {| +module type f = functor (X : empty) (Y : empty) -> empty +Line 3, characters 9-45: +3 | functor(X:empty)(Y:empty)(Z:empty) -> Empty + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Signature mismatch: + Modules do not match: + functor (X : empty) (Y : empty) (Z : empty) -> ... + is not included in + functor (X : empty) (Y : empty) -> ... + 1. Module types empty and empty match + 2. Module types empty and empty match + 3. An extra argument is provided of module type empty +|}] + +module type f = functor (X:a)(Y:b) -> c +module F:f = functor (X:a)(Y:b)(Z:c) -> Empty +[%%expect {| +module type f = functor (X : a) (Y : b) -> c +Line 2, characters 21-45: +2 | module F:f = functor (X:a)(Y:b)(Z:c) -> Empty + ^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Signature mismatch: + Modules do not match: + functor (X : a) (Y : b) (Z : c) -> ... + is not included in + functor (X : a) (Y : b) -> ... + 1. Module types a and a match + 2. Module types b and b match + 3. An extra argument is provided of module type c +|}] + +module M : sig module F: functor (X:sig end) -> sig end end = + struct + module F(X:sig type t end) = struct end + end +[%%expect {| +Lines 2-4, characters 2-5: +2 | ..struct +3 | module F(X:sig type t end) = struct end +4 | end +Error: Signature mismatch: + Modules do not match: + sig module F : functor (X : sig type t end) -> sig end end + is not included in + sig module F : functor (X : sig end) -> sig end end + In module F: + Modules do not match: + functor (X : $S1) -> ... + is not included in + functor (X : sig end) -> ... + Module types do not match: + $S1 = sig type t end + does not include + sig end + The type `t' is required but not provided +|}] + +module F(X:sig type t end) = struct end +module M = F(struct type x end) +[%%expect {| +module F : functor (X : sig type t end) -> sig end +Line 2, characters 11-31: +2 | module M = F(struct type x end) + ^^^^^^^^^^^^^^^^^^^^ +Error: Modules do not match: sig type x end is not included in sig type t end + The type `t' is required but not provided +|}] + +module F(X:sig type x end)(Y:sig type y end)(Z:sig type z end) = struct + type t = X of X.x | Y of Y.y | Z of Z.z +end +type u = F(X)(Z).t +[%%expect {| +module F : + functor (X : sig type x end) (Y : sig type y end) (Z : sig type z end) -> + sig type t = X of X.x | Y of Y.y | Z of Z.z end +Line 4, characters 9-18: +4 | type u = F(X)(Z).t + ^^^^^^^^^ +Error: The functor application F(X)(Z) is ill-typed. + These arguments: + X Z + do not match these parameters: + functor (X : ...) (Y : $T2) (Z : ...) -> ... + 1. Module X matches the expected module type + 2. An argument appears to be missing with module type + $T2 = sig type y end + 3. Module Z matches the expected module type +|}] + +module F()(X:sig type t end) = struct end +module M = F()() +[%%expect {| +module F : functor () (X : sig type t end) -> sig end +Line 2, characters 11-16: +2 | module M = F()() + ^^^^^ +Error: The functor application is ill-typed. + These arguments: + () () + do not match these parameters: + functor () (X : $T2) -> ... + 1. Module () matches the expected module type + 2. The functor was expected to be applicative at this position +|}] + +module M: sig + module F: functor(X:sig type x end)(X:sig type y end) -> sig end +end = struct + module F(X:sig type y end) = struct end +end +[%%expect {| +Lines 3-5, characters 6-3: +3 | ......struct +4 | module F(X:sig type y end) = struct end +5 | end +Error: Signature mismatch: + Modules do not match: + sig module F : functor (X : sig type y end) -> sig end end + is not included in + sig + module F : + functor (X : sig type x end) (X : sig type y end) -> sig end + end + In module F: + Modules do not match: + functor (X : $S2) -> ... + is not included in + functor (X : $T1) (X : $T2) -> ... + 1. An argument appears to be missing with module type + $T1 = sig type x end + 2. Module types $S2 and $T2 match +|}] + + +module F(Ctx: sig + module type t + module type u + module X:t + module Y:u +end) = struct + open Ctx + module F(A:t)(B:u) = struct end + module M = F(Y)(X) +end +[%%expect {| +Line 9, characters 13-20: +9 | module M = F(Y)(X) + ^^^^^^^ +Error: The functor application is ill-typed. + These arguments: + Ctx.Y Ctx.X + do not match these parameters: + functor (A : Ctx.t) (B : Ctx.u) -> ... + 1. Modules do not match: Ctx.Y : Ctx.u is not included in Ctx.t + 2. Modules do not match: Ctx.X : Ctx.t is not included in Ctx.u +|}] + +(** Too many arguments *) +module Ord = struct type t = unit let compare _ _ = 0 end +module M = Map.Make(Ord)(Ord) +[%%expect {| +module Ord : sig type t = unit val compare : 'a -> 'b -> int end +Line 2, characters 11-29: +2 | module M = Map.Make(Ord)(Ord) + ^^^^^^^^^^^^^^^^^^ +Error: The functor application is ill-typed. + These arguments: + Ord Ord + do not match these parameters: + functor (Ord : Map.OrderedType) -> ... + 1. The following extra argument is provided + Ord : sig type t = unit val compare : 'a -> 'b -> int end + 2. Module Ord matches the expected module type Map.OrderedType +|}] + + +(** Dependent types *) +(** Application side *) + +module F + (A:sig type x type y end) + (B:sig type x = A.x end) + (C:sig type y = A.y end) += struct end +module K = struct include X include Y end +module M = F(K)(struct type x = K.x end)( (* struct type z = K.y end *) ) +[%%expect {| +module F : + functor (A : sig type x type y end) (B : sig type x = A.x end) + (C : sig type y = A.y end) -> sig end +module K : sig type x = X.x type y = Y.y end +Line 10, characters 11-73: +10 | module M = F(K)(struct type x = K.x end)( (* struct type z = K.y end *) ) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The functor application is ill-typed. + These arguments: + K $S2 () + do not match these parameters: + functor (A : ...) (B : ...) (C : $T3) -> ... + 1. Module K matches the expected module type + 2. Module $S2 matches the expected module type + 3. The functor was expected to be applicative at this position +|}] + +module M = F(K)(struct type y = K.y end) +[%%expect {| +Line 1, characters 11-40: +1 | module M = F(K)(struct type y = K.y end) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The functor application is ill-typed. + These arguments: + K $S3 + do not match these parameters: + functor (A : ...) (B : $T2) (C : ...) -> ... + 1. Module K matches the expected module type + 2. An argument appears to be missing with module type + $T2 = sig type x = A.x end + 3. Module $S3 matches the expected module type +|}] + + +module M = + F + (struct include X include Y end) + (struct type x = K.x end) + (struct type yy = K.y end) +[%%expect {| +Lines 2-5, characters 2-30: +2 | ..F +3 | (struct include X include Y end) +4 | (struct type x = K.x end) +5 | (struct type yy = K.y end) +Error: The functor application is ill-typed. + These arguments: + $S1 $S2 $S3 + do not match these parameters: + functor (A : ...) (B : ...) (C : $T3) -> ... + 1. Module $S1 matches the expected module type + 2. Module $S2 matches the expected module type + 3. Modules do not match: + $S3 : sig type yy = K.y end + is not included in + $T3 = sig type y = A.y end + The type `y' is required but not provided +|}] + + +module M = struct + module N = struct + type x + type y + end +end + + +module Defs = struct + module X = struct type x = M.N.x end + module Y = struct type y = M.N.y end +end +module Missing_X = F(M.N)(Defs.Y) +[%%expect {| +module M : sig module N : sig type x type y end end +module Defs : + sig module X : sig type x = M.N.x end module Y : sig type y = M.N.y end end +Line 13, characters 19-33: +13 | module Missing_X = F(M.N)(Defs.Y) + ^^^^^^^^^^^^^^ +Error: The functor application is ill-typed. + These arguments: + M.N Defs.Y + do not match these parameters: + functor (A : ...) (B : $T2) (C : ...) -> ... + 1. Module M.N matches the expected module type + 2. An argument appears to be missing with module type + $T2 = sig type x = A.x end + 3. Module Defs.Y matches the expected module type +|}] + +module Too_many_Xs = F(M.N)(Defs.X)(Defs.X)(Defs.Y) +[%%expect {| +Line 1, characters 21-51: +1 | module Too_many_Xs = F(M.N)(Defs.X)(Defs.X)(Defs.Y) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The functor application is ill-typed. + These arguments: + M.N Defs.X Defs.X Defs.Y + do not match these parameters: + functor (A : ...) (B : ...) (C : ...) -> ... + 1. Module M.N matches the expected module type + 2. The following extra argument is provided + Defs.X : sig type x = M.N.x end + 3. Module Defs.X matches the expected module type + 4. Module Defs.Y matches the expected module type +|}] + + +module X = struct type x = int end +module Y = struct type y = float end +module Missing_X_bis = F(struct type x = int type y = float end)(Y) +[%%expect {| +module X : sig type x = int end +module Y : sig type y = float end +Line 3, characters 23-67: +3 | module Missing_X_bis = F(struct type x = int type y = float end)(Y) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The functor application is ill-typed. + These arguments: + $S1 Y + do not match these parameters: + functor (A : ...) (B : $T2) (C : ...) -> ... + 1. Module $S1 matches the expected module type + 2. An argument appears to be missing with module type + $T2 = sig type x = A.x end + 3. Module Y matches the expected module type +|}] + +module Too_many_Xs_bis = F(struct type x = int type y = float end)(X)(X)(Y) +[%%expect {| +Line 1, characters 25-75: +1 | module Too_many_Xs_bis = F(struct type x = int type y = float end)(X)(X)(Y) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The functor application is ill-typed. + These arguments: + $S1 X X Y + do not match these parameters: + functor (A : ...) (B : ...) (C : ...) -> ... + 1. Module $S1 matches the expected module type + 2. The following extra argument is provided X : sig type x = int end + 3. Module X matches the expected module type + 4. Module Y matches the expected module type +|}] + + +(** Inclusion side *) +module type f = + functor(A:sig type x type y end)(B:sig type x = A.x end)(C:sig type y = A.y end) + -> sig end +module F: f = functor (A:sig include x include y end)(Z:sig type y = A.y end) -> struct end +[%%expect {| +module type f = + functor (A : sig type x type y end) (B : sig type x = A.x end) + (C : sig type y = A.y end) -> sig end +Line 4, characters 22-91: +4 | module F: f = functor (A:sig include x include y end)(Z:sig type y = A.y end) -> struct end + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Signature mismatch: + Modules do not match: + functor (A : $S1) (Z : $S3) -> ... + is not included in + functor (A : $T1) (B : $T2) (C : $T3) -> ... + 1. Module types $S1 and $T1 match + 2. An argument appears to be missing with module type + $T2 = sig type x = A.x end + 3. Module types $S3 and $T3 match +|}] + + +module type f = + functor(B:sig type x type y type u=x type v=y end)(Y:sig type yu = Y of B.u end)(Z:sig type zv = Z of B.v end) + -> sig end +module F: f = functor (X:sig include x include y end)(Z:sig type zv = Z of X.y end) -> struct end +[%%expect {| +module type f = + functor (B : sig type x type y type u = x type v = y end) + (Y : sig type yu = Y of B.u end) (Z : sig type zv = Z of B.v end) -> + sig end +Line 4, characters 22-97: +4 | module F: f = functor (X:sig include x include y end)(Z:sig type zv = Z of X.y end) -> struct end + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Signature mismatch: + Modules do not match: + functor (X : $S1) (Z : $S3) -> ... + is not included in + functor (B : $T1) (Y : $T2) (Z : $T3) -> ... + 1. Module types $S1 and $T1 match + 2. An argument appears to be missing with module type + $T2 = sig type yu = Y of B.u end + 3. Module types $S3 and $T3 match +|}] + + +(** Module type equalities *) + +module M: sig + module type S = sig type t end +end = struct + module type S = sig type s type t end +end;; +[%%expect {| +Lines 5-7, characters 6-3: +5 | ......struct +6 | module type S = sig type s type t end +7 | end.. +Error: Signature mismatch: + Modules do not match: + sig module type S = sig type s type t end end + is not included in + sig module type S = sig type t end end + Module type declarations do not match: + module type S = sig type s type t end + does not match + module type S = sig type t end + The second module type is not included in the first + At position module type S = + Module types do not match: + sig type t end + is not equal to + sig type s type t end + At position module type S = + The type `s' is required but not provided +|}] + +module M: sig + module type S = sig type t type u end +end = struct + module type S = sig type t end +end;; + [%%expect {| +Lines 3-5, characters 6-3: +3 | ......struct +4 | module type S = sig type t end +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig module type S = sig type t end end + is not included in + sig module type S = sig type t type u end end + Module type declarations do not match: + module type S = sig type t end + does not match + module type S = sig type t type u end + The first module type is not included in the second + At position module type S = + Module types do not match: + sig type t end + is not equal to + sig type t type u end + At position module type S = + The type `u' is required but not provided +|}] + + +(** Name collision test *) + +module F(X:x)(B:b)(Y:y) = struct type t end +module M = struct + module type b + module G(P: sig module B:b end) = struct + open P + module U = F(struct type x end)(B)(struct type w end) + end +end +[%%expect {| +module F : functor (X : x) (B : b) (Y : y) -> sig type t end +Line 8, characters 15-57: +8 | module U = F(struct type x end)(B)(struct type w end) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The functor application is ill-typed. + These arguments: + $S1 P.B $S3 + do not match these parameters: + functor (X : x) (B : b/2) (Y : y) -> ... + 1. Module $S1 matches the expected module type x + 2. Modules do not match: + P.B : b/1 + is not included in + b/2 + Line 5, characters 2-15: + Definition of module type b/1 + Line 2, characters 0-13: + Definition of module type b/2 + 3. Modules do not match: $S3 : sig type w end is not included in y +|}] + +module F(X:a) = struct type t end +module M = struct + module type a + module G(P: sig module X:a end) = struct + open P + type t = F(X).t + end +end +[%%expect {| +module F : functor (X : a) -> sig type t end +Line 6, characters 13-19: +6 | type t = F(X).t + ^^^^^^ +Error: Modules do not match: a/1 is not included in a/2 + Line 3, characters 2-15: + Definition of module type a/1 + Line 1, characters 0-13: + Definition of module type a/2 +|}] + + + +module M: sig module F: functor(X:a)(Y:a) -> sig end end = + struct + module type aa = a + module type a + module F(X:aa)(Y:a) = struct end +end +[%%expect {| +Lines 2-6, characters 1-3: +2 | .struct +3 | module type aa = a +4 | module type a +5 | module F(X:aa)(Y:a) = struct end +6 | end +Error: Signature mismatch: + Modules do not match: + sig + module type aa = a + module type a + module F : functor (X : aa) (Y : a) -> sig end + end + is not included in + sig module F : functor (X : a) (Y : a) -> sig end end + In module F: + Modules do not match: + functor (X : aa) (Y : a/1) -> ... + is not included in + functor (X : a/2) (Y : a/2) -> ... + 1. Module types aa and a/2 match + 2. Module types do not match: + a/1 + does not include + a/2 + Line 4, characters 2-15: + Definition of module type a/1 + Line 1, characters 0-13: + Definition of module type a/2 +|}] + +module X: functor ( X: sig end) -> sig end = functor(X: Set.OrderedType) -> struct end +[%%expect {| +Line 1, characters 52-86: +1 | module X: functor ( X: sig end) -> sig end = functor(X: Set.OrderedType) -> struct end + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Signature mismatch: + Modules do not match: + functor (X : Set.OrderedType) -> ... + is not included in + functor (X : sig end) -> ... + Module types do not match: + Set.OrderedType + does not include + sig end + The type `t' is required but not provided + File "set.mli", line 54, characters 4-10: Expected declaration + The value `compare' is required but not provided + File "set.mli", line 57, characters 4-31: Expected declaration +|}] + +(** Deeply nested errors *) + + +module M: sig + module F: functor + (X: + functor(A: sig type xa end)(B:sig type xz end) -> sig end + ) + (Y: + functor(A: sig type ya end)(B:sig type yb end) -> sig end + ) + (Z: + functor(A: sig type za end)(B:sig type zb end) -> sig end + ) -> sig end +end = struct + module F + (X: + functor (A: sig type xa end)(B:sig type xz end) -> sig end + ) + (Y: + functor (A: sig type ya end)(B:sig type ybb end) -> sig end + ) + (Z: + functor (A: sig type za end)(B:sig type zbb end) -> sig end + ) + = struct end +end +[%%expect {| +Lines 15-27, characters 6-3: +15 | ......struct +16 | module F +17 | (X: +18 | functor (A: sig type xa end)(B:sig type xz end) -> sig end +19 | ) +... +24 | functor (A: sig type za end)(B:sig type zbb end) -> sig end +25 | ) +26 | = struct end +27 | end +Error: Signature mismatch: + Modules do not match: + sig + module F : + functor + (X : functor (A : sig type xa end) (B : sig type xz end) -> + sig end) + (Y : functor (A : sig type ya end) (B : sig type ybb end) -> + sig end) + (Z : functor (A : sig type za end) (B : sig type zbb end) -> + sig end) + -> sig end + end + is not included in + sig + module F : + functor + (X : functor (A : sig type xa end) (B : sig type xz end) -> + sig end) + (Y : functor (A : sig type ya end) (B : sig type yb end) -> + sig end) + (Z : functor (A : sig type za end) (B : sig type zb end) -> + sig end) + -> sig end + end + In module F: + Modules do not match: + functor (X : $S1) (Y : $S2) (Z : $S3) -> ... + is not included in + functor (X : $T1) (Y : $T2) (Z : $T3) -> ... + 1. Module types $S1 and $T1 match + 2. Module types do not match: + $S2 = + functor (A : sig type ya end) (B : sig type ybb end) -> sig end + does not include + $T2 = + functor (A : sig type ya end) (B : sig type yb end) -> sig end + Modules do not match: + functor (A : $S1) (B : $S2) -> ... + is not included in + functor (A : $T1) (B : $T2) -> ... + 1. Module types $S1 and $T1 match + 2. Module types do not match: + $S2 = sig type yb end + does not include + $T2 = sig type ybb end + The type `yb' is required but not provided + 3. Module types do not match: + $S3 = + functor (A : sig type za end) (B : sig type zbb end) -> sig end + does not include + $T3 = + functor (A : sig type za end) (B : sig type zb end) -> sig end + Modules do not match: + functor (A : $S1) (B : $S2) -> ... + is not included in + functor (A : $T1) (B : $T2) -> ... +|}] + + +module M: sig + module F: functor + (X: + functor(A: sig type xa end)(B:sig type xz end) -> sig end + ) + (Y: + functor(A: sig type ya end)(B:sig type yb end) -> sig end + ) + (Z: + functor(A: sig type za end)(B:sig type zb end) -> sig end + ) -> sig end +end = struct + module F + (X: + functor (A: sig type xa end)(B:sig type xz end) -> sig end + ) + (Y: + functor (A: sig type ya end)(B:sig type yb end) -> sig end + ) + = struct end +end +[%%expect {| +Lines 12-21, characters 6-3: +12 | ......struct +13 | module F +14 | (X: +15 | functor (A: sig type xa end)(B:sig type xz end) -> sig end +16 | ) +17 | (Y: +18 | functor (A: sig type ya end)(B:sig type yb end) -> sig end +19 | ) +20 | = struct end +21 | end +Error: Signature mismatch: + Modules do not match: + sig + module F : + functor + (X : functor (A : sig type xa end) (B : sig type xz end) -> + sig end) + (Y : functor (A : sig type ya end) (B : sig type yb end) -> + sig end) + -> sig end + end + is not included in + sig + module F : + functor + (X : functor (A : sig type xa end) (B : sig type xz end) -> + sig end) + (Y : functor (A : sig type ya end) (B : sig type yb end) -> + sig end) + (Z : functor (A : sig type za end) (B : sig type zb end) -> + sig end) + -> sig end + end + In module F: + Modules do not match: + functor (X : $S1) (Y : $S2) -> ... + is not included in + functor (X : $T1) (Y : $T2) (Z : $T3) -> ... + 1. Module types $S1 and $T1 match + 2. Module types $S2 and $T2 match + 3. An argument appears to be missing with module type + $T3 = + functor (A : sig type za end) (B : sig type zb end) -> sig end +|}] + +module M: sig + module F: functor + (X: + functor(A: sig type xa end)(B:sig type xz end) -> sig end + ) + (Y: + functor(A: sig type ya end)(B:sig type yb end) -> sig end + ) + (Z: + functor(A: sig type za end)(B:sig type zb end) -> sig end + ) -> sig end +end = struct + module F + (X: + functor (A: sig type xaa end)(B:sig type xz end) -> sig end + ) + (Y: + functor (A: sig type ya end)(B:sig type ybb end) -> sig end + ) + (Z: + functor (A: sig type za end)(B:sig type zbb end) -> sig end + ) + = struct end +end +[%%expect {| +Lines 12-24, characters 6-3: +12 | ......struct +13 | module F +14 | (X: +15 | functor (A: sig type xaa end)(B:sig type xz end) -> sig end +16 | ) +... +21 | functor (A: sig type za end)(B:sig type zbb end) -> sig end +22 | ) +23 | = struct end +24 | end +Error: Signature mismatch: + Modules do not match: + sig + module F : + functor + (X : functor (A : sig type xaa end) (B : sig type xz end) -> + sig end) + (Y : functor (A : sig type ya end) (B : sig type ybb end) -> + sig end) + (Z : functor (A : sig type za end) (B : sig type zbb end) -> + sig end) + -> sig end + end + is not included in + sig + module F : + functor + (X : functor (A : sig type xa end) (B : sig type xz end) -> + sig end) + (Y : functor (A : sig type ya end) (B : sig type yb end) -> + sig end) + (Z : functor (A : sig type za end) (B : sig type zb end) -> + sig end) + -> sig end + end + In module F: + Modules do not match: + functor (X : $S1) (Y : $S2) (Z : $S3) -> ... + is not included in + functor (X : $T1) (Y : $T2) (Z : $T3) -> ... + 1. Module types do not match: + $S1 = + functor (A : sig type xaa end) (B : sig type xz end) -> sig end + does not include + $T1 = + functor (A : sig type xa end) (B : sig type xz end) -> sig end + Modules do not match: + functor (A : $S1) (B : $S2) -> ... + is not included in + functor (A : $T1) (B : $T2) -> ... + 1. Module types do not match: + $S1 = sig type xa end + does not include + $T1 = sig type xaa end + The type `xa' is required but not provided + 2. Module types $S2 and $T2 match + 2. Module types do not match: + $S2 = + functor (A : sig type ya end) (B : sig type ybb end) -> sig end + does not include + $T2 = + functor (A : sig type ya end) (B : sig type yb end) -> sig end + Modules do not match: + functor (A : $S1) (B : $S2) -> ... + is not included in + functor (A : $T1) (B : $T2) -> ... + 3. Module types do not match: + $S3 = + functor (A : sig type za end) (B : sig type zbb end) -> sig end + does not include + $T3 = + functor (A : sig type za end) (B : sig type zb end) -> sig end + Modules do not match: + functor (A : $S1) (B : $S2) -> ... + is not included in + functor (A : $T1) (B : $T2) -> ... +|}] + +module A: sig + module B: sig + module C: sig + module D: sig + module E: sig + module F: sig type x end -> sig type y end + -> sig type z end -> sig type w end -> sig end + end + end + end + end +end = struct + module B = struct + module C = struct + module D = struct + module E = struct + module F(X:sig type x end)(Y:sig type y' end) + (W:sig type w end) = struct end + end + end + end + end +end +[%%expect {| +Lines 12-23, characters 6-3: +12 | ......struct +13 | module B = struct +14 | module C = struct +15 | module D = struct +16 | module E = struct +... +20 | end +21 | end +22 | end +23 | end +Error: Signature mismatch: + Modules do not match: + sig + module B : + sig + module C : + sig + module D : + sig + module E : + sig + module F : + functor (X : sig type x end) + (Y : sig type y' end) (W : sig type w end) -> + sig end + end + end + end + end + end + is not included in + sig + module B : + sig + module C : + sig + module D : + sig + module E : + sig + module F : + sig type x end -> sig type y end -> + sig type z end -> sig type w end -> sig end + end + end + end + end + end + In module B: + Modules do not match: + sig module C = B.C end + is not included in + sig + module C : + sig + module D : + sig + module E : + sig + module F : + sig type x end -> sig type y end -> + sig type z end -> sig type w end -> sig end + end + end + end + end + In module B.C: + Modules do not match: + sig module D = B.C.D end + is not included in + sig + module D : + sig + module E : + sig + module F : + sig type x end -> sig type y end -> sig type z end -> + sig type w end -> sig end + end + end + end + In module B.C.D: + Modules do not match: + sig module E = B.C.D.E end + is not included in + sig + module E : + sig + module F : + sig type x end -> sig type y end -> sig type z end -> + sig type w end -> sig end + end + end + In module B.C.D.E: + Modules do not match: + sig module F = B.C.D.E.F end + is not included in + sig + module F : + sig type x end -> sig type y end -> sig type z end -> + sig type w end -> sig end + end + In module B.C.D.E.F: + Modules do not match: + functor (X : $S1) (Y : $S3) (W : $S4) -> ... + is not included in + functor $T1 $T2 $T3 $T4 -> ... + 1. Module types $S1 and $T1 match + 2. An argument appears to be missing with module type + $T2 = sig type y end + 3. Module types do not match: + $S3 = sig type y' end + does not include + $T3 = sig type z end + 4. Module types $S4 and $T4 match +|}] + + +(** Ugly cases *) + +module type Arg = sig + module type A + module type Honorificabilitudinitatibus + module X: Honorificabilitudinitatibus + module Y: A +end + +module F(A:Arg) += struct + open A + module G(X:A)(Y:A)(_:A)(Z:A) = struct end + type u = G(X)(Y)(X)(Y)(X).t +end;; +[%%expect {| +module type Arg = + sig + module type A + module type Honorificabilitudinitatibus + module X : Honorificabilitudinitatibus + module Y : A + end +Line 14, characters 11-29: +14 | type u = G(X)(Y)(X)(Y)(X).t + ^^^^^^^^^^^^^^^^^^ +Error: The functor application G(X)(Y)(X)(Y)(X) is ill-typed. + These arguments: + A.X A.Y A.X A.Y A.X + do not match these parameters: + functor (X : A.A) (Y : A.A) A.A (Z : A.A) -> ... + 1. The following extra argument is provided + A.X : A.Honorificabilitudinitatibus + 2. Module A.Y matches the expected module type A.A + 3. Modules do not match: + A.X : A.Honorificabilitudinitatibus + is not included in + A.A + 4. Module A.Y matches the expected module type A.A + 5. Modules do not match: + A.X : A.Honorificabilitudinitatibus + is not included in + A.A +|}] + + +module type s = functor + (X: sig type when_ type shall type we type three type meet type again end) + (Y:sig type in_ val thunder:in_ val lightning: in_ type rain end) + (Z:sig type when_ type the type hurlyburly's type done_ end) + (Z:sig type when_ type the type battle's type lost type and_ type won end) + (W:sig type that type will type be type ere type the_ type set type of_ type sun end) + (S: sig type where type the type place end) + (R: sig type upon type the type heath end) +-> sig end +module F: s = functor + (X: sig type when_ type shall type we type tree type meet type again end) + (Y:sig type in_ val thunder:in_ val lightning: in_ type pain end) + (Z:sig type when_ type the type hurlyburly's type gone end) + (Z:sig type when_ type the type battle's type last type and_ type won end) + (W:sig type that type will type be type the type era type set type of_ type sun end) + (S: sig type where type the type lace end) + (R: sig type upon type the type heart end) + -> struct end +[%%expect {| +module type s = + functor + (X : sig + type when_ + type shall + type we + type three + type meet + type again + end) + (Y : sig type in_ val thunder : in_ val lightning : in_ type rain end) + (Z : sig type when_ type the type hurlyburly's type done_ end) + (Z : sig + type when_ + type the + type battle's + type lost + type and_ + type won + end) + (W : sig + type that + type will + type be + type ere + type the_ + type set + type of_ + type sun + end) + (S : sig type where type the type place end) + (R : sig type upon type the type heath end) -> sig end +Lines 11-18, characters 2-15: +11 | ..(X: sig type when_ type shall type we type tree type meet type again end) +12 | (Y:sig type in_ val thunder:in_ val lightning: in_ type pain end) +13 | (Z:sig type when_ type the type hurlyburly's type gone end) +14 | (Z:sig type when_ type the type battle's type last type and_ type won end) +15 | (W:sig type that type will type be type the type era type set type of_ type sun end) +16 | (S: sig type where type the type lace end) +17 | (R: sig type upon type the type heart end) +18 | -> struct end +Error: Signature mismatch: + Modules do not match: + functor (X : $S1) (Y : $S2) (Z : $S3) (Z : $S4) (W : $S5) (S : $S6) + (R : $S7) -> ... + is not included in + functor (X : $T1) (Y : $T2) (Z : $T3) (Z : $T4) (W : $T5) (S : $T6) + (R : $T7) -> ... + 1. Module types do not match: + $S1 = + sig + type when_ + type shall + type we + type tree + type meet + type again + end + does not include + $T1 = + sig + type when_ + type shall + type we + type three + type meet + type again + end + The type `tree' is required but not provided + 2. Module types do not match: + $S2 = + sig type in_ val thunder : in_ val lightning : in_ type pain end + does not include + $T2 = + sig type in_ val thunder : in_ val lightning : in_ type rain end + 3. Module types do not match: + $S3 = sig type when_ type the type hurlyburly's type gone end + does not include + $T3 = sig type when_ type the type hurlyburly's type done_ end + 4. Module types do not match: + $S4 = + sig + type when_ + type the + type battle's + type last + type and_ + type won + end + does not include + $T4 = + sig + type when_ + type the + type battle's + type lost + type and_ + type won + end + 5. Module types do not match: + $S5 = + sig + type that + type will + type be + type the + type era + type set + type of_ + type sun + end + does not include + $T5 = + sig + type that + type will + type be + type ere + type the_ + type set + type of_ + type sun + end + 6. Module types do not match: + $S6 = sig type where type the type lace end + does not include + $T6 = sig type where type the type place end + 7. Module types do not match: + $S7 = sig type upon type the type heart end + does not include + $T7 = sig type upon type the type heath end +|}] + + +(** Abstract module type woes *) + + +module F(X:sig type witness module type t module M:t end) = X.M + +module PF = struct + type witness + module type t = module type of F + module M = F +end + +module U = F(PF)(PF)(PF) +[%%expect {| +module F : + functor (X : sig type witness module type t module M : t end) -> X.t +module PF : + sig + type witness + module type t = + functor (X : sig type witness module type t module M : t end) -> X.t + module M = F + end +module U : PF.t +|}] + +module W = F(PF)(PF)(PF)(PF)(PF)(F) +[%%expect {| +Line 1, characters 11-35: +1 | module W = F(PF)(PF)(PF)(PF)(PF)(F) + ^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The functor application is ill-typed. + These arguments: + PF PF PF PF PF F + do not match these parameters: + functor (X : ...) (X : ...) (X : ...) (X : ...) (X : ...) (X : $T6) + -> ... + 1. Module PF matches the expected module type + 2. Module PF matches the expected module type + 3. Module PF matches the expected module type + 4. Module PF matches the expected module type + 5. Module PF matches the expected module type + 6. Modules do not match: + F : + functor (X : sig type witness module type t module M : t end) -> + X.t + is not included in + $T6 = sig type witness module type t module M : t end + Modules do not match: + functor (X : $S1) -> ... + is not included in + functor -> ... + An extra argument is provided of module type + $S1 = sig type witness module type t module M : t end +|}] + +(** Divergent arities *) +module type arg = sig type arg end +module A = struct type arg end + +module Add_one' = struct + module M(_:arg) = A + module type t = module type of M +end + +module Add_one = struct type witness include Add_one' end + +module Add_three' = struct + module M(_:arg)(_:arg)(_:arg) = A + module type t = module type of M +end + +module Add_three = struct + include Add_three' + type witness +end + + +module Wrong_intro = F(Add_three')(A)(A)(A) +[%%expect {| +module type arg = sig type arg end +module A : sig type arg end +module Add_one' : + sig + module M : arg -> sig type arg = A.arg end + module type t = arg -> sig type arg = A.arg end + end +module Add_one : + sig type witness module M = Add_one'.M module type t = Add_one'.t end +module Add_three' : + sig + module M : arg -> arg -> arg -> sig type arg = A.arg end + module type t = arg -> arg -> arg -> sig type arg = A.arg end + end +module Add_three : + sig module M = Add_three'.M module type t = Add_three'.t type witness end +Line 22, characters 21-43: +22 | module Wrong_intro = F(Add_three')(A)(A)(A) + ^^^^^^^^^^^^^^^^^^^^^^ +Error: The functor application is ill-typed. + These arguments: + Add_three' A A A + do not match these parameters: + functor (X : $T1) arg arg arg -> ... + 1. Modules do not match: + Add_three' : + sig module M = Add_three'.M module type t = Add_three'.t end + is not included in + $T1 = sig type witness module type t module M : t end + The type `witness' is required but not provided + 2. Module A matches the expected module type arg + 3. Module A matches the expected module type arg + 4. Module A matches the expected module type arg +|}] + +module Choose_one = F(Add_one')(Add_three)(A)(A)(A) +[%%expect {| +Line 1, characters 20-51: +1 | module Choose_one = F(Add_one')(Add_three)(A)(A)(A) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The functor application is ill-typed. + These arguments: + Add_one' Add_three A A A + do not match these parameters: + functor (X : ...) arg arg arg -> ... + 1. The following extra argument is provided + Add_one' : + sig module M = Add_one'.M module type t = Add_one'.t end + 2. Module Add_three matches the expected module type + 3. Module A matches the expected module type arg + 4. Module A matches the expected module type arg + 5. Module A matches the expected module type arg +|}] + +(** Known lmitation: we choose the wrong environment without the + error on Add_one +**) +module Mislead_chosen_one = F(Add_one)(Add_three)(A)(A)(A) +[%%expect {| +Line 1, characters 28-58: +1 | module Mislead_chosen_one = F(Add_one)(Add_three)(A)(A)(A) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The functor application is ill-typed. + These arguments: + Add_one Add_three A A A + do not match these parameters: + functor (X : ...) arg arg arg -> ... + 1. The following extra argument is provided + Add_one : + sig + type witness = Add_one.witness + module M = Add_one'.M + module type t = Add_one.t + end + 2. Module Add_three matches the expected module type + 3. Module A matches the expected module type arg + 4. Module A matches the expected module type arg + 5. Module A matches the expected module type arg +|}] + + + + + + +(** Hide your arity from the world *) + +module M: sig + module F: + functor (X:sig + type x + module type t = + functor + (Y:sig type y end) + (Z:sig type z end) + -> sig end + end) -> X.t +end += struct + module F(X:sig type x end)(Z:sig type z end) = struct end +end +[%%expect {| +Lines 14-16, characters 2-3: +14 | ..struct +15 | module F(X:sig type x end)(Z:sig type z end) = struct end +16 | end +Error: Signature mismatch: + Modules do not match: + sig + module F : + functor (X : sig type x end) (Z : sig type z end) -> sig end + end + is not included in + sig + module F : + functor + (X : sig + type x + module type t = + functor (Y : sig type y end) (Z : sig type z end) -> + sig end + end) + -> X.t + end + In module F: + Modules do not match: + functor (X : $S1) (Z : $S3) -> ... + is not included in + functor (X : $T1) (Y : $T2) (Z : $T3) -> ... + 1. Module types $S1 and $T1 match + 2. An argument appears to be missing with module type + $T2 = sig type y end + 3. Module types $S3 and $T3 match +|}] + + +module M: sig + module F(X: sig + module type T + module type t = T -> T -> T + module M: t + end + )(_:X.T)(_:X.T): X.T +end = struct + module F (Wrong: sig type wrong end) + (X: sig + module type t + module M: t + end) = (X.M : X.t) +end +[%%expect {| +Lines 8-14, characters 6-3: + 8 | ......struct + 9 | module F (Wrong: sig type wrong end) +10 | (X: sig +11 | module type t +12 | module M: t +13 | end) = (X.M : X.t) +14 | end +Error: Signature mismatch: + Modules do not match: + sig + module F : + functor (Wrong : sig type wrong end) + (X : sig module type t module M : t end) -> X.t + end + is not included in + sig + module F : + functor + (X : sig + module type T + module type t = T -> T -> T + module M : t + end) + -> X.T -> X.T -> X.T + end + In module F: + Modules do not match: + functor (Wrong : $S1) (X : $S2) X.T X.T -> ... + is not included in + functor (X : $T2) X.T X.T -> ... + 1. An extra argument is provided of module type + $S1 = sig type wrong end + 2. Module types $S2 and $T2 match + 3. Module types X/3.T and X/2.T match + 4. Module types X/3.T and X/2.T match +|}] + + +module M: sig + module F(_:sig end)(X: + sig + module type T + module type inner = sig + module type t + module M: t + end + module F(X: inner)(_:T -> T->T): + sig module type res = X.t end + module Y: sig + module type t = T -> T -> T + module M(X:T)(Y:T): T + end + end): + X.F(X.Y)(X.Y.M).res +end = struct + module F(_:sig type wrong end) (X: + sig module type T end + )(Res: X.T)(Res: X.T)(Res: X.T) = Res +end +[%%expect {| +Lines 17-21, characters 6-3: +17 | ......struct +18 | module F(_:sig type wrong end) (X: +19 | sig module type T end +20 | )(Res: X.T)(Res: X.T)(Res: X.T) = Res +21 | end +Error: Signature mismatch: + Modules do not match: + sig + module F : + sig type wrong end -> + functor (X : sig module type T end) (Res : X.T) (Res : + X.T) (Res : X.T) + -> X.T + end + is not included in + sig + module F : + sig end -> + functor + (X : sig + module type T + module type inner = + sig module type t module M : t end + module F : + functor (X : inner) -> (T -> T -> T) -> + sig module type res = X.t end + module Y : + sig + module type t = T -> T -> T + module M : functor (X : T) (Y : T) -> T + end + end) + -> X.F(X.Y)(X.Y.M).res + end + In module F: + Modules do not match: + functor (Arg : $S1) (X : $S2) (Res : X.T) (Res : X.T) (Res : + X.T) -> ... + is not included in + functor (sig end) (X : $T2) X.T X.T -> ... + 1. Module types do not match: + $S1 = sig type wrong end + does not include + sig end + The type `wrong' is required but not provided + 2. Module types $S2 and $T2 match + 3. An extra argument is provided of module type X/2.T + 4. Module types X/2.T and X/2.T match + 5. Module types X/2.T and X/2.T match +|}] + + +(** The price of Gluttony: gready update of environment leads to a non-optimal edit distance. *) + +module F(X:sig type t end)(Y:sig type t = Y of X.t end)(Z:sig type t = Z of X.t end) = struct end + +module X = struct type t = U end +module Y = struct type t = Y of int end +module Z = struct type t = Z of int end + +module Error=F(X)(struct type t = int end)(Y)(Z) +[%%expect {| +module F : + functor (X : sig type t end) (Y : sig type t = Y of X.t end) + (Z : sig type t = Z of X.t end) -> sig end +module X : sig type t = U end +module Y : sig type t = Y of int end +module Z : sig type t = Z of int end +Line 9, characters 13-48: +9 | module Error=F(X)(struct type t = int end)(Y)(Z) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The functor application is ill-typed. + These arguments: + X ... Y Z + do not match these parameters: + functor (X : ...) (Y : $T3) (Z : $T4) -> ... + 1. Module X matches the expected module type + 2. The following extra argument is provided ... : sig type t = int end + 3. Modules do not match: + Y : sig type t = Y.t = Y of int end + is not included in + $T3 = sig type t = Y of X/2.t end + Type declarations do not match: + type t = Y.t = Y of int + is not included in + type t = Y of X.t + Constructors do not match: + Y of int + is not the same as: + Y of X.t + The type int is not equal to the type X.t + 4. Modules do not match: + Z : sig type t = Z.t = Z of int end + is not included in + $T4 = sig type t = Z of X/2.t end + Type declarations do not match: + type t = Z.t = Z of int + is not included in + type t = Z of X.t + Constructors do not match: + Z of int + is not the same as: + Z of X.t + The type int is not equal to the type X.t +|}] + +(** Final state in the presence of extensions + Test provided by Leo White in + https://github.com/ocaml/ocaml/pull/9331#pullrequestreview-492359720 +*) + +module type A = sig type a end +module A = struct type a end +module type B = sig type b end +module B = struct type b end + +module type ty = sig type t end +module TY = struct type t end + +module type Ext = sig module type T module X : T end + +module AExt = struct module type T = A module X = A end +module FiveArgsExt = struct + module type T = ty -> ty -> ty -> ty -> ty -> sig end + module X : T = + functor (_ : ty) (_ : ty) (_ : ty) (_ : ty) (_ : ty) -> struct end +end + +module Bar (W : A) (X : Ext) (Y : B) (Z : Ext) = Z.X + +type fine = Bar(A)(FiveArgsExt)(B)(AExt).a +[%%expect{| +module type A = sig type a end +module A : sig type a end +module type B = sig type b end +module B : sig type b end +module type ty = sig type t end +module TY : sig type t end +module type Ext = sig module type T module X : T end +module AExt : sig module type T = A module X = A end +module FiveArgsExt : + sig module type T = ty -> ty -> ty -> ty -> ty -> sig end module X : T end +module Bar : functor (W : A) (X : Ext) (Y : B) (Z : Ext) -> Z.T +type fine = Bar(A)(FiveArgsExt)(B)(AExt).a +|}] + +type broken1 = Bar(B)(FiveArgsExt)(B)(AExt).a +[%%expect{| +Line 1, characters 15-45: +1 | type broken1 = Bar(B)(FiveArgsExt)(B)(AExt).a + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The functor application Bar(B)(FiveArgsExt)(B)(AExt) is ill-typed. + These arguments: + B FiveArgsExt B AExt + do not match these parameters: + functor (W : A) (X : Ext) (Y : B) (Z : Ext) -> ... + 1. Modules do not match: + B : sig type b = B.b end + is not included in + A + The type `a' is required but not provided + 2. Module FiveArgsExt matches the expected module type Ext + 3. Module B matches the expected module type B + 4. Module AExt matches the expected module type Ext +|}] + +type broken2 = Bar(A)(FiveArgsExt)(TY)(TY)(TY)(TY)(TY).a +[%%expect{| +Line 1, characters 15-56: +1 | type broken2 = Bar(A)(FiveArgsExt)(TY)(TY)(TY)(TY)(TY).a + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The functor application Bar(A)(FiveArgsExt)(TY)(TY)(TY)(TY)(TY) is ill-typed. + These arguments: + A FiveArgsExt TY TY TY TY TY + do not match these parameters: + functor (W : A) (X : Ext) (Y : B) (Z : Ext) ty ty ty ty ty -> ... + 1. Module A matches the expected module type A + 2. An argument appears to be missing with module type Ext + 3. An argument appears to be missing with module type B + 4. Module FiveArgsExt matches the expected module type Ext + 5. Module TY matches the expected module type ty + 6. Module TY matches the expected module type ty + 7. Module TY matches the expected module type ty + 8. Module TY matches the expected module type ty + 9. Module TY matches the expected module type ty +|}] + +module Shape_arg = struct + module M1 (Arg1 : sig end) = struct + module type S1 = sig + type t + end + end + + module type S2 = sig + module Make (Arg2 : sig end) : M1(Arg2).S1 + end + + module M2 : S2 = struct + module Make (Arg3 : sig end) = struct + type t = T + end + end + + module M3 (Arg4 : sig end) = struct + module type S3 = sig + type t = M2.Make(Arg4).t + end + end + + module M4 (Arg5 : sig end) : M3(Arg5).S3 = struct + module M5 = M2.Make (Arg5) + + type t = M5.t + end +end +[%%expect{| +module Shape_arg : + sig + module M1 : + functor (Arg1 : sig end) -> sig module type S1 = sig type t end end + module type S2 = + sig module Make : functor (Arg2 : sig end) -> M1(Arg2).S1 end + module M2 : S2 + module M3 : + functor (Arg4 : sig end) -> + sig module type S3 = sig type t = M2.Make(Arg4).t end end + module M4 : functor (Arg5 : sig end) -> M3(Arg5).S3 + end +|}] diff --git a/ocaml/testsuite/tests/typing-modules/generative.ml b/ocaml/testsuite/tests/typing-modules/generative.ml index c9411da3e60..9cc7c0db45a 100644 --- a/ocaml/testsuite/tests/typing-modules/generative.ml +++ b/ocaml/testsuite/tests/typing-modules/generative.ml @@ -65,9 +65,10 @@ Line 2, characters 36-38: ^^ Error: Signature mismatch: Modules do not match: - functor (X : sig end) -> sig end + functor (X : sig end) -> ... is not included in - functor () -> sig end + functor () -> ... + The functor was expected to be generative at this position |}];; module F3 () = struct end;; module F4 : functor (X : sig end) -> sig end = F3;; (* fail *) @@ -78,9 +79,10 @@ Line 2, characters 47-49: ^^ Error: Signature mismatch: Modules do not match: - functor () -> sig end + functor () -> ... is not included in - functor (X : sig end) -> sig end + functor (X : sig end) -> ... + The functor was expected to be applicative at this position |}];; (* tests for shortened functor notation () *) diff --git a/ocaml/testsuite/tests/typing-modules/illegal_permutation.ml b/ocaml/testsuite/tests/typing-modules/illegal_permutation.ml index 5a5998dac68..fabe8548c59 100644 --- a/ocaml/testsuite/tests/typing-modules/illegal_permutation.ml +++ b/ocaml/testsuite/tests/typing-modules/illegal_permutation.ml @@ -237,9 +237,9 @@ Error: Signature mismatch: module type a = sig module type b = sig val x : int val y : int end end At position module type a = - Modules do not match: + Module types do not match: sig module type b = sig val y : int val x : int end end - is not included in + is not equal to sig module type b = sig val x : int val y : int end end At position module type a = Module type declarations do not match: diff --git a/ocaml/testsuite/tests/typing-modules/include_functor.ml b/ocaml/testsuite/tests/typing-modules/include_functor.ml index 43cbdf0e830..49f66ef3a7c 100644 --- a/ocaml/testsuite/tests/typing-modules/include_functor.ml +++ b/ocaml/testsuite/tests/typing-modules/include_functor.ml @@ -40,6 +40,7 @@ Line 5, characters 18-20: ^^ Error: Signature mismatch in included functor's parameter: Values do not match: val x : bool is not included in val x : t + The type bool is not compatible with the type t = int |}];; (* Test 3: Missing type in structure *) @@ -114,6 +115,7 @@ Line 5, characters 18-20: ^^ Error: Signature mismatch in included functor's parameter: Values do not match: val x : bool is not included in val x : t + The type bool is not compatible with the type t |}];; (* Test 7: Missing type in signature *) @@ -673,3 +675,25 @@ Line 20, characters 16-17: Error: This expression has type int but an expression was expected of type string |}];; + +(* Test 21: Check that scraping of result type happens in environment expanded + with parameter type. *) +module M21 = struct + module F (_ : sig end) = struct + module type S = sig end + end + + module P = struct + module Make (M : sig end) : F(M).S = struct end + end + + include functor P.Make +end;; +[%%expect{| +module M21 : + sig + module F : sig end -> sig module type S = sig end end + module P : sig module Make : functor (M : sig end) -> F(M).S end + end +|}];; + diff --git a/ocaml/testsuite/tests/typing-modules/inclusion_errors.ml b/ocaml/testsuite/tests/typing-modules/inclusion_errors.ml new file mode 100644 index 00000000000..e4333a08a1d --- /dev/null +++ b/ocaml/testsuite/tests/typing-modules/inclusion_errors.ml @@ -0,0 +1,1810 @@ +(* TEST + * expect +*) + +(********************************** Equality **********************************) + +module M : sig + type ('a, 'b) t = 'a * 'b +end = struct + type ('a, 'b) t = 'a * 'a +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type ('a, 'b) t = 'a * 'a +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type ('a, 'b) t = 'a * 'a end + is not included in + sig type ('a, 'b) t = 'a * 'b end + Type declarations do not match: + type ('a, 'b) t = 'a * 'a + is not included in + type ('a, 'b) t = 'a * 'b + The type 'a * 'a is not equal to the type 'a * 'b + Type 'a is not equal to type 'b +|}];; + +module M : sig + type ('a, 'b) t = 'a * 'a +end = struct + type ('a, 'b) t = 'a * 'b +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type ('a, 'b) t = 'a * 'b +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type ('a, 'b) t = 'a * 'b end + is not included in + sig type ('a, 'b) t = 'a * 'a end + Type declarations do not match: + type ('a, 'b) t = 'a * 'b + is not included in + type ('a, 'b) t = 'a * 'a + The type 'a * 'b is not equal to the type 'a * 'a + Type 'b is not equal to type 'a +|}];; + +type 'a x +module M: sig + type ('a,'b,'c) t = ('a * 'b * 'c * 'b * 'a) x +end = struct + type ('b,'c,'a) t = ('b * 'c * 'a * 'c * 'a) x +end +[%%expect{| +type 'a x +Lines 4-6, characters 6-3: +4 | ......struct +5 | type ('b,'c,'a) t = ('b * 'c * 'a * 'c * 'a) x +6 | end +Error: Signature mismatch: + Modules do not match: + sig type ('b, 'c, 'a) t = ('b * 'c * 'a * 'c * 'a) x end + is not included in + sig type ('a, 'b, 'c) t = ('a * 'b * 'c * 'b * 'a) x end + Type declarations do not match: + type ('b, 'c, 'a) t = ('b * 'c * 'a * 'c * 'a) x + is not included in + type ('a, 'b, 'c) t = ('a * 'b * 'c * 'b * 'a) x + The type ('b * 'c * 'a * 'c * 'a) x is not equal to the type + ('b * 'c * 'a * 'c * 'b) x + Type 'a is not equal to type 'b +|}] + +module M : sig + type t = as 'bar)> +end = struct + type t = as 'foo +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = as 'foo +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = < m : 'a. 'a * ('a * 'b) > as 'b end + is not included in + sig type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > end + Type declarations do not match: + type t = < m : 'a. 'a * ('a * 'b) > as 'b + is not included in + type t = < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > + The type < m : 'a. 'a * ('a * 'd) > as 'd is not equal to the type + < m : 'b. 'b * ('b * < m : 'c. 'c * 'e > as 'e) > + The method m has type 'a. 'a * ('a * < m : 'a. 'f >) as 'f, + but the expected method type was 'c. 'c * ('b * < m : 'c. 'g >) as 'g + The universal variable 'b would escape its scope +|}];; + +type s = private < m : int; .. >;; +[%%expect{| +type s = private < m : int; .. > +|}];; + +module M : sig + type t = s +end = struct + type t = +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = < m : int > end + is not included in + sig type t = s end + Type declarations do not match: + type t = < m : int > + is not included in + type t = s + The type < m : int > is not equal to the type s + The second object type has an abstract row, it cannot be closed +|}];; + +module M : sig + type t = +end = struct + type t = s +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = s +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = s end + is not included in + sig type t = < m : int > end + Type declarations do not match: + type t = s + is not included in + type t = < m : int > + The type s is not equal to the type < m : int > + The first object type has an abstract row, it cannot be closed +|}];; + +module M : sig + type t = + | Foo of (int)*float +end = struct + type t = + | Foo of (int*int)*float +end;; +[%%expect{| +Lines 4-7, characters 6-3: +4 | ......struct +5 | type t = +6 | | Foo of (int*int)*float +7 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = Foo of (int * int) * float end + is not included in + sig type t = Foo of int * float end + Type declarations do not match: + type t = Foo of (int * int) * float + is not included in + type t = Foo of int * float + Constructors do not match: + Foo of (int * int) * float + is not the same as: + Foo of int * float + The type int * int is not equal to the type int +|}];; + +module M : sig + type t = (int * float) +end = struct + type t = (int * float * int) +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = (int * float * int) +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = int * float * int end + is not included in + sig type t = int * float end + Type declarations do not match: + type t = int * float * int + is not included in + type t = int * float + The type int * float * int is not equal to the type int * float +|}];; + +module M : sig + type t = +end = struct + type t = +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = < f : float; n : int > end + is not included in + sig type t = < m : float; n : int > end + Type declarations do not match: + type t = < f : float; n : int > + is not included in + type t = < m : float; n : int > + The type < f : float; n : int > is not equal to the type + < m : float; n : int > + The second object type has no method f +|}];; + +module M : sig + type t = +end = struct + type t = +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = < n : int > end + is not included in + sig type t = < m : float; n : int > end + Type declarations do not match: + type t = < n : int > + is not included in + type t = < m : float; n : int > + The type < n : int > is not equal to the type < m : float; n : int > + The first object type has no method m +|}];; + +module M4 : sig + type t = +end = struct + type t = +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = < m : int; n : int > end + is not included in + sig type t = < m : float * int; n : int > end + Type declarations do not match: + type t = < m : int; n : int > + is not included in + type t = < m : float * int; n : int > + The type < m : int; n : int > is not equal to the type + < m : float * int; n : int > + Types for method m are incompatible +|}];; + +module M4 : sig + type t = + | Foo of [`Foo of string | `Bar of string] +end = struct + type t = + | Foo of [`Bar of string] +end;; +[%%expect{| +Lines 4-7, characters 6-3: +4 | ......struct +5 | type t = +6 | | Foo of [`Bar of string] +7 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = Foo of [ `Bar of string ] end + is not included in + sig type t = Foo of [ `Bar of string | `Foo of string ] end + Type declarations do not match: + type t = Foo of [ `Bar of string ] + is not included in + type t = Foo of [ `Bar of string | `Foo of string ] + Constructors do not match: + Foo of [ `Bar of string ] + is not the same as: + Foo of [ `Bar of string | `Foo of string ] + The type [ `Bar of string ] is not equal to the type + [ `Bar of string | `Foo of string ] + The first variant type does not allow tag(s) `Foo +|}];; + +module M : sig + type t = private [`C of int] +end = struct + type t = private [`C] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private [`C] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private [ `C ] end + is not included in + sig type t = private [ `C of int ] end + Type declarations do not match: + type t = private [ `C ] + is not included in + type t = private [ `C of int ] + The type [ `C ] is not equal to the type [ `C of int ] + Types for tag `C are incompatible +|}];; + +module M : sig + type t = private [`C] +end = struct + type t = private [`C of int] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private [`C of int] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private [ `C of int ] end + is not included in + sig type t = private [ `C ] end + Type declarations do not match: + type t = private [ `C of int ] + is not included in + type t = private [ `C ] + The type [ `C of int ] is not equal to the type [ `C ] + Types for tag `C are incompatible +|}];; + +module M : sig + type t = [`C of [< `A] | `C of [`A]] +end = struct + type t = [`C of [< `A | `B] | `C of [`A]] +end;; +[%%expect{| +module M : sig type t = [ `C of [ `A ] ] end +|}];; + +module M : sig + type t = private [> `A of int] +end = struct + type t = private [`A of int] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private [`A of int] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private [ `A of int ] end + is not included in + sig type t = private [> `A of int ] end + Type declarations do not match: + type t = private [ `A of int ] + is not included in + type t = private [> `A of int ] + The type [ `A of int ] is not equal to the type [> `A of int ] + The second variant type is open and the first is not +|}];; + +module M : sig + type t = private [`A of int] +end = struct + type t = private [> `A of int] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private [> `A of int] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private [> `A of int ] end + is not included in + sig type t = private [ `A of int ] end + Type declarations do not match: + type t = private [> `A of int ] + is not included in + type t = private [ `A of int ] + The type [> `A of int ] is not equal to the type [ `A of int ] + The first variant type is open and the second is not +|}];; + +module M : sig + type 'a t = [> `A of int | `B of int] as 'a +end = struct + type 'a t = [> `A of int] as 'a +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type 'a t = [> `A of int] as 'a +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type 'a t = 'a constraint 'a = [> `A of int ] end + is not included in + sig type 'a t = 'a constraint 'a = [> `A of int | `B of int ] end + Type declarations do not match: + type 'a t = 'a constraint 'a = [> `A of int ] + is not included in + type 'a t = 'a constraint 'a = [> `A of int | `B of int ] + The type [> `A of int ] is not equal to the type + [> `A of int | `B of int ] + The first variant type does not allow tag(s) `B +|}];; + +module M : sig + type 'a t = [> `A of int] as 'a +end = struct + type 'a t = [> `A of int | `C of float] as 'a +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type 'a t = [> `A of int | `C of float] as 'a +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type 'a t = 'a constraint 'a = [> `A of int | `C of float ] end + is not included in + sig type 'a t = 'a constraint 'a = [> `A of int ] end + Type declarations do not match: + type 'a t = 'a constraint 'a = [> `A of int | `C of float ] + is not included in + type 'a t = 'a constraint 'a = [> `A of int ] + The type [> `A of int | `C of float ] is not equal to the type + [> `A of int ] + The second variant type does not allow tag(s) `C +|}];; + +module M : sig + type t = [`C of [< `A | `B] | `C of [`A]] +end = struct + type t = [`C of [< `A] | `C of [`A]] +end;; +[%%expect{| +module M : sig type t = [ `C of [ `A ] ] end +|}];; + +module M : sig + type t = private [< `C] +end = struct + type t = private [< `C of int&float] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private [< `C of int&float] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private [< `C of int & float ] end + is not included in + sig type t = private [< `C ] end + Type declarations do not match: + type t = private [< `C of int & float ] + is not included in + type t = private [< `C ] + Types for tag `C are incompatible +|}];; + +(********************************** Moregen ***********************************) + +module type T = sig + type t +end +module Int = struct + type t = int +end +module type S = sig + module Choice : T + val r : Choice.t list ref ref +end +module Force (X : functor () -> S) = struct end +module Choose () = struct + module Choice = + (val (module Int : T)) + let r = ref (ref []) +end +module Ignore = Force(Choose) +[%%expect{| +module type T = sig type t end +module Int : sig type t = int end +module type S = sig module Choice : T val r : Choice.t list ref ref end +module Force : functor (X : functor () -> S) -> sig end +module Choose : + functor () -> sig module Choice : T val r : '_weak1 list ref ref end +Line 17, characters 16-29: +17 | module Ignore = Force(Choose) + ^^^^^^^^^^^^^ +Error: Modules do not match: + functor () -> sig module Choice : T val r : '_weak1 list ref ref end + is not included in functor () -> S + Modules do not match: + sig module Choice : T val r : '_weak1 list ref ref end + is not included in + S + Values do not match: + val r : '_weak1 list ref ref + is not included in + val r : Choice.t list ref ref + The type '_weak1 list ref ref is not compatible with the type + Choice.t list ref ref + The type constructor Choice.t would escape its scope +|}];; + +module O = struct + module type s + module M: sig + val f: (module s) -> unit + end = struct + module type s + let f (module X:s) = () + end +end;; +[%%expect{| +Lines 5-8, characters 8-5: +5 | ........struct +6 | module type s +7 | let f (module X:s) = () +8 | end +Error: Signature mismatch: + Modules do not match: + sig module type s val f : (module s) -> unit end + is not included in + sig val f : (module s) -> unit end + Values do not match: + val f : (module s/1) -> unit + is not included in + val f : (module s/2) -> unit + The type (module s/1) -> unit is not compatible with the type + (module s/2) -> unit + Type (module s/1) is not compatible with type (module s/2) + Line 6, characters 4-17: + Definition of module type s/1 + Line 2, characters 2-15: + Definition of module type s/2 +|}];; + +module M : sig + val f : ( as 'bar)>) -> unit +end = struct + let f (x : as 'foo) = () +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let f (x : as 'foo) = () +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig val f : (< m : 'a. 'a * 'b > as 'b) -> unit end + is not included in + sig val f : < m : 'b. 'b * < m : 'c. 'c * 'a > as 'a > -> unit end + Values do not match: + val f : (< m : 'a. 'a * 'b > as 'b) -> unit + is not included in + val f : < m : 'b. 'b * < m : 'c. 'c * 'a > as 'a > -> unit + The type (< m : 'a. 'a * 'd > as 'd) -> unit + is not compatible with the type + < m : 'b. 'b * < m : 'c. 'c * 'e > as 'e > -> unit + The method m has type 'a. 'a * < m : 'a. 'f > as 'f, + but the expected method type was 'c. 'c * ('b * < m : 'c. 'g >) as 'g + The universal variable 'b would escape its scope +|}];; + +type s = private < m : int; .. >;; + +module M : sig + val f : s -> s +end = struct + let f (x : ) = x +end;; +[%%expect{| +type s = private < m : int; .. > +Lines 5-7, characters 6-3: +5 | ......struct +6 | let f (x : ) = x +7 | end.. +Error: Signature mismatch: + Modules do not match: + sig val f : < m : int > -> < m : int > end + is not included in + sig val f : s -> s end + Values do not match: + val f : < m : int > -> < m : int > + is not included in + val f : s -> s + The type < m : int > -> < m : int > is not compatible with the type + s -> s + Type < m : int > is not compatible with type s = < m : int; .. > + The second object type has an abstract row, it cannot be closed +|}];; + +module M : sig + val f : 'a -> float +end = struct + let f : 'b -> int = fun _ -> 0 +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let f : 'b -> int = fun _ -> 0 +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig val f : 'b -> int end + is not included in + sig val f : 'a -> float end + Values do not match: + val f : 'b -> int + is not included in + val f : 'a -> float + The type 'a -> int is not compatible with the type 'a -> float + Type int is not compatible with type float +|}] + +module M : sig + val x : 'a list ref +end = struct + let x = ref [] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let x = ref [] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig val x : '_weak2 list ref end + is not included in + sig val x : 'a list ref end + Values do not match: + val x : '_weak2 list ref + is not included in + val x : 'a list ref + The type '_weak2 list ref is not compatible with the type 'a list ref + Type '_weak2 is not compatible with type 'a +|}];; + +module M = struct let r = ref [] end;; +type t;; +module N : sig val r : t list ref end = M;; +[%%expect{| +module M : sig val r : '_weak3 list ref end +type t +Line 3, characters 40-41: +3 | module N : sig val r : t list ref end = M;; + ^ +Error: Signature mismatch: + Modules do not match: + sig val r : '_weak3 list ref end + is not included in + sig val r : t list ref end + Values do not match: + val r : '_weak3 list ref + is not included in + val r : t list ref + The type '_weak3 list ref is not compatible with the type t list ref + The type constructor t would escape its scope +|}];; + +type (_, _) eq = Refl : ('a, 'a) eq;; + +module T : sig + type t + type s + val eq : (t, s) eq +end = struct + type t = int + type s = int + let eq = Refl +end;; + +module M = struct let r = ref [] end;; + +let foo p (e : (T.t, T.s) eq) (x : T.t) (y : T.s) = + match e with + | Refl -> + let z = if p then x else y in + let module N = struct + module type S = module type of struct let r = ref [z] end + end in + let module O : N.S = M in + ();; +[%%expect{| +type (_, _) eq = Refl : ('a, 'a) eq +module T : sig type t type s val eq : (t, s) eq end +module M : sig val r : '_weak4 list ref end +Line 22, characters 25-26: +22 | let module O : N.S = M in + ^ +Error: Signature mismatch: + Modules do not match: + sig val r : '_weak4 list ref end + is not included in + N.S + Values do not match: + val r : '_weak4 list ref + is not included in + val r : T.s list ref + The type '_weak4 list ref is not compatible with the type T.s list ref + Type '_weak4 is not compatible with type T.s = T.t + This instance of T.t is ambiguous: + it would escape the scope of its equation +|}];; + +module M: sig + val f : int -> float +end = struct + let f (x : 'a) = x +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let f (x : 'a) = x +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig val f : 'a -> 'a end + is not included in + sig val f : int -> float end + Values do not match: + val f : 'a -> 'a + is not included in + val f : int -> float + The type int -> int is not compatible with the type int -> float + Type int is not compatible with type float +|}];; + +module M: sig + val f : (int * float * int) -> (int -> int) +end = struct + let f (x : (int * int)) = x +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let f (x : (int * int)) = x +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig val f : int * int -> int * int end + is not included in + sig val f : int * float * int -> int -> int end + Values do not match: + val f : int * int -> int * int + is not included in + val f : int * float * int -> int -> int + The type int * int -> int * int is not compatible with the type + int * float * int -> int -> int + Type int * int is not compatible with type int * float * int +|}];; + +module M: sig + val f : -> +end = struct + let f (x : ) = x +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let f (x : ) = x +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig val f : < f : float; m : int > -> < f : float; m : int > end + is not included in + sig val f : < m : int; n : float > -> < m : int; n : float > end + Values do not match: + val f : < f : float; m : int > -> < f : float; m : int > + is not included in + val f : < m : int; n : float > -> < m : int; n : float > + The type < f : float; m : int > -> < f : float; m : int > + is not compatible with the type + < m : int; n : float > -> < m : int; n : float > + The second object type has no method f +|}];; + +module M : sig + val f : [`Foo] -> unit +end = struct + let f (x : [ `Foo | `Bar]) = () +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let f (x : [ `Foo | `Bar]) = () +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig val f : [ `Bar | `Foo ] -> unit end + is not included in + sig val f : [ `Foo ] -> unit end + Values do not match: + val f : [ `Bar | `Foo ] -> unit + is not included in + val f : [ `Foo ] -> unit + The type [ `Bar | `Foo ] -> unit is not compatible with the type + [ `Foo ] -> unit + The second variant type does not allow tag(s) `Bar +|}];; + +module M : sig + val f : [>`Foo] -> unit +end = struct + let f (x : [< `Foo]) = () +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let f (x : [< `Foo]) = () +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig val f : [< `Foo ] -> unit end + is not included in + sig val f : [> `Foo ] -> unit end + Values do not match: + val f : [< `Foo ] -> unit + is not included in + val f : [> `Foo ] -> unit + The type [< `Foo ] -> unit is not compatible with the type + [> `Foo ] -> unit + The second variant type is open and the first is not +|}];; + +module M : sig + val f : [< `Foo | `Bar] -> unit +end = struct + let f (x : [< `Foo]) = () +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let f (x : [< `Foo]) = () +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig val f : [< `Foo ] -> unit end + is not included in + sig val f : [< `Bar | `Foo ] -> unit end + Values do not match: + val f : [< `Foo ] -> unit + is not included in + val f : [< `Bar | `Foo ] -> unit + The type [< `Foo ] -> unit is not compatible with the type + [< `Bar | `Foo ] -> unit + The first variant type does not allow tag(s) `Bar +|}];; + +module M : sig + val f : < m : [< `Foo]> -> unit +end = struct + let f (x : < m : 'a. [< `Foo] as 'a >) = () +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let f (x : < m : 'a. [< `Foo] as 'a >) = () +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig val f : < m : 'a. [< `Foo ] as 'a > -> unit end + is not included in + sig val f : < m : [< `Foo ] > -> unit end + Values do not match: + val f : < m : 'a. [< `Foo ] as 'a > -> unit + is not included in + val f : < m : [< `Foo ] > -> unit + The type < m : 'a. [< `Foo ] as 'a > -> unit + is not compatible with the type < m : [< `Foo ] > -> unit + Types for method m are incompatible +|}];; + +module M : sig + val f : < m : 'a. [< `Foo] as 'a > -> unit +end = struct + let f (x : < m : [`Foo]>) = () +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let f (x : < m : [`Foo]>) = () +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig val f : < m : [ `Foo ] > -> unit end + is not included in + sig val f : < m : 'a. [< `Foo ] as 'a > -> unit end + Values do not match: + val f : < m : [ `Foo ] > -> unit + is not included in + val f : < m : 'a. [< `Foo ] as 'a > -> unit + The type < m : [ `Foo ] > -> unit is not compatible with the type + < m : 'a. [< `Foo ] as 'a > -> unit + Types for method m are incompatible +|}];; + +module M : sig + val f : [< `C] -> unit +end = struct + let f (x : [< `C of int&float]) = () +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let f (x : [< `C of int&float]) = () +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig val f : [< `C of int & float ] -> unit end + is not included in + sig val f : [< `C ] -> unit end + Values do not match: + val f : [< `C of int & float ] -> unit + is not included in + val f : [< `C ] -> unit + The type [< `C of & int & float ] -> unit + is not compatible with the type [< `C ] -> unit + Types for tag `C are incompatible +|}];; + +module M : sig + val f : [`Foo] -> unit +end = struct + let f (x : [`Foo of int]) = () +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let f (x : [`Foo of int]) = () +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig val f : [ `Foo of int ] -> unit end + is not included in + sig val f : [ `Foo ] -> unit end + Values do not match: + val f : [ `Foo of int ] -> unit + is not included in + val f : [ `Foo ] -> unit + The type [ `Foo of int ] -> unit is not compatible with the type + [ `Foo ] -> unit + Types for tag `Foo are incompatible +|}];; + +module M : sig + val f : [`Foo of int] -> unit +end = struct + let f (x : [`Foo]) = () +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let f (x : [`Foo]) = () +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig val f : [ `Foo ] -> unit end + is not included in + sig val f : [ `Foo of int ] -> unit end + Values do not match: + val f : [ `Foo ] -> unit + is not included in + val f : [ `Foo of int ] -> unit + The type [ `Foo ] -> unit is not compatible with the type + [ `Foo of int ] -> unit + Types for tag `Foo are incompatible +|}];; + +module M : sig + val f : [< `Foo | `Bar | `Baz] -> unit +end = struct + let f (x : [< `Foo | `Bar | `Baz]) = () +end;; +[%%expect{| +module M : sig val f : [< `Bar | `Baz | `Foo ] -> unit end +|}];; + +module M : sig + val f : [< `Foo | `Bar | `Baz] -> unit +end = struct + let f (x : [> `Foo | `Bar]) = () +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let f (x : [> `Foo | `Bar]) = () +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig val f : [> `Bar | `Foo ] -> unit end + is not included in + sig val f : [< `Bar | `Baz | `Foo ] -> unit end + Values do not match: + val f : [> `Bar | `Foo ] -> unit + is not included in + val f : [< `Bar | `Baz | `Foo ] -> unit + The type [> `Bar | `Foo ] -> unit is not compatible with the type + [< `Bar | `Baz | `Foo ] -> unit + The tag `Foo is guaranteed to be present in the first variant type, + but not in the second +|}];; + +(******************************* Type manifests *******************************) + +module M : sig + type t = private [< `A | `B] +end = struct + type t = [`C] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = [`C] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = [ `C ] end + is not included in + sig type t = private [< `A | `B ] end + Type declarations do not match: + type t = [ `C ] + is not included in + type t = private [< `A | `B ] + The constructor C is only present in the second declaration. +|}];; + +module M : sig + type t = private [< `A | `B] +end = struct + type t = private [> `A] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private [> `A] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private [> `A ] end + is not included in + sig type t = private [< `A | `B ] end + Type declarations do not match: + type t = private [> `A ] + is not included in + type t = private [< `A | `B ] + The second is private and closed, but the first is not closed +|}];; + +module M : sig + type t = private [< `A | `B > `A] +end = struct + type t = [`B] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = [`B] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = [ `B ] end + is not included in + sig type t = private [< `A | `B > `A ] end + Type declarations do not match: + type t = [ `B ] + is not included in + type t = private [< `A | `B > `A ] + The constructor A is only present in the first declaration. +|}];; + +module M : sig + type t = private [> `A of int] +end = struct + type t = [`A] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = [`A] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = [ `A ] end + is not included in + sig type t = private [> `A of int ] end + Type declarations do not match: + type t = [ `A ] + is not included in + type t = private [> `A of int ] + Types for tag `A are incompatible +|}];; + +module M : sig + type t = private [< `A of int] +end = struct + type t = private [< `A of & int] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private [< `A of & int] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private [< `A of & int ] end + is not included in + sig type t = private [< `A of int ] end + Type declarations do not match: + type t = private [< `A of & int ] + is not included in + type t = private [< `A of int ] + Types for tag `A are incompatible +|}];; + + +module M : sig + type t = private [< `A of int] +end = struct + type t = private [< `A] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private [< `A] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private [< `A ] end + is not included in + sig type t = private [< `A of int ] end + Type declarations do not match: + type t = private [< `A ] + is not included in + type t = private [< `A of int ] + Types for tag `A are incompatible +|}];; + + +module M : sig + type t = private [< `A of int & float] +end = struct + type t = private [< `A] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private [< `A] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private [< `A ] end + is not included in + sig type t = private [< `A of int & float ] end + Type declarations do not match: + type t = private [< `A ] + is not included in + type t = private [< `A of int & float ] + Types for tag `A are incompatible +|}];; + +module M : sig + type t = private [> `A of int] +end = struct + type t = [`A of float] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = [`A of float] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = [ `A of float ] end + is not included in + sig type t = private [> `A of int ] end + Type declarations do not match: + type t = [ `A of float ] + is not included in + type t = private [> `A of int ] + The type float is not equal to the type int +|}];; + +module M : sig + type t = private [< `A | `B] +end = struct + type t = private [`A | `B] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private [`A | `B] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private [ `A | `B ] end + is not included in + sig type t = private [< `A | `B ] end + Type declarations do not match: + type t = private [ `A | `B ] + is not included in + type t = private [< `A | `B ] + The type [ `A | `B ] is not equal to the type [< `A | `B ] + The tag `B is guaranteed to be present in the first variant type, + but not in the second +|}];; + +module M : sig + type t = [`A | `B] +end = struct + type t = private [`A | `B] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private [`A | `B] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private [ `A | `B ] end + is not included in + sig type t = [ `A | `B ] end + Type declarations do not match: + type t = private [ `A | `B ] + is not included in + type t = [ `A | `B ] + A private type abbreviation would be revealed. +|}];; + +module M : sig + type t = private [< `A | `B > `B] +end = struct + type t = private [< `A | `B] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private [< `A | `B] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private [< `A | `B ] end + is not included in + sig type t = private [< `A | `B > `B ] end + Type declarations do not match: + type t = private [< `A | `B ] + is not included in + type t = private [< `A | `B > `B ] + The tag `B is present in the the second declaration, + but might not be in the the first +|}];; + +module M : sig + type t = private +end = struct + type t = +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = < b : int > end + is not included in + sig type t = private < a : int; .. > end + Type declarations do not match: + type t = < b : int > + is not included in + type t = private < a : int; .. > + The implementation is missing the method a +|}];; + +module M : sig + type t = private +end = struct + type t = +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = < a : int > end + is not included in + sig type t = private < a : float; .. > end + Type declarations do not match: + type t = < a : int > + is not included in + type t = private < a : float; .. > + The type int is not equal to the type float + Type int is not equal to type float +|}];; + +type w = private float +type q = private (int * w) +type u = private (int * q) +module M : sig (* Confussing error message :( *) + type t = private (int * (int * int)) +end = struct + type t = private u +end;; +[%%expect{| +type w = private float +type q = private int * w +type u = private int * q +Lines 6-8, characters 6-3: +6 | ......struct +7 | type t = private u +8 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private u end + is not included in + sig type t = private int * (int * int) end + Type declarations do not match: + type t = private u + is not included in + type t = private int * (int * int) + The type int * q is not equal to the type int * (int * int) + Type q is not equal to type int * int +|}];; + +type w = float +type q = (int * w) +type u = private (int * q) +module M : sig + type t = private (int * (int * int)) +end = struct + type t = private u +end;; +[%%expect{| +type w = float +type q = int * w +type u = private int * q +Lines 6-8, characters 6-3: +6 | ......struct +7 | type t = private u +8 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private u end + is not included in + sig type t = private int * (int * int) end + Type declarations do not match: + type t = private u + is not included in + type t = private int * (int * int) + The type int * q is not equal to the type int * (int * int) + Type q = int * w is not equal to type int * int + Type w = float is not equal to type int +|}];; + +type s = private int + +module M : sig + type t = private float +end = struct + type t = private s +end;; +[%%expect{| +type s = private int +Lines 5-7, characters 6-3: +5 | ......struct +6 | type t = private s +7 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private s end + is not included in + sig type t = private float end + Type declarations do not match: + type t = private s + is not included in + type t = private float + The type int is not equal to the type float +|}];; + +module M : sig + type t = A +end = struct + type t = private A +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private A +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private A end + is not included in + sig type t = A end + Type declarations do not match: + type t = private A + is not included in + type t = A + Private variant constructor(s) would be revealed. +|}];; + +module M : sig + type t = A | B +end = struct + type t = private A | B +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private A | B +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private A | B end + is not included in + sig type t = A | B end + Type declarations do not match: + type t = private A | B + is not included in + type t = A | B + Private variant constructor(s) would be revealed. +|}];; + +module M : sig + type t = A of { x : int; y : bool } +end = struct + type t = private A of { x : int; y : bool } +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private A of { x : int; y : bool } +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private A of { x : int; y : bool; } end + is not included in + sig type t = A of { x : int; y : bool; } end + Type declarations do not match: + type t = private A of { x : int; y : bool; } + is not included in + type t = A of { x : int; y : bool; } + Private variant constructor(s) would be revealed. +|}];; + +module M : sig + type t = { x : int; y : bool } +end = struct + type t = private { x : int; y : bool } +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private { x : int; y : bool } +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private { x : int; y : bool; } end + is not included in + sig type t = { x : int; y : bool; } end + Type declarations do not match: + type t = private { x : int; y : bool; } + is not included in + type t = { x : int; y : bool; } + A private record constructor would be revealed. +|}];; + +module M : sig + type t = A +end = struct + type t = private A | B +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private A | B +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private A | B end + is not included in + sig type t = A end + Type declarations do not match: + type t = private A | B + is not included in + type t = A + Private variant constructor(s) would be revealed. +|}];; + +module M : sig + type t = A | B +end = struct + type t = private A +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private A +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private A end + is not included in + sig type t = A | B end + Type declarations do not match: + type t = private A + is not included in + type t = A | B + Private variant constructor(s) would be revealed. +|}];; + +module M : sig + type t = { x : int } +end = struct + type t = private { x : int; y : bool } +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private { x : int; y : bool } +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private { x : int; y : bool; } end + is not included in + sig type t = { x : int; } end + Type declarations do not match: + type t = private { x : int; y : bool; } + is not included in + type t = { x : int; } + A private record constructor would be revealed. +|}];; + +module M : sig + type t = { x : int; y : bool } +end = struct + type t = private { x : int } +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private { x : int } +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private { x : int; } end + is not included in + sig type t = { x : int; y : bool; } end + Type declarations do not match: + type t = private { x : int; } + is not included in + type t = { x : int; y : bool; } + A private record constructor would be revealed. +|}];; + +module M : sig + type t = A | B +end = struct + type t = private { x : int; y : bool } +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private { x : int; y : bool } +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private { x : int; y : bool; } end + is not included in + sig type t = A | B end + Type declarations do not match: + type t = private { x : int; y : bool; } + is not included in + type t = A | B + Their kinds differ. +|}];; + +module M : sig + type t = { x : int; y : bool } +end = struct + type t = private A | B +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private A | B +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private A | B end + is not included in + sig type t = { x : int; y : bool; } end + Type declarations do not match: + type t = private A | B + is not included in + type t = { x : int; y : bool; } + Their kinds differ. +|}];; + +module M : sig + type t = [`A] +end = struct + type t = private [> `A | `B] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private [> `A | `B] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private [> `A | `B ] end + is not included in + sig type t = [ `A ] end + Type declarations do not match: + type t = private [> `A | `B ] + is not included in + type t = [ `A ] + A private row type would be revealed. +|}];; + +module M : sig + type t = [`A] +end = struct + type t = private [< `A | `B] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private [< `A | `B] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private [< `A | `B ] end + is not included in + sig type t = [ `A ] end + Type declarations do not match: + type t = private [< `A | `B ] + is not included in + type t = [ `A ] + A private row type would be revealed. +|}];; + +module M : sig + type t = [`A] +end = struct + type t = private [< `A | `B > `A] +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private [< `A | `B > `A] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private [< `A | `B > `A ] end + is not included in + sig type t = [ `A ] end + Type declarations do not match: + type t = private [< `A | `B > `A ] + is not included in + type t = [ `A ] + A private row type would be revealed. +|}];; + +module M : sig + type t = < m : int > +end = struct + type t = private < m : int; .. > +end;; +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = private < m : int; .. > +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig type t = private < m : int; .. > end + is not included in + sig type t = < m : int > end + Type declarations do not match: + type t = private < m : int; .. > + is not included in + type t = < m : int > + A private row type would be revealed. +|}];; + + +(** Unexpected recursive types *) +module M: sig + type _ t = A : ( as 'a) -> ( as 'b) t +end = struct + type _ t = A : ( as 'a) -> ( as 'b) t +end +[%%expect {| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type _ t = A : ( as 'a) -> ( as 'b) t +5 | end +Error: Signature mismatch: + Modules do not match: + sig + type _ t = A : (< x : 'b * 'b > as 'b) -> (< y : 'a > as 'a) t + end + is not included in + sig type _ t = A : (< x : 'b > as 'b) -> (< y : 'a > as 'a) t end + Type declarations do not match: + type _ t = A : (< x : 'b * 'b > as 'b) -> (< y : 'a > as 'a) t + is not included in + type _ t = A : (< x : 'b > as 'b) -> (< y : 'a > as 'a) t + Constructors do not match: + A : (< x : 'b * 'b > as 'b) -> (< y : 'a > as 'a) t + is not the same as: + A : (< x : 'b > as 'b) -> (< y : 'a > as 'a) t + The type < x : 'a * 'a > as 'a is not equal to the type + < x : 'b > as 'b + Types for method x are incompatible +|}] +module R: sig + type t = { a: ( as 'a) } +end = struct + type t = { a: ( as 'a) } +end +[%%expect {| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = { a: ( as 'a) } +5 | end +Error: Signature mismatch: + Modules do not match: + sig type t = { a : < x : 'a * 'a > as 'a; } end + is not included in + sig type t = { a : < x : 'a > as 'a; } end + Type declarations do not match: + type t = { a : < x : 'a * 'a > as 'a; } + is not included in + type t = { a : < x : 'a > as 'a; } + Fields do not match: + a : < x : 'a * 'a > as 'a; + is not the same as: + a : < x : 'a > as 'a; + The type < x : 'a * 'a > as 'a is not equal to the type + < x : 'b > as 'b + Types for method x are incompatible +|}] +type _ ext = .. +module Ext: sig + type _ ext += A : ( as 'a) -> ( as 'b) ext +end = struct + type _ ext += A : ( as 'a) -> ( as 'b) ext +end +[%%expect {| +type _ ext = .. +Lines 4-6, characters 6-3: +4 | ......struct +5 | type _ ext += A : ( as 'a) -> ( as 'b) ext +6 | end +Error: Signature mismatch: + Modules do not match: + sig + type _ ext += + A : (< x : 'b * 'b > as 'b) -> (< y : 'a > as 'a) ext + end + is not included in + sig + type _ ext += A : (< x : 'b > as 'b) -> (< y : 'a > as 'a) ext + end + Extension declarations do not match: + type _ ext += A : (< x : 'b * 'b > as 'b) -> (< y : 'a > as 'a) ext + is not included in + type _ ext += A : (< x : 'b > as 'b) -> (< y : 'a > as 'a) ext + Constructors do not match: + A : (< x : 'b * 'b > as 'b) -> (< y : 'a > as 'a) ext + is not the same as: + A : (< x : 'b > as 'b) -> (< y : 'a > as 'a) ext + The type < x : 'a * 'a > as 'a is not equal to the type + < x : 'b > as 'b + Types for method x are incompatible +|}] diff --git a/ocaml/testsuite/tests/typing-modules/inclusion_errors_elision.ml b/ocaml/testsuite/tests/typing-modules/inclusion_errors_elision.ml new file mode 100644 index 00000000000..3dbd0e67fff --- /dev/null +++ b/ocaml/testsuite/tests/typing-modules/inclusion_errors_elision.ml @@ -0,0 +1,93 @@ +(* TEST + flags ="-keep-original-error-size" + * expect + *) + + +module A = struct + type a and b and c and d +end + +module type S = sig + module B = A +end + +module C : S = struct + module B = struct + type a and b and c and d and e and f and g and h + end +end +[%%expect {| +module A : sig type a and b and c and d end +module type S = sig module B = A end +Lines 9-13, characters 15-3: + 9 | ...............struct +10 | module B = struct +11 | type a and b and c and d and e and f and g and h +12 | end +13 | end +Error: Signature mismatch: + ... + In module B: + Modules do not match: + sig + type a = B.a + and b = B.b + and c = B.c + and d = B.d + and e = B.e + and f = B.f + and g = B.g + and h = B.h + end + is not included in + (module A) +|}] + +module A = struct + type a and b and c and d +end + +module type S = sig + module type B = sig + module C = A + end +end + +module D : S = struct + module type B = sig + module C: sig + type a and b and c and d and e and f and g and h + end + end +end +[%%expect{| +module A : sig type a and b and c and d end +module type S = sig module type B = sig module C = A end end +Lines 11-17, characters 15-3: +11 | ...............struct +12 | module type B = sig +13 | module C: sig +14 | type a and b and c and d and e and f and g and h +15 | end +16 | end +17 | end +Error: Signature mismatch: + ... + ... + ... + At position module type B = sig module C : end + Modules do not match: + sig + type a = C.a + and b = C.b + and c = C.c + and d = C.d + and e = C.e + and f = C.f + and g = C.g + and h = C.h + end + is not included in + (module A) +|}] diff --git a/ocaml/testsuite/tests/typing-modules/merge_constraint.ml b/ocaml/testsuite/tests/typing-modules/merge_constraint.ml index a26bf835a7a..a1ac0ea2c68 100644 --- a/ocaml/testsuite/tests/typing-modules/merge_constraint.ml +++ b/ocaml/testsuite/tests/typing-modules/merge_constraint.ml @@ -146,8 +146,8 @@ module CorrectEnvConstructionTest : and +'a abstract module M : sig - type 'a user = 'a user = Foo of 'a abstract - and 'a abstract = 'a abstract + type 'a user = 'a user = Foo of 'a abstract/1 + and 'a abstract = 'a abstract/2 end type 'a foo = 'a M.user end @@ -246,3 +246,177 @@ module type Weird = module P : sig module M : sig type t = M.t type u = M.u end end end |}] + +(* Recursion issues *) + +(* Should fail rather than stack overflow *) +module type S = sig + type 'a t = 'a + constraint 'a = < m : r > + and r = (< m : r >) t + end + +module type T = S with type 'a t = 'b constraint 'a = < m : 'b >;; +[%%expect{| +module type S = + sig type 'a t = 'a constraint 'a = < m : r > and r = < m : r > t end +Uncaught exception: Stack overflow + +|}] + +(* Correct *) +module type S = sig + type t = Foo of r + and r = t + end + +type s = Foo of s + +module type T = S with type t = s +[%%expect{| +module type S = sig type t = Foo of r and r = t end +type s = Foo of s +module type T = sig type t = s = Foo of r and r = t end +|}] + +(* Correct *) +module type S = sig + type r = t + and t = Foo of r + end + +type s = Foo of s + +module type T = S with type t = s +[%%expect{| +module type S = sig type r = t and t = Foo of r end +type s = Foo of s +module type T = sig type r = t and t = s = Foo of r end +|}] + +(* Should succeed *) +module type S = sig + module rec M : sig + type t = Foo of M.r + type r = t + end + end + +type s = Foo of s + +module type T = S with type M.t = s +[%%expect{| +module type S = sig module rec M : sig type t = Foo of M.r type r = t end end +type s = Foo of s +Line 10, characters 23-35: +10 | module type T = S with type M.t = s + ^^^^^^^^^^^^ +Error: This variant or record definition does not match that of type s + Constructors do not match: + Foo of s + is not the same as: + Foo of M.r + The type s is not equal to the type M.r = M.t +|}] + +(* Should succeed *) +module type S = sig + module rec M : sig + type t = private [`Foo of M.r] + type r = t + end + end + +type s = [`Foo of s] + +module type T = S with type M.t = s +[%%expect{| +module type S = + sig module rec M : sig type t = private [ `Foo of M.r ] type r = t end end +type s = [ `Foo of s ] +Line 10, characters 16-35: +10 | module type T = S with type M.t = s + ^^^^^^^^^^^^^^^^^^^ +Error: In this `with' constraint, the new definition of M.t + does not match its original definition in the constrained signature: + Type declarations do not match: + type t = s + is not included in + type t = private [ `Foo of M.r ] + The type s = [ `Foo of s ] is not equal to the type [ `Foo of M.r ] + Type s = [ `Foo of s ] is not equal to type M.r = M.t + Types for tag `Foo are incompatible +|}] + +(* Should succeed *) +module type S = sig + module rec M : sig + module N : sig type t = private [`Foo of M.r] end + type r = M.N.t + end +end + +module X = struct type t = [`Foo of t] end + +module type T = S with module M.N = X +[%%expect{| +module type S = + sig + module rec M : + sig + module N : sig type t = private [ `Foo of M.r ] end + type r = M.N.t + end + end +module X : sig type t = [ `Foo of t ] end +Line 10, characters 16-37: +10 | module type T = S with module M.N = X + ^^^^^^^^^^^^^^^^^^^^^ +Error: In this `with' constraint, the new definition of M.N + does not match its original definition in the constrained signature: + Modules do not match: + sig type t = [ `Foo of t ] end + is not included in + sig type t = private [ `Foo of M.r ] end + Type declarations do not match: + type t = [ `Foo of t ] + is not included in + type t = private [ `Foo of M.r ] + The type [ `Foo of t ] is not equal to the type [ `Foo of M.r ] + Type t = [ `Foo of t ] is not equal to type M.r = M.N.t + Types for tag `Foo are incompatible +|}] + +(* Should succeed *) +module type S = sig + module rec M : sig + module N : sig type t = M.r type s end + type r = N.s + end + end + +module X = struct type t type s = t end + +module type T = S with module M.N = X +[%%expect{| +module type S = + sig + module rec M : + sig module N : sig type t = M.r type s end type r = N.s end + end +module X : sig type t type s = t end +Line 10, characters 16-37: +10 | module type T = S with module M.N = X + ^^^^^^^^^^^^^^^^^^^^^ +Error: In this `with' constraint, the new definition of M.N + does not match its original definition in the constrained signature: + Modules do not match: + sig type t = X.t type s = t end + is not included in + sig type t = M.r type s end + Type declarations do not match: + type t = X.t + is not included in + type t = M.r + The type X.t is not equal to the type M.r = M.N.s +|}] diff --git a/ocaml/testsuite/tests/typing-modules/module_type_substitution.ml b/ocaml/testsuite/tests/typing-modules/module_type_substitution.ml new file mode 100644 index 00000000000..09f16ce7be5 --- /dev/null +++ b/ocaml/testsuite/tests/typing-modules/module_type_substitution.ml @@ -0,0 +1,278 @@ +(* TEST + * expect +*) + +(** Basic *) +module type x = sig type t = int end + +module type t = sig + module type x + module M:x +end + +module type t' = t with module type x = x +[%%expect {| +module type x = sig type t = int end +module type t = sig module type x module M : x end +module type t' = sig module type x = x module M : x end +|}] + +module type t'' = t with module type x := x +[%%expect {| +module type t'' = sig module M : x end +|}] + +module type t3 = t with module type x = sig type t end +[%%expect {| +module type t3 = sig module type x = sig type t end module M : x end +|}] + +module type t4 = t with module type x := sig type t end +[%%expect {| +module type t4 = sig module M : sig type t end end +|}] + +(** nested *) + +module type ENDO = sig + module Inner: + sig + module type T + module F: T -> T + end +end +module type ENDO_2 = ENDO with module type Inner.T = ENDO +module type ENDO_2' = ENDO with module type Inner.T := ENDO +[%%expect {| +module type ENDO = + sig module Inner : sig module type T module F : T -> T end end +module type ENDO_2 = + sig module Inner : sig module type T = ENDO module F : T -> T end end +module type ENDO_2' = sig module Inner : sig module F : ENDO -> ENDO end end +|}] + + +module type S = sig + module M: sig + module type T + end + module N: M.T +end +module type R = S with module type M.T := sig end +[%%expect {| +module type S = sig module M : sig module type T end module N : M.T end +module type R = sig module M : sig end module N : sig end end +|}] + + +(** Adding equalities *) + +module type base = sig type t = X of int | Y of float end + +module type u = sig + module type t = sig type t = X of int | Y of float end + module M: t +end + +module type s = u with module type t := base +[%%expect {| +module type base = sig type t = X of int | Y of float end +module type u = + sig module type t = sig type t = X of int | Y of float end module M : t end +module type s = sig module M : base end +|}] + + +module type base = sig type t = X of int | Y of float end + +module type u = sig + type x + type y + module type t = sig type t = X of x | Y of y end + module M: t +end + +module type r = + u with type x = int + and type y = float + and module type t = base +[%%expect {| +module type base = sig type t = X of int | Y of float end +module type u = + sig + type x + type y + module type t = sig type t = X of x | Y of y end + module M : t + end +module type r = + sig type x = int type y = float module type t = base module M : t end +|}] + +module type r = + u with type x = int + and type y = float + and module type t := base +[%%expect {| +module type r = sig type x = int type y = float module M : base end +|}] + + +module type r = + u with type x := int + and type y := float + and module type t := base +[%%expect {| +module type r = sig module M : base end +|}] + +(** error *) + +module type r = + u with module type t := base + +[%%expect {| +Line 4, characters 2-30: +4 | u with module type t := base + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: In this `with' constraint, the new definition of t + does not match its original definition in the constrained signature: + At position module type t = + Module types do not match: + sig type t = X of x | Y of y end + is not equal to + base + At position module type t = + Type declarations do not match: + type t = X of x | Y of y + is not included in + type t = X of int | Y of float + 1. Constructors do not match: + X of x + is not the same as: + X of int + The type x is not equal to the type int + 2. Constructors do not match: + Y of y + is not the same as: + Y of float + The type y is not equal to the type float +|}] + +(** First class module types require an identity *) + +module type fst = sig + module type t + val x: (module t) +end + +module type ext +module type fst_ext = fst with module type t = ext +module type fst_ext = fst with module type t := ext +[%%expect {| +module type fst = sig module type t val x : (module t) end +module type ext +module type fst_ext = sig module type t = ext val x : (module t) end +module type fst_ext = sig val x : (module ext) end +|}] + + + +module type fst_erased = fst with module type t := sig end +[%%expect {| +Line 1, characters 25-58: +1 | module type fst_erased = fst with module type t := sig end + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This `with' constraint t := sig end makes a packed module ill-formed. +|}] + +module type fst_ok = fst with module type t = sig end +[%%expect {| +module type fst_ok = sig module type t = sig end val x : (module t) end +|}] + +module type S = sig + module M: sig + module type T + end + val x: (module M.T) +end + +module type R = S with module type M.T := sig end +[%%expect {| +module type S = sig module M : sig module type T end val x : (module M.T) end +Line 8, characters 16-49: +8 | module type R = S with module type M.T := sig end + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This `with' constraint M.T := sig end + makes a packed module ill-formed. +|}] + + +module type S = sig + module M: sig + module type T + val x: (module T) + end +end + +module type R = S with module type M.T := sig end +[%%expect {| +module type S = sig module M : sig module type T val x : (module T) end end +Line 8, characters 16-49: +8 | module type R = S with module type M.T := sig end + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This `with' constraint T := sig end makes a packed module ill-formed. +|}] + + +(** local module type substitutions *) + +module type s = sig + module type u := sig type a type b type c end + module type r = sig type r include u end + module type s = sig include u type a = A end +end +[%%expect {| +module type s = + sig + module type r = sig type r type a type b type c end + module type s = sig type b type c type a = A end + end +|}] + + +module type s = sig + module type u := sig type a type b type c end + module type wrong = sig type a include u end +end +[%%expect {| +Line 3, characters 33-42: +3 | module type wrong = sig type a include u end + ^^^^^^^^^ +Error: Multiple definition of the type name a. + Names must be unique in a given structure or signature. +|}] + +module type fst = sig + module type t := sig end + val x: (module t) +end +[%%expect {| +Line 3, characters 2-19: +3 | val x: (module t) + ^^^^^^^^^^^^^^^^^ +Error: The module type t is not a valid type for a packed module: + it is defined as a local substitution for a non-path module type. +|}] + + +module type hidden = sig + module type t := sig type u end + include t + val x: (module t) + val x: int +end +[%%expect {| +module type hidden = sig type u val x : int end +|}] diff --git a/ocaml/testsuite/tests/typing-modules/nondep.ml b/ocaml/testsuite/tests/typing-modules/nondep.ml index cade70753de..36e541127f5 100644 --- a/ocaml/testsuite/tests/typing-modules/nondep.ml +++ b/ocaml/testsuite/tests/typing-modules/nondep.ml @@ -35,3 +35,24 @@ module M : sig module type S = sig type t = float val foo : t X.t end end module N : sig module type S = sig type t = float val foo : int end end |}] + +type 'a always_int = int +module F (X : sig type t end) = struct type s = X.t always_int end +module M = F (struct type t = T end) +[%%expect{| +type 'a always_int = int +module F : functor (X : sig type t end) -> sig type s = X.t always_int end +module M : sig type s = int end +|}] + +module M = struct + module F (X : sig type t end) = X + module Not_ok = F (struct type t = private [< `A] end) +end +[%%expect{| +module M : + sig + module F : functor (X : sig type t end) -> sig type t = X.t end + module Not_ok : sig type t end + end +|}] diff --git a/ocaml/testsuite/tests/typing-modules/nondep_private_abbrev.ml b/ocaml/testsuite/tests/typing-modules/nondep_private_abbrev.ml index 4c8e4e1e342..a0daa1fb95e 100644 --- a/ocaml/testsuite/tests/typing-modules/nondep_private_abbrev.ml +++ b/ocaml/testsuite/tests/typing-modules/nondep_private_abbrev.ml @@ -83,6 +83,19 @@ module IndirectPriv = I(struct end);; module IndirectPriv : sig type t end |}] +(* These two behave as though a functor was defined *) +module DirectPrivEta = + (functor (X : sig end) -> Priv(X))(struct end);; +[%%expect{| +module DirectPrivEta : sig type t end +|}] + +module DirectPrivEtaUnit = + (functor (_ : sig end) -> Priv)(struct end)(struct end);; +[%%expect{| +module DirectPrivEtaUnit : sig type t end +|}] + (*** Test proposed by Jacques in https://github.com/ocaml/ocaml/pull/1826#discussion_r194290729 ***) @@ -112,6 +125,9 @@ Error: Signature mismatch: type s = t is not included in type s = private [ `Bar of int | `Foo of 'a -> int ] as 'a + The type [ `Bar of int | `Foo of t -> int ] is not equal to the type + [ `Bar of int | `Foo of 'a -> int ] as 'a + Types for tag `Foo are incompatible |}] (* nondep_type_decl + nondep_type_rec *) diff --git a/ocaml/testsuite/tests/typing-modules/packed_module_levels.ml b/ocaml/testsuite/tests/typing-modules/packed_module_levels.ml new file mode 100644 index 00000000000..a4883d00deb --- /dev/null +++ b/ocaml/testsuite/tests/typing-modules/packed_module_levels.ml @@ -0,0 +1,42 @@ +(* TEST + * expect +*) +type (_, _) equ = Refl : ('q, 'q) equ + +module type Ty = sig type t end +type 'a modu = (module Ty with type t = 'a) + +type 'q1 packed = + P : 'q0 modu * ('q0, 'q1) equ -> 'q1 packed + +(* Adds a module M to the environment where M.t equals an existential *) +let repack (type q) (x : q packed) : q modu = + match x with + | P (p, eq) -> + let module M = (val p) in + let Refl = eq in + (module M) + +[%%expect{| +type (_, _) equ = Refl : ('q, 'q) equ +module type Ty = sig type t end +type 'a modu = (module Ty with type t = 'a) +type 'q1 packed = P : 'q0 modu * ('q0, 'q1) equ -> 'q1 packed +val repack : 'q packed -> 'q modu = +|}] + +(* Same, using a polymorphic function rather than an existential *) + +let mkmod (type a) () : a modu = + (module struct type t = a end) + +let f (type foo) (intish : (foo, int) equ) = + let module M = (val (mkmod () : foo modu)) in + let Refl = intish in + let module C : sig type t = int end = M in + () + +[%%expect{| +val mkmod : unit -> 'a modu = +val f : ('foo, int) equ -> unit = +|}] diff --git a/ocaml/testsuite/tests/typing-modules/pr10298.ml b/ocaml/testsuite/tests/typing-modules/pr10298.ml new file mode 100644 index 00000000000..58a9509cd70 --- /dev/null +++ b/ocaml/testsuite/tests/typing-modules/pr10298.ml @@ -0,0 +1,22 @@ +(* TEST + * expect +*) + +module type S = sig type t end +module Res_ko = + (functor (X : S) -> X)(struct type t = int end) +[%%expect{| +module type S = sig type t end +module Res_ko : sig type t = int end +|}] + +module Res_ok2 = + (functor (X : S) -> struct include X end) (struct type t = int end) +[%%expect{| +module Res_ok2 : sig type t = int end +|}] +module Res_ok3 = + (functor (X : S) -> struct type t = X.t end) (struct type t = int end) +[%%expect{| +module Res_ok3 : sig type t = int end +|}] diff --git a/ocaml/testsuite/tests/typing-modules/pr10399.ml b/ocaml/testsuite/tests/typing-modules/pr10399.ml new file mode 100644 index 00000000000..cce02f41a21 --- /dev/null +++ b/ocaml/testsuite/tests/typing-modules/pr10399.ml @@ -0,0 +1,46 @@ +(* TEST + * expect +*) + +(* From jctis: *) + +module PR10399 : sig + type t = < x : int > + + class c : object method x : int method y : bool end + + val o : t +end = struct + type t = < x : int > + + class c = object method x = 3 method y = true end + + let o = new c +end + +[%%expect{| +Lines 7-13, characters 6-3: + 7 | ......struct + 8 | type t = < x : int > + 9 | +10 | class c = object method x = 3 method y = true end +11 | +12 | let o = new c +13 | end +Error: Signature mismatch: + Modules do not match: + sig + type t = < x : int > + class c : object method x : int method y : bool end + val o : c + end + is not included in + sig + type t = < x : int > + class c : object method x : int method y : bool end + val o : t + end + Values do not match: val o : c is not included in val o : t + The type c is not compatible with the type t + The second object type has no method y +|}] diff --git a/ocaml/testsuite/tests/typing-modules/pr6394.ml b/ocaml/testsuite/tests/typing-modules/pr6394.ml index 97bbeebf1ec..d785fb50651 100644 --- a/ocaml/testsuite/tests/typing-modules/pr6394.ml +++ b/ocaml/testsuite/tests/typing-modules/pr6394.ml @@ -24,4 +24,5 @@ Error: Signature mismatch: type t = X.t = A | B is not included in type t = int * bool + The type X.t is not equal to the type int * bool |}];; diff --git a/ocaml/testsuite/tests/typing-modules/pr7818.ml b/ocaml/testsuite/tests/typing-modules/pr7818.ml index 84f7d8f702f..922b190239e 100644 --- a/ocaml/testsuite/tests/typing-modules/pr7818.ml +++ b/ocaml/testsuite/tests/typing-modules/pr7818.ml @@ -323,7 +323,10 @@ Line 15, characters 0-69: Error: This variant or record definition does not match that of type M.t Constructors do not match: E of (MkT(M.T).t, MkT(M.T).t) eq - is not compatible with: + is not the same as: E of (MkT(Desc).t, MkT(Desc).t) eq - The types are not equal. + The type (MkT(M.T).t, MkT(M.T).t) eq is not equal to the type + (MkT(Desc).t, MkT(Desc).t) eq + Type MkT(M.T).t = Set.Make(M.Term0).t is not equal to type + MkT(Desc).t = Set.Make(Desc).t |}] diff --git a/ocaml/testsuite/tests/typing-modules/pr7851.ml b/ocaml/testsuite/tests/typing-modules/pr7851.ml index bcd3281bedc..9e1eef73a10 100644 --- a/ocaml/testsuite/tests/typing-modules/pr7851.ml +++ b/ocaml/testsuite/tests/typing-modules/pr7851.ml @@ -29,9 +29,9 @@ Line 1, characters 0-58: Error: This variant or record definition does not match that of type M1.t Constructors do not match: E of M1.x - is not compatible with: + is not the same as: E of M1.y - The types are not equal. + The type M1.x = int is not equal to the type M1.y = bool |}] let bool_of_int x = @@ -81,7 +81,8 @@ Line 1, characters 0-58: Error: This variant or record definition does not match that of type M1.t Constructors do not match: E of (M1.x, M1.x) eq - is not compatible with: + is not the same as: E of (M1.x, M1.y) eq - The types are not equal. + The type (M1.x, M1.x) eq is not equal to the type (M1.x, M1.y) eq + Type M1.x = int is not equal to type M1.y = bool |}] diff --git a/ocaml/testsuite/tests/typing-modules/private.ml b/ocaml/testsuite/tests/typing-modules/private.ml new file mode 100644 index 00000000000..940c1eb6a98 --- /dev/null +++ b/ocaml/testsuite/tests/typing-modules/private.ml @@ -0,0 +1,31 @@ +(* TEST + * expect + *) + +module M : + sig type t = private [< `A | `B of string] end += struct type t = [`A|`B of string] end;; +[%%expect{| +module M : sig type t = private [< `A | `B of string ] end +|}] + +module M = struct type header_item_tag = + [ `CO | `HD | `Other of string | `PG | `RG | `SQ ] +end;; +[%%expect{| +module M : + sig + type header_item_tag = [ `CO | `HD | `Other of string | `PG | `RG | `SQ ] + end +|}] + +module M' : sig type header_item_tag = + private [< `CO | `HD | `Other of string | `PG | `RG | `SQ ] +end = M;; +[%%expect{| +module M' : + sig + type header_item_tag = private + [< `CO | `HD | `Other of string | `PG | `RG | `SQ ] + end +|}] diff --git a/ocaml/testsuite/tests/typing-modules/records_errors_test.ml b/ocaml/testsuite/tests/typing-modules/records_errors_test.ml index f85c1e7db9b..ef327db4eb0 100644 --- a/ocaml/testsuite/tests/typing-modules/records_errors_test.ml +++ b/ocaml/testsuite/tests/typing-modules/records_errors_test.ml @@ -40,11 +40,20 @@ Error: Signature mismatch: f0 : unit * unit * unit * int * unit * unit * unit; f1 : unit * unit * unit * int * unit * unit * unit; } - Fields do not match: + 1. Fields do not match: f0 : unit * unit * unit * float * unit * unit * unit; - is not compatible with: + is not the same as: f0 : unit * unit * unit * int * unit * unit * unit; - The types are not equal. + The type unit * unit * unit * float * unit * unit * unit + is not equal to the type unit * unit * unit * int * unit * unit * unit + Type float is not equal to type int + 2. Fields do not match: + f1 : unit * unit * unit * string * unit * unit * unit; + is not the same as: + f1 : unit * unit * unit * int * unit * unit * unit; + The type unit * unit * unit * string * unit * unit * unit + is not equal to the type unit * unit * unit * int * unit * unit * unit + Type string is not equal to type int |}];; @@ -86,11 +95,18 @@ Error: Signature mismatch: mutable f0 : unit * unit * unit * int * unit * unit * unit; f1 : unit * unit * unit * int * unit * unit * unit; } - Fields do not match: + 1. Fields do not match: f0 : unit * unit * unit * float * unit * unit * unit; - is not compatible with: + is not the same as: mutable f0 : unit * unit * unit * int * unit * unit * unit; The second is mutable and the first is not. + 2. Fields do not match: + f1 : unit * unit * unit * string * unit * unit * unit; + is not the same as: + f1 : unit * unit * unit * int * unit * unit * unit; + The type unit * unit * unit * string * unit * unit * unit + is not equal to the type unit * unit * unit * int * unit * unit * unit + Type string is not equal to type int |}];; module M3 : sig @@ -112,7 +128,7 @@ Error: Signature mismatch: type t = { f1 : unit; } is not included in type t = { f0 : unit; } - Fields number 1 have different names, f1 and f0. + Fields have different names, f1 and f0. |}];; module M4 : sig @@ -134,5 +150,355 @@ Error: Signature mismatch: type t = { f0 : unit; } is not included in type t = { f0 : unit; f1 : unit; } - The field f1 is only present in the second declaration. + A field, f1, is missing in the first declaration. |}];; + + +(** Random additions and deletions of fields *) + +module Addition : sig + type t = {a : unit; b : unit; c : unit; d : unit} +end = struct + type t = {a : unit; b : unit; beta : unit; c : unit; d: unit} +end +[%%expect {| +Lines 5-7, characters 6-3: +5 | ......struct +6 | type t = {a : unit; b : unit; beta : unit; c : unit; d: unit} +7 | end +Error: Signature mismatch: + Modules do not match: + sig + type t = { a : unit; b : unit; beta : unit; c : unit; d : unit; } + end + is not included in + sig type t = { a : unit; b : unit; c : unit; d : unit; } end + Type declarations do not match: + type t = { a : unit; b : unit; beta : unit; c : unit; d : unit; } + is not included in + type t = { a : unit; b : unit; c : unit; d : unit; } + An extra field, beta, is provided in the first declaration. +|}] + + +module Deletion : sig + type t = {a : unit; b : unit; c : unit; d : unit} +end = struct + type t = {a : unit; c : unit; d : unit} +end +[%%expect {| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = {a : unit; c : unit; d : unit} +5 | end +Error: Signature mismatch: + Modules do not match: + sig type t = { a : unit; c : unit; d : unit; } end + is not included in + sig type t = { a : unit; b : unit; c : unit; d : unit; } end + Type declarations do not match: + type t = { a : unit; c : unit; d : unit; } + is not included in + type t = { a : unit; b : unit; c : unit; d : unit; } + A field, b, is missing in the first declaration. +|}] + + +module Multi: sig + type t = { + a : unit; + b : unit; + c : unit; + d : unit; + e : unit; + f : unit; + g : unit + } +end = struct + type t = { + a : unit; + b : unit; + beta: int; + c : unit; + d : unit; + f : unit; + g : unit; + phi : unit; + } +end + +[%%expect {| +Lines 11-22, characters 6-3: +11 | ......struct +12 | type t = { +13 | a : unit; +14 | b : unit; +15 | beta: int; +... +19 | g : unit; +20 | phi : unit; +21 | } +22 | end +Error: Signature mismatch: + Modules do not match: + sig + type t = { + a : unit; + b : unit; + beta : int; + c : unit; + d : unit; + f : unit; + g : unit; + phi : unit; + } + end + is not included in + sig + type t = { + a : unit; + b : unit; + c : unit; + d : unit; + e : unit; + f : unit; + g : unit; + } + end + Type declarations do not match: + type t = { + a : unit; + b : unit; + beta : int; + c : unit; + d : unit; + f : unit; + g : unit; + phi : unit; + } + is not included in + type t = { + a : unit; + b : unit; + c : unit; + d : unit; + e : unit; + f : unit; + g : unit; + } + 3. An extra field, beta, is provided in the first declaration. + 5. A field, e, is missing in the first declaration. + 8. An extra field, phi, is provided in the first declaration. +|}] + + +(** Multiple errors *) + +module M : sig + type t = { a:int; e:int; c:int; d:int; b:int } +end = struct + type t = { alpha:int; b:int; c:int; d:int; e:int } +end +[%%expect {| +Lines 5-7, characters 6-3: +5 | ......struct +6 | type t = { alpha:int; b:int; c:int; d:int; e:int } +7 | end +Error: Signature mismatch: + Modules do not match: + sig + type t = { alpha : int; b : int; c : int; d : int; e : int; } + end + is not included in + sig type t = { a : int; e : int; c : int; d : int; b : int; } end + Type declarations do not match: + type t = { alpha : int; b : int; c : int; d : int; e : int; } + is not included in + type t = { a : int; e : int; c : int; d : int; b : int; } + 1. Fields have different names, alpha and a. + 2<->5. Fields b and e have been swapped. +|}] + + +module M: sig + type t = { a:int; b:int; c:int; d:int; e:int; f:float } +end = +struct + type t = { b:int; c:int; d:int; e:int; a:int; f:int } +end +[%%expect {| +Lines 4-6, characters 0-3: +4 | struct +5 | type t = { b:int; c:int; d:int; e:int; a:int; f:int } +6 | end +Error: Signature mismatch: + Modules do not match: + sig + type t = { b : int; c : int; d : int; e : int; a : int; f : int; } + end + is not included in + sig + type t = { + a : int; + b : int; + c : int; + d : int; + e : int; + f : float; + } + end + Type declarations do not match: + type t = { b : int; c : int; d : int; e : int; a : int; f : int; } + is not included in + type t = { a : int; b : int; c : int; d : int; e : int; f : float; } + 1->5. Field a has been moved from position 1 to 5. + 6. Fields do not match: + f : int; + is not the same as: + f : float; + The type int is not equal to the type float +|}] + +(** Existential types introduce equations that must be taken in account + when diffing +*) + + +module Eq : sig + type t = A: { a:'a; b:'b; x:'a } -> t +end = struct + type t = A: { a:'a; b:'b; x:'x } -> t +end +[%%expect {| +Lines 8-10, characters 6-3: + 8 | ......struct + 9 | type t = A: { a:'a; b:'b; x:'x } -> t +10 | end +Error: Signature mismatch: + Modules do not match: + sig type t = A : { a : 'a; b : 'b; x : 'x; } -> t end + is not included in + sig type t = A : { a : 'a; b : 'b; x : 'a; } -> t end + Type declarations do not match: + type t = A : { a : 'a; b : 'b; x : 'x; } -> t + is not included in + type t = A : { a : 'a; b : 'b; x : 'a; } -> t + Constructors do not match: + A : { a : 'a; b : 'b; x : 'x; } -> t + is not the same as: + A : { a : 'a; b : 'b; x : 'a; } -> t + Fields do not match: + x : 'x; + is not the same as: + x : 'a; + The type 'x is not equal to the type 'a +|}] + + +module Not_a_swap: sig + type t = A: { x:'a; a:'a; b:'b; y:'b} -> t +end = struct + type t = A: { y:'a; a:'a; b:'b; x:'b} -> t +end +[%%expect {| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = A: { y:'a; a:'a; b:'b; x:'b} -> t +5 | end +Error: Signature mismatch: + Modules do not match: + sig type t = A : { y : 'a; a : 'a; b : 'b; x : 'b; } -> t end + is not included in + sig type t = A : { x : 'a; a : 'a; b : 'b; y : 'b; } -> t end + Type declarations do not match: + type t = A : { y : 'a; a : 'a; b : 'b; x : 'b; } -> t + is not included in + type t = A : { x : 'a; a : 'a; b : 'b; y : 'b; } -> t + Constructors do not match: + A : { y : 'a; a : 'a; b : 'b; x : 'b; } -> t + is not the same as: + A : { x : 'a; a : 'a; b : 'b; y : 'b; } -> t + 1. Fields have different names, y and x. + 4. Fields have different names, x and y. +|}] + +module Swap: sig + type t = A: { x:'a; a:'a; b:'b; y:'b} -> t +end = struct + type t = A: { y:'b; a:'a; b:'b; x:'a} -> t +end +[%%expect {| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = A: { y:'b; a:'a; b:'b; x:'a} -> t +5 | end +Error: Signature mismatch: + Modules do not match: + sig type t = A : { y : 'b; a : 'a; b : 'b; x : 'a; } -> t end + is not included in + sig type t = A : { x : 'a; a : 'a; b : 'b; y : 'b; } -> t end + Type declarations do not match: + type t = A : { y : 'b; a : 'a; b : 'b; x : 'a; } -> t + is not included in + type t = A : { x : 'a; a : 'a; b : 'b; y : 'b; } -> t + Constructors do not match: + A : { y : 'b; a : 'a; b : 'b; x : 'a; } -> t + is not the same as: + A : { x : 'a; a : 'a; b : 'b; y : 'b; } -> t + Fields x and y have been swapped. +|}] + + +module Not_a_move: sig + type t = A: { a:'a; b:'b; x:'b} -> t +end = struct + type t = A: { x:'a; a:'a; b:'b} -> t +end +[%%expect {| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = A: { x:'a; a:'a; b:'b} -> t +5 | end +Error: Signature mismatch: + Modules do not match: + sig type t = A : { x : 'a; a : 'a; b : 'b; } -> t end + is not included in + sig type t = A : { a : 'a; b : 'b; x : 'b; } -> t end + Type declarations do not match: + type t = A : { x : 'a; a : 'a; b : 'b; } -> t + is not included in + type t = A : { a : 'a; b : 'b; x : 'b; } -> t + Constructors do not match: + A : { x : 'a; a : 'a; b : 'b; } -> t + is not the same as: + A : { a : 'a; b : 'b; x : 'b; } -> t + 1. An extra field, x, is provided in the first declaration. + 3. A field, x, is missing in the first declaration. +|}] + + +module Move: sig + type t = A: { a:'a; b:'b; x:'b} -> t +end = struct + type t = A: { x:'b; a:'a; b:'b} -> t +end +[%%expect {| +Lines 3-5, characters 6-3: +3 | ......struct +4 | type t = A: { x:'b; a:'a; b:'b} -> t +5 | end +Error: Signature mismatch: + Modules do not match: + sig type t = A : { x : 'b; a : 'a; b : 'b; } -> t end + is not included in + sig type t = A : { a : 'a; b : 'b; x : 'b; } -> t end + Type declarations do not match: + type t = A : { x : 'b; a : 'a; b : 'b; } -> t + is not included in + type t = A : { a : 'a; b : 'b; x : 'b; } -> t + Constructors do not match: + A : { x : 'b; a : 'a; b : 'b; } -> t + is not the same as: + A : { a : 'a; b : 'b; x : 'b; } -> t + Field x has been moved from position 3 to 1. +|}] diff --git a/ocaml/testsuite/tests/typing-modules/variants_errors_test.ml b/ocaml/testsuite/tests/typing-modules/variants_errors_test.ml index a923ebcfa77..253bc080e2d 100644 --- a/ocaml/testsuite/tests/typing-modules/variants_errors_test.ml +++ b/ocaml/testsuite/tests/typing-modules/variants_errors_test.ml @@ -26,9 +26,9 @@ Error: Signature mismatch: type t = Foo of int * int Constructors do not match: Foo of float * int - is not compatible with: + is not the same as: Foo of int * int - The types are not equal. + The type float is not equal to the type int |}];; module M2 : sig @@ -55,7 +55,7 @@ Error: Signature mismatch: type t = Foo of int * int Constructors do not match: Foo of float - is not compatible with: + is not the same as: Foo of int * int They have different arities. |}];; @@ -84,13 +84,13 @@ Error: Signature mismatch: type t = Foo of { x : int; y : int; } Constructors do not match: Foo of { x : float; y : int; } - is not compatible with: + is not the same as: Foo of { x : int; y : int; } Fields do not match: x : float; - is not compatible with: + is not the same as: x : int; - The types are not equal. + The type float is not equal to the type int |}];; module M4 : sig @@ -117,7 +117,7 @@ Error: Signature mismatch: type t = Foo of { x : int; y : int; } Constructors do not match: Foo of float - is not compatible with: + is not the same as: Foo of { x : int; y : int; } The second uses inline records and the first doesn't. |}];; @@ -146,7 +146,7 @@ Error: Signature mismatch: type 'a t = Foo : int -> int t Constructors do not match: Foo of 'a - is not compatible with: + is not the same as: Foo : int -> int t The second has explicit return type and the first doesn't. |}];; @@ -172,9 +172,9 @@ Error: Signature mismatch: type ('a, 'b) t = A of 'a Constructors do not match: A of 'b - is not compatible with: + is not the same as: A of 'a - The types are not equal. + The type 'b is not equal to the type 'a |}];; module M : sig @@ -198,7 +198,215 @@ Error: Signature mismatch: type ('a, 'b) t = A of 'a Constructors do not match: A of 'a - is not compatible with: + is not the same as: A of 'a - The types are not equal. + The type 'a is not equal to the type 'b |}];; + + + +(** Random additions and deletions of constructors *) + +module Addition : sig + type t = + | A + | B + | C + | D +end = struct + type t = + | A + | B + | Beta + | C + | D +end +[%%expect {| +Lines 9-16, characters 6-3: + 9 | ......struct +10 | type t = +11 | | A +12 | | B +13 | | Beta +14 | | C +15 | | D +16 | end +Error: Signature mismatch: + Modules do not match: + sig type t = A | B | Beta | C | D end + is not included in + sig type t = A | B | C | D end + Type declarations do not match: + type t = A | B | Beta | C | D + is not included in + type t = A | B | C | D + An extra constructor, Beta, is provided in the first declaration. +|}] + + +module Addition : sig + type t = + | A + | B + | C + | D +end = struct + type t = + | A + | B + | D +end +[%%expect {| +Lines 7-12, characters 6-3: + 7 | ......struct + 8 | type t = + 9 | | A +10 | | B +11 | | D +12 | end +Error: Signature mismatch: + Modules do not match: + sig type t = A | B | D end + is not included in + sig type t = A | B | C | D end + Type declarations do not match: + type t = A | B | D + is not included in + type t = A | B | C | D + A constructor, C, is missing in the first declaration. +|}] + + +module Multi: sig + type t = + | A + | B + | C + | D + | E + | F + | G +end = struct + type t = + | A + | B + | Beta + | C + | D + | F + | G + | Phi +end + +[%%expect {| +Lines 10-20, characters 6-3: +10 | ......struct +11 | type t = +12 | | A +13 | | B +14 | | Beta +... +17 | | F +18 | | G +19 | | Phi +20 | end +Error: Signature mismatch: + Modules do not match: + sig type t = A | B | Beta | C | D | F | G | Phi end + is not included in + sig type t = A | B | C | D | E | F | G end + Type declarations do not match: + type t = A | B | Beta | C | D | F | G | Phi + is not included in + type t = A | B | C | D | E | F | G + 3. An extra constructor, Beta, is provided in the first declaration. + 5. A constructor, E, is missing in the first declaration. + 8. An extra constructor, Phi, is provided in the first declaration. +|}] + + +(** Swaps and moves *) + +module Swap : sig + type t = + | A + | E + | C + | D + | B +end = struct + type t = + | Alpha + | B + | C + | D + | E +end +[%%expect {| +Lines 10-17, characters 6-3: +10 | ......struct +11 | type t = +12 | | Alpha +13 | | B +14 | | C +15 | | D +16 | | E +17 | end +Error: Signature mismatch: + Modules do not match: + sig type t = Alpha | B | C | D | E end + is not included in + sig type t = A | E | C | D | B end + Type declarations do not match: + type t = Alpha | B | C | D | E + is not included in + type t = A | E | C | D | B + 1. Constructors have different names, Alpha and A. + 2<->5. Constructors B and E have been swapped. +|}] + + +module Move: sig + type t = + | A of int + | B + | C + | D + | E + | F +end = struct + type t = + | A of float + | B + | D + | E + | F + | C +end +[%%expect {| +Lines 9-17, characters 6-3: + 9 | ......struct +10 | type t = +11 | | A of float +12 | | B +13 | | D +14 | | E +15 | | F +16 | | C +17 | end +Error: Signature mismatch: + Modules do not match: + sig type t = A of float | B | D | E | F | C end + is not included in + sig type t = A of int | B | C | D | E | F end + Type declarations do not match: + type t = A of float | B | D | E | F | C + is not included in + type t = A of int | B | C | D | E | F + 1. Constructors do not match: + A of float + is not the same as: + A of int + The type float is not equal to the type int + 3->6. Constructor C has been moved from position 3 to 6. +|}] diff --git a/ocaml/testsuite/tests/typing-modules/with_ghosts.ml b/ocaml/testsuite/tests/typing-modules/with_ghosts.ml new file mode 100644 index 00000000000..ab9ad14fa99 --- /dev/null +++ b/ocaml/testsuite/tests/typing-modules/with_ghosts.ml @@ -0,0 +1,52 @@ +(* TEST + * expect +*) + +(** + Check the behavior of with constraints with respect to + ghost type items introduced for class and class types + *) + +module type s = sig + class type c = object method m: int end +end with type c := +[%%expect {| +Lines 6-8, characters 16-29: +6 | ................sig +7 | class type c = object method m: int end +8 | end with type c := +Error: The signature constrained by `with' has no component named c +|}] + + +module type s = sig + class type ct = object method m: int end +end with type ct := +[%%expect {| +Lines 1-3, characters 16-30: +1 | ................sig +2 | class type ct = object method m: int end +3 | end with type ct := +Error: The signature constrained by `with' has no component named ct +|}] + +(** Check that we keep the same structure even after replacing a ghost item *) + +module type s = sig + type top + and t = private < .. > + and mid + and u = private < .. > + and v +end with type t = private < .. > + with type u = private < .. > +[%%expect {| +module type s = + sig + type top + and t = private < .. > + and mid + and u = private < .. > + and v + end +|}] diff --git a/ocaml/testsuite/tests/typing-multifile/pr6372.ml b/ocaml/testsuite/tests/typing-multifile/pr6372.ml index 727839cf933..74457647daa 100644 --- a/ocaml/testsuite/tests/typing-multifile/pr6372.ml +++ b/ocaml/testsuite/tests/typing-multifile/pr6372.ml @@ -1,5 +1,5 @@ (* TEST -files = "d.mli e.ml" +readonly_files = "d.mli e.ml" * setup-ocamlc.byte-build-env ** ocamlc.byte module = "d.mli" diff --git a/ocaml/testsuite/tests/typing-multifile/pr7325.ml b/ocaml/testsuite/tests/typing-multifile/pr7325.ml index 33b69bc946f..87cad1ab54e 100644 --- a/ocaml/testsuite/tests/typing-multifile/pr7325.ml +++ b/ocaml/testsuite/tests/typing-multifile/pr7325.ml @@ -1,5 +1,5 @@ (* TEST -files = "a.ml b.ml c.ml" +readonly_files = "a.ml b.ml c.ml" * setup-ocamlc.byte-build-env ** ocamlc.byte module = "a.ml" diff --git a/ocaml/testsuite/tests/typing-objects-bugs/pr3968_bad.compilers.reference b/ocaml/testsuite/tests/typing-objects-bugs/pr3968_bad.compilers.reference index a5685448b5c..43d6bbf9e86 100644 --- a/ocaml/testsuite/tests/typing-objects-bugs/pr3968_bad.compilers.reference +++ b/ocaml/testsuite/tests/typing-objects-bugs/pr3968_bad.compilers.reference @@ -12,9 +12,7 @@ File "pr3968_bad.ml", lines 20-29, characters 0-3: Error: The class type object val l : - [ `Abs of - string * - ([ `Abs of string * expr | `App of 'a * exp ] as 'b) + [ `Abs of string * ([> `App of 'a * exp ] as 'b) | `App of expr * expr ] as 'a val r : exp method eval : (string, exp) Hashtbl.t -> 'b @@ -23,9 +21,7 @@ Error: The class type The class type object val l : - [ `Abs of - string * - ([ `Abs of string * expr | `App of 'a * exp ] as 'b) + [ `Abs of string * ([> `App of 'a * exp ] as 'b) | `App of expr * expr ] as 'a val r : exp method eval : (string, exp) Hashtbl.t -> 'b @@ -34,16 +30,15 @@ Error: The class type object method eval : (string, exp) Hashtbl.t -> expr end The method eval has type (string, exp) Hashtbl.t -> - ([ `Abs of string * expr - | `App of [ `Abs of string * 'a | `App of expr * expr ] * exp ] + ([> `App of [ `Abs of string * 'a | `App of expr * expr ] * exp ] as 'a) but is expected to have type (string, exp) Hashtbl.t -> expr Type - [ `Abs of string * expr - | `App of [ `Abs of string * 'a | `App of expr * expr ] * exp ] + [> `App of [ `Abs of string * 'a | `App of expr * expr ] * exp ] as 'a is not compatible with type expr = [ `Abs of string * expr | `App of expr * expr ] Type exp = < eval : (string, exp) Hashtbl.t -> expr > is not compatible with type expr = [ `Abs of string * expr | `App of expr * expr ] + Types for tag `App are incompatible diff --git a/ocaml/testsuite/tests/typing-objects-bugs/pr3968_bad.ml b/ocaml/testsuite/tests/typing-objects-bugs/pr3968_bad.ml index 6b04eee0757..e60b35044fb 100644 --- a/ocaml/testsuite/tests/typing-objects-bugs/pr3968_bad.ml +++ b/ocaml/testsuite/tests/typing-objects-bugs/pr3968_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-objects-bugs/pr4018_bad.compilers.reference b/ocaml/testsuite/tests/typing-objects-bugs/pr4018_bad.compilers.reference index 68b176658ed..8a400c289b9 100644 --- a/ocaml/testsuite/tests/typing-objects-bugs/pr4018_bad.compilers.reference +++ b/ocaml/testsuite/tests/typing-objects-bugs/pr4018_bad.compilers.reference @@ -3,8 +3,7 @@ File "pr4018_bad.ml", line 42, characters 11-17: ^^^^^^ Error: This type entity = < destroy_subject : id subject; entity_id : id > should be an instance of type - < destroy_subject : < add_observer : 'a entity_container -> 'c; .. > - as 'b; + < destroy_subject : < add_observer : 'a entity_container -> 'b; .. >; .. > as 'a Type @@ -12,29 +11,12 @@ Error: This type entity = < destroy_subject : id subject; entity_id : id > < add_observer : (id subject, id) observer -> unit; notify_observers : id -> unit > is not compatible with type - < add_observer : 'a entity_container -> 'c; .. > as 'b - Type (id subject, id) observer = < notify : id subject -> id -> unit > - is not compatible with type - 'a entity_container = - < add_entity : (< destroy_subject : < add_observer : 'a - entity_container -> - 'f; - .. > - as 'e; - .. > - as 'd) -> - 'f; - notify : 'd -> id -> unit > - Type entity = < destroy_subject : id subject; entity_id : id > - is not compatible with type < destroy_subject : 'e; .. > as 'd - Type - id subject = - < add_observer : (id subject, id) observer -> unit; - notify_observers : id -> unit > - is not compatible with type - < add_observer : 'a entity_container -> 'f; .. > as 'e + < add_observer : < destroy_subject : 'c; .. > entity_container -> 'b; + .. > + as 'c Type (id subject, id) observer = < notify : id subject -> id -> unit > is not compatible with type - 'a entity_container = - < add_entity : 'd -> 'f; notify : 'd -> id -> unit > - The first object type has no method add_entity + (< destroy_subject : < add_observer : 'd -> 'b; .. >; .. > as 'a) + entity_container as 'd = + < add_entity : 'a -> 'b; notify : 'a -> id -> unit > + Types for method add_observer are incompatible diff --git a/ocaml/testsuite/tests/typing-objects-bugs/pr4018_bad.ml b/ocaml/testsuite/tests/typing-objects-bugs/pr4018_bad.ml index 8d23f82d93e..a2a7235fefc 100644 --- a/ocaml/testsuite/tests/typing-objects-bugs/pr4018_bad.ml +++ b/ocaml/testsuite/tests/typing-objects-bugs/pr4018_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-objects-bugs/pr4435_bad.ml b/ocaml/testsuite/tests/typing-objects-bugs/pr4435_bad.ml index f869e7d602b..9cbd777ee45 100644 --- a/ocaml/testsuite/tests/typing-objects-bugs/pr4435_bad.ml +++ b/ocaml/testsuite/tests/typing-objects-bugs/pr4435_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-objects-bugs/pr4766_ok.ml b/ocaml/testsuite/tests/typing-objects-bugs/pr4766_ok.ml index d8511e56f82..565275a4992 100644 --- a/ocaml/testsuite/tests/typing-objects-bugs/pr4766_ok.ml +++ b/ocaml/testsuite/tests/typing-objects-bugs/pr4766_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-objects-bugs/pr4824_ok.ml b/ocaml/testsuite/tests/typing-objects-bugs/pr4824_ok.ml index 7b31b5d96bd..114a5a7534d 100644 --- a/ocaml/testsuite/tests/typing-objects-bugs/pr4824_ok.ml +++ b/ocaml/testsuite/tests/typing-objects-bugs/pr4824_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-objects-bugs/pr4824a_bad.ml b/ocaml/testsuite/tests/typing-objects-bugs/pr4824a_bad.ml index 37002d71a5b..566cd0c7718 100644 --- a/ocaml/testsuite/tests/typing-objects-bugs/pr4824a_bad.ml +++ b/ocaml/testsuite/tests/typing-objects-bugs/pr4824a_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-objects-bugs/pr5156_ok.ml b/ocaml/testsuite/tests/typing-objects-bugs/pr5156_ok.ml index 6c52480ca43..e17bf711d23 100644 --- a/ocaml/testsuite/tests/typing-objects-bugs/pr5156_ok.ml +++ b/ocaml/testsuite/tests/typing-objects-bugs/pr5156_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-objects-bugs/pr7284_bad.ml b/ocaml/testsuite/tests/typing-objects-bugs/pr7284_bad.ml index 4d236cb5b8a..ab7bc55d823 100644 --- a/ocaml/testsuite/tests/typing-objects-bugs/pr7284_bad.ml +++ b/ocaml/testsuite/tests/typing-objects-bugs/pr7284_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-objects-bugs/pr7293_ok.ml b/ocaml/testsuite/tests/typing-objects-bugs/pr7293_ok.ml index 88694877da3..40ba424e051 100644 --- a/ocaml/testsuite/tests/typing-objects-bugs/pr7293_ok.ml +++ b/ocaml/testsuite/tests/typing-objects-bugs/pr7293_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-objects-bugs/woodyatt_ok.ml b/ocaml/testsuite/tests/typing-objects-bugs/woodyatt_ok.ml index d0969457d5b..a109ed052c2 100644 --- a/ocaml/testsuite/tests/typing-objects-bugs/woodyatt_ok.ml +++ b/ocaml/testsuite/tests/typing-objects-bugs/woodyatt_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml b/ocaml/testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml index 09282762d11..99011ef7819 100644 --- a/ocaml/testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml +++ b/ocaml/testsuite/tests/typing-objects-bugs/yamagata021012_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-objects/Exemples.ml b/ocaml/testsuite/tests/typing-objects/Exemples.ml index dca5d1b859b..57035ca71a7 100644 --- a/ocaml/testsuite/tests/typing-objects/Exemples.ml +++ b/ocaml/testsuite/tests/typing-objects/Exemples.ml @@ -286,12 +286,11 @@ class printable_color_point y c = object (self) Format.print_string ")" end;; [%%expect{| -Line 3, characters 10-27: +Line 3, characters 2-36: 3 | inherit printable_point y as super - ^^^^^^^^^^^^^^^^^ + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 13 [instance-variable-override]: the following instance variables are overridden by the class printable_point : x -The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) class printable_color_point : int -> string -> @@ -542,10 +541,7 @@ Error: Type < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > is not a subtype of int_comparable = < cmp : int_comparable -> int; x : int > - Type int_comparable = < cmp : int_comparable -> int; x : int > - is not a subtype of - int_comparable2 = - < cmp : int_comparable2 -> int; set_x : int -> unit; x : int > + Type int_comparable is not a subtype of int_comparable2 The first object type has no method set_x |}];; (* Fail : 'a comp2 is not a subtype *) (new sorted_list ())#add c2;; @@ -590,20 +586,7 @@ Error: This expression has type #comparable as 'a = < cmp : 'a -> int; .. > Type int_comparable = < cmp : int_comparable -> int; x : int > is not compatible with type - int_comparable3 = - < cmp : int_comparable -> int; setx : int -> unit; x : int > - The first object type has no method setx -|}, Principal{| -Line 1, characters 25-27: -1 | (new sorted_list ())#add c3;; - ^^ -Error: This expression has type - int_comparable3 = - < cmp : int_comparable -> int; setx : int -> unit; x : int > - but an expression was expected of type #comparable as 'a = < cmp : 'a -> int; .. > - Type int_comparable = < cmp : int_comparable -> int; x : int > - is not compatible with type 'a = < cmp : 'a -> int; .. > The first object type has no method setx |}];; (* Error; strange message with -principal *) diff --git a/ocaml/testsuite/tests/typing-objects/Tests.ml b/ocaml/testsuite/tests/typing-objects/Tests.ml index 700491c3f80..7456f125089 100644 --- a/ocaml/testsuite/tests/typing-objects/Tests.ml +++ b/ocaml/testsuite/tests/typing-objects/Tests.ml @@ -19,7 +19,7 @@ end and ['a] d () = object end;; [%%expect{| class ['a] c : unit -> object constraint 'a = int method f : int c end -and ['a] d : unit -> object constraint 'a = int method f : int c end +and ['a] d : unit -> object constraint 'a = int method f : 'a c end |}];; (* class ['a] c : unit -> object constraint 'a = int method f : 'a c end *) (* and ['a] d : unit -> object constraint 'a = int method f : 'a c end *) @@ -103,11 +103,12 @@ class x () = object method virtual f : int end;; [%%expect{| -Lines 1-3, characters 0-3: -1 | class x () = object +Lines 1-3, characters 13-3: +1 | .............object 2 | method virtual f : int 3 | end.. -Error: This class should be virtual. The following methods are undefined : f +Error: This non-virtual class has virtual methods. + The following methods are virtual : f |}];; (* The class x should be virtual: its methods f is undefined *) @@ -162,9 +163,9 @@ end;; class ['a, 'b] d : unit -> object - constraint 'a = int -> 'c - constraint 'b = 'a * < x : 'b > * 'c * 'd - method f : 'a -> 'b -> unit + constraint 'a = int -> 'd + constraint 'b = 'a * (< x : 'b > as 'c) * 'd * 'e + method f : (int -> 'd) -> (int -> 'd) * 'c * 'd * 'e -> unit end |}];; @@ -322,7 +323,7 @@ class ['a, 'b] d : constraint 'a = int -> bool val x : float list val y : 'b - method f : 'a -> unit + method f : (int -> bool) -> unit method g : 'b end |}];; @@ -335,7 +336,7 @@ class ['a, 'b] e : constraint 'a = int -> bool val x : float list val y : 'b - method f : 'a -> unit + method f : (int -> bool) -> unit method g : 'b end |}];; @@ -469,28 +470,24 @@ class e () = object method b = b end;; [%%expect{| -Line 3, characters 10-13: +Line 3, characters 2-13: 3 | inherit c 5 - ^^^ + ^^^^^^^^^^^ Warning 13 [instance-variable-override]: the following instance variables are overridden by the class c : x -The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) Line 4, characters 6-7: 4 | val y = 3 ^ Warning 13 [instance-variable-override]: the instance variable y is overridden. -The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) -Line 6, characters 10-13: +Line 6, characters 2-13: 6 | inherit d 7 - ^^^ + ^^^^^^^^^^^ Warning 13 [instance-variable-override]: the following instance variables are overridden by the class d : t z -The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) Line 7, characters 6-7: 7 | val u = 3 ^ Warning 13 [instance-variable-override]: the instance variable u is overridden. -The behaviour changed in ocaml 3.10 (previous behaviour was hiding.) class e : unit -> object @@ -702,6 +699,10 @@ Error: Signature mismatch: val f : (#c as 'a) -> 'a is not included in val f : #c -> #c + The type (#c as 'a) -> 'a is not compatible with the type #c -> #c + Type #c as 'a = < m : 'a; .. > is not compatible with type + #c as 'b = < m : 'b; .. > + Type 'a is not compatible with type 'b |}];; module M = struct type t = int class t () = object end end;; @@ -918,3 +919,502 @@ Line 2, characters 44-49: Error: The ancestor variable super cannot be accessed from the definition of an instance variable |}];; + +(* Some more tests of class idiosyncrasies *) + +class c = object method private m = 3 end + and d = object method o = object inherit c end end;; +[%%expect {| +class c : object method private m : int end +and d : object method o : c end +|}];; + +class c = object(_ : 'self) + method o = object(_ : 'self) method o = assert false end +end;; +[%%expect {| +Line 2, characters 13-58: +2 | method o = object(_ : 'self) method o = assert false end + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: Cannot close type of object literal: < o : '_weak3; _.. > + it has been unified with the self type of a class that is not yet + completely defined. +|}];; + +class c = object + method m = 1 + inherit object (self) + method n = self#m + end + end;; +[%%expect {| +Line 4, characters 17-23: +4 | method n = self#m + ^^^^^^ +Warning 17 [undeclared-virtual-method]: the virtual method m is not declared. +class c : object method m : int method n : int end +|}];; + +class virtual c = object (self : 'c) + constraint 'c = < f : int; .. > +end +[%%expect {| +class virtual c : object method virtual f : int end +|}];; + +class virtual c = object (self : 'c) + constraint 'c = < f : int; .. > + method g = self # f +end +[%%expect {| +class virtual c : object method virtual f : int method g : int end +|}];; + +class [ 'a ] c = object (_ : 'a) end;; +let o = object + method m = 1 + inherit [ < m : int > ] c + end;; +[%%expect {| +class ['a] c : object ('a) constraint 'a = < .. > end +Line 4, characters 14-25: +4 | inherit [ < m : int > ] c + ^^^^^^^^^^^ +Error: The type parameter < m : int > + does not meet its constraint: it should be < .. > + Self type cannot be unified with a closed object type +|}];; + +class type [ 'a ] d = object method a : 'a method b : 'a end +class c : ['a] d = object (self) method a = 1 method b = assert false end;; +[%%expect {| +class type ['a] d = object method a : 'a method b : 'a end +Line 2, characters 19-73: +2 | class c : ['a] d = object (self) method a = 1 method b = assert false end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The class type object method a : int method b : 'a end + is not matched by the class type ['_a] d + The class type object method a : int method b : 'a end + is not matched by the class type + object method a : 'a method b : 'a end + The method a has type int but is expected to have type 'a + Type int is not compatible with type 'a +|}];; + +class type ['a] ct = object ('a) end +class c : [ < a : int; ..> ] ct = object method a = 3 end;; +[%%expect {| +class type ['a] ct = object ('a) constraint 'a = < .. > end +Line 2, characters 10-31: +2 | class c : [ < a : int; ..> ] ct = object method a = 3 end;; + ^^^^^^^^^^^^^^^^^^^^^ +Error: This non-virtual class has undeclared virtual methods. + The following methods were not declared : a +|}];; + +class virtual c : [ < a : int; ..> ] ct = object method a = 3 end;; +[%%expect {| +class virtual c : object method virtual a : int end +|}];; + +class c : object + method m : < m : 'a > as 'a + end = object (self) + method m = self +end;; +[%%expect {| +Lines 3-5, characters 8-3: +3 | ........object (self) +4 | method m = self +5 | end.. +Error: The class type object ('a) method m : < m : 'a; .. > as 'a end + is not matched by the class type + object method m : < m : 'a > as 'a end + The method m has type < m : 'a; .. > as 'a + but is expected to have type < m : 'b > as 'b + Type 'a is not compatible with type < > +|}];; + +class c : + object + method foo : < foo : int; .. > -> < foo : int> -> unit + end = + object + method foo : 'a. (< foo : int; .. > as 'a) -> 'a -> unit = assert false + end;; +[%%expect {| +Lines 5-7, characters 2-5: +5 | ..object +6 | method foo : 'a. (< foo : int; .. > as 'a) -> 'a -> unit = assert false +7 | end.. +Error: The class type + object method foo : (< foo : int; .. > as 'a) -> 'a -> unit end + is not matched by the class type + object method foo : < foo : int; .. > -> < foo : int > -> unit end + The method foo has type 'a. (< foo : int; .. > as 'a) -> 'a -> unit + but is expected to have type + 'b. (< foo : int; .. > as 'b) -> < foo : int > -> unit + Type 'c is not compatible with type < > +|}];; + + +class c = (fun x -> object(_:'foo) end) 3;; +[%%expect {| +class c : object end +|}];; + +class virtual c = + ((fun (x : 'self -> unit) -> object(_:'self) end) (fun (_ : < a : int; .. >) -> ()) + : object method virtual a : int end) +[%%expect {| +class virtual c : object method virtual a : int end +|}];; + +class c = object + val x = 3 + method o = {< x = 4; y = 5 >} + val y = 4 +end;; +[%%expect {| +class c : object ('a) val x : int val y : int method o : 'a end +|}];; + +class c : object('self) method m : < m : 'a; x : int; ..> -> unit as 'a end = + object (_ : 'self) method m (_ : 'self) = () end;; +[%%expect {| +Line 2, characters 4-52: +2 | object (_ : 'self) method m (_ : 'self) = () end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The class type + object ('a) method m : (< m : 'a -> unit; .. > as 'a) -> unit end + is not matched by the class type + object method m : < m : 'a; x : int; .. > -> unit as 'a end + The method m has type (< m : 'a -> unit; .. > as 'a) -> unit + but is expected to have type + 'b. (< m : 'c; x : int; .. > as 'b) -> unit as 'c + Type 'a is not compatible with type < x : int; .. > +|}];; + +let is_empty (x : < >) = () +class c = object (self) method private foo = is_empty self end;; +[%%expect {| +val is_empty : < > -> unit = +Line 2, characters 54-58: +2 | class c = object (self) method private foo = is_empty self end;; + ^^^^ +Error: This expression has type < .. > but an expression was expected of type + < > + Self type cannot be unified with a closed object type +|}];; + +(* Warnings about private methods implicitly made public *) +let has_foo (x : < foo : 'a; .. >) = () + +class c = object (self) method private foo = 5 initializer has_foo self end;; +[%%expect {| +val has_foo : < foo : 'a; .. > -> unit = +Line 3, characters 10-75: +3 | class c = object (self) method private foo = 5 initializer has_foo self end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 15 [implicit-public-methods]: the following private methods were made public implicitly: + foo. +class c : object method foo : int end +|}];; + +class type c = object(< foo : 'a; ..>) method private foo : int end;; +[%%expect {| +class type c = object method foo : int end +|}];; + +class ['a] p = object (_ : 'a) method private foo = 5 end;; +class c = [ < foo : int; .. > ] p;; +[%%expect {| +class ['a] p : + object ('a) constraint 'a = < .. > method private foo : int end +class c : object method foo : int end +|}];; + +(* Errors for undefined methods *) + +class c = object method virtual foo : int end;; +[%%expect {| +Line 1, characters 10-45: +1 | class c = object method virtual foo : int end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This non-virtual class has virtual methods. + The following methods are virtual : foo +|}];; + +class type ct = object method virtual foo : int end;; +[%%expect {| +Line 1, characters 16-51: +1 | class type ct = object method virtual foo : int end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This non-virtual class type has virtual methods. + The following methods are virtual : foo +|}];; + +let o = object method virtual foo : int end;; +[%%expect {| +Line 1, characters 8-43: +1 | let o = object method virtual foo : int end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This object has virtual methods. + The following methods are virtual : foo +|}];; + +class c = object(self) initializer self#foo end;; +[%%expect {| +Line 1, characters 35-39: +1 | class c = object(self) initializer self#foo end;; + ^^^^ +Error: This expression has no method foo +|}];; + +let o = object(self) initializer self#foo end;; +[%%expect {| +Line 1, characters 33-37: +1 | let o = object(self) initializer self#foo end;; + ^^^^ +Error: This expression has no method foo +|}];; + +let has_foo (x : < foo : int; ..>) = () +class c = object(self) initializer has_foo self end;; +[%%expect {| +val has_foo : < foo : int; .. > -> unit = +Line 2, characters 10-51: +2 | class c = object(self) initializer has_foo self end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This non-virtual class has undeclared virtual methods. + The following methods were not declared : foo +|}];; + +let o = object(self) initializer has_foo self end;; +[%%expect {| +Line 1, characters 41-45: +1 | let o = object(self) initializer has_foo self end;; + ^^^^ +Error: This expression has type < > but an expression was expected of type + < foo : int; .. > + The first object type has no method foo +|}];; + +class c = object(_ : < foo : int; ..>) end;; +[%%expect {| +Line 1, characters 10-42: +1 | class c = object(_ : < foo : int; ..>) end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This non-virtual class has undeclared virtual methods. + The following methods were not declared : foo +|}];; + +class type ct = object(< foo : int; ..>) end;; +[%%expect {| +Line 1, characters 16-44: +1 | class type ct = object(< foo : int; ..>) end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This non-virtual class type has undeclared virtual methods. + The following methods were not declared : foo +|}];; + +let o = object(_ : < foo : int; ..>) end;; +[%%expect {| +Line 1, characters 8-40: +1 | let o = object(_ : < foo : int; ..>) end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This object has undeclared virtual methods. + The following methods were not declared : foo +|}];; + +(* Shadowing/overriding methods in class types *) + +class type c = object + val x : int + val x : float +end;; +[%%expect {| +class type c = object val x : float end +|}];; + +class type c = object + val x : int + val mutable x : int +end;; +[%%expect {| +class type c = object val mutable x : int end +|}];; + +class type c = object + val mutable x : int + val x : int +end;; +[%%expect {| +class type c = object val x : int end +|}];; + +class type virtual c = object + val virtual x : int + val x : int +end;; +[%%expect {| +class type c = object val x : int end +|}];; + +class type virtual c = object + val x : int + val virtual x : int +end;; +[%%expect {| +class type c = object val x : int end +|}];; + +class type virtual c = object + val x : int + val virtual x : float +end;; +[%%expect {| +class type c = object val x : float end +|}];; + +class c = object + method virtual private test : unit + method private test = () +end + +let () = (new c)#test +[%%expect {| +class c : object method private test : unit end +Line 6, characters 9-16: +6 | let () = (new c)#test + ^^^^^^^ +Error: This expression has type c + It has no method test +|}];; + +class c = object + method virtual private test : unit + method test = () +end + +let () = (new c)#test +[%%expect {| +class c : object method test : unit end +|}];; + +class virtual d = object + method virtual private test : unit +end + +class c = object + inherit d + method private test = () +end + +let () = (new c)#test +[%%expect {| +class virtual d : object method private virtual test : unit end +class c : object method private test : unit end +Line 10, characters 9-16: +10 | let () = (new c)#test + ^^^^^^^ +Error: This expression has type c + It has no method test +|}];; + +class c = object + inherit d + method test = () +end + +let () = (new c)#test +[%%expect {| +class c : object method test : unit end +|}];; + +class foo = + object + method private f (b : bool) = b + inherit object + method f (b : bool) = b + end + end +let _ = (new foo)#f true +[%%expect {| +class foo : object method f : bool -> bool end +- : bool = true +|}];; + + +class c : object + method virtual m : int +end = object + method m = 9 + end +[%%expect {| +Lines 1-3, characters 10-3: +1 | ..........object +2 | method virtual m : int +3 | end......... +Error: This non-virtual class type has virtual methods. + The following methods are virtual : m +|}];; + +class virtual c : object + method virtual m : int +end = object + method m = 42 + end +[%%expect {| +class virtual c : object method virtual m : int end +|}];; + +class virtual cv = object + method virtual m : int + end + +class c : cv = object + method m = 42 + end +[%%expect {| +class virtual cv : object method virtual m : int end +Line 5, characters 10-12: +5 | class c : cv = object + ^^ +Error: This non-virtual class type has virtual methods. + The following methods are virtual : m +|}];; + +class virtual c : cv = object + method m = 41 + end +[%%expect {| +class virtual c : cv +|}];; + +class c = cv +[%%expect {| +Line 1, characters 10-12: +1 | class c = cv + ^^ +Error: This non-virtual class has virtual methods. + The following methods are virtual : m +|}];; + +class virtual c = cv +[%%expect {| +class virtual c : cv +|}];; + +(** Test classes abbreviations with a recursive type *) +class ['a] c = object method m: ( as 'b) -> unit = fun _ -> () end +class d = ['a] c +[%%expect {| +class ['a] c : object method m : (< f : 'b; x : 'a > as 'b) -> unit end +Line 2, characters 0-16: +2 | class d = ['a] c + ^^^^^^^^^^^^^^^^ +Error: Some type variables are unbound in this type: class d : ['a] c + The method m has type (< f : 'b; x : 'a > as 'b) -> unit where 'a + is unbound +|}] diff --git a/ocaml/testsuite/tests/typing-objects/dummy.ml b/ocaml/testsuite/tests/typing-objects/dummy.ml index 3256e48a8bf..f2b797d25b8 100644 --- a/ocaml/testsuite/tests/typing-objects/dummy.ml +++ b/ocaml/testsuite/tests/typing-objects/dummy.ml @@ -60,7 +60,7 @@ class foo1 = object(self) end end;; [%%expect{| -class foo1 : object method child : child2 method previous : child2 option end +class foo1 : object method child : child1 method previous : child1 option end |}] class nested = object @@ -76,7 +76,7 @@ end;; [%%expect{| class nested : object - method obj : < child : unit -> child2; previous : child2 option > + method obj : < child : unit -> child1; previous : child1 option > end |}] @@ -93,7 +93,7 @@ class just_to_see = object(self) end;; [%%expect{| class just_to_see : - object method child : child2 method previous : child2 option end + object method child : child1 method previous : child1 option end |}] class just_to_see2 = object @@ -111,7 +111,7 @@ class just_to_see2 = object end;; [%%expect{| class just_to_see2 : - object method obj : < child : child2; previous : child2 option > end + object method obj : < child : child1; previous : child1 option > end |}] type gadt = Not_really_though : gadt @@ -127,7 +127,7 @@ end;; [%%expect{| type gadt = Not_really_though : gadt class just_to_see3 : - object method child : gadt -> child2 method previous : child2 option end + object method child : gadt -> child1 method previous : child1 option end |}] class leading_up_to = object(self : 'a) @@ -144,10 +144,8 @@ Lines 4-7, characters 4-7: 5 | inherit child1 self 6 | inherit child2 7 | end -Error: Cannot close type of object literal: - < child : '_weak1; previous : 'a option; _.. > as 'a - it has been unified with the self type of a class that is not yet - completely defined. +Error: This object has undeclared virtual methods. + The following methods were not declared : previous child |}] class assertion_failure = object(self : 'a) @@ -171,7 +169,150 @@ Lines 4-10, characters 4-7: 9 | method child = assert false 10 | end Error: Cannot close type of object literal: - < child : '_weak2; previous : 'a option; _.. > as 'a + < child : '_weak1; previous : 'a option; _.. > as 'a it has been unified with the self type of a class that is not yet completely defined. |}] + +(* MPR#7894 and variations *) +class parameter_contains_self app = object(self) + method invalidate : unit = + app#redrawWidget self +end;; +[%%expect{| +class parameter_contains_self : + < redrawWidget : 'a -> unit; .. > -> + object ('a) method invalidate : unit end +|}] + +class closes_via_inheritance param = + let _ = new parameter_contains_self param in object + inherit parameter_contains_self param + end;; +[%%expect{| +Line 3, characters 36-41: +3 | inherit parameter_contains_self param + ^^^^^ +Error: This expression has type + < redrawWidget : parameter_contains_self -> unit; .. > + but an expression was expected of type + < redrawWidget : < invalidate : unit; .. > -> unit; .. > + Type parameter_contains_self = < invalidate : unit > + is not compatible with type < invalidate : unit; .. > + Self type cannot be unified with a closed object type +|}] + +class closes_via_application param = + let _ = new parameter_contains_self param in + parameter_contains_self param;; +[%%expect{| +Line 3, characters 26-31: +3 | parameter_contains_self param;; + ^^^^^ +Error: This expression has type + < redrawWidget : parameter_contains_self -> unit; .. > + but an expression was expected of type + < redrawWidget : < invalidate : unit; .. > -> unit; .. > + Type parameter_contains_self = < invalidate : unit > + is not compatible with type < invalidate : unit; .. > + Self type cannot be unified with a closed object type +|}] + +let escapes_via_inheritance param = + let module Local = struct + class c = object + inherit parameter_contains_self param + end + end in + ();; +[%%expect{| +Line 4, characters 38-43: +4 | inherit parameter_contains_self param + ^^^^^ +Error: This expression has type 'a but an expression was expected of type + < redrawWidget : < invalidate : unit; .. > -> unit; .. > + Self type cannot escape its class +|}] + +let escapes_via_application param = + let module Local = struct + class c = parameter_contains_self param + end in + ();; +[%%expect{| +Line 3, characters 38-43: +3 | class c = parameter_contains_self param + ^^^^^ +Error: This expression has type 'a but an expression was expected of type + < redrawWidget : < invalidate : unit; .. > -> unit; .. > + Self type cannot escape its class +|}] + +let can_close_object_via_inheritance param = + let _ = new parameter_contains_self param in object + inherit parameter_contains_self param + end;; +[%%expect{| +Line 3, characters 36-41: +3 | inherit parameter_contains_self param + ^^^^^ +Error: This expression has type + < redrawWidget : parameter_contains_self -> unit; .. > + but an expression was expected of type + < redrawWidget : < invalidate : unit; .. > -> unit; .. > + Type parameter_contains_self = < invalidate : unit > + is not compatible with type < invalidate : unit; .. > + Self type cannot be unified with a closed object type +|}] + +let can_escape_object_via_inheritance param = object + inherit parameter_contains_self param + end;; +[%%expect{| +val can_escape_object_via_inheritance : + < redrawWidget : parameter_contains_self -> unit; .. > -> + parameter_contains_self = +|}] + +let can_close_object_explicitly = object (_ : < i : int >) + method i = 5 +end;; +[%%expect{| +val can_close_object_explicitly : < i : int > = +|}] + +let cannot_close_object_explicitly_with_inheritance = object + inherit object (_ : < i : int >) + method i = 5 + end +end;; +[%%expect{| +Line 2, characters 17-34: +2 | inherit object (_ : < i : int >) + ^^^^^^^^^^^^^^^^^ +Error: This pattern cannot match self: it only matches values of type + < i : int > +|}] + +class closes_after_constraint = + ((fun (x : 'a) -> object (_:'a) end) : 'a -> object('a) end) (object end);; +[%%expect{| +Line 2, characters 63-75: +2 | ((fun (x : 'a) -> object (_:'a) end) : 'a -> object('a) end) (object end);; + ^^^^^^^^^^^^ +Error: This expression has type < > but an expression was expected of type + < .. > + Self type cannot be unified with a closed object type +|}];; + +class type ['a] ct = object ('a) end +class type closes_via_application = [ ] ct;; +[%%expect{| +class type ['a] ct = object ('a) constraint 'a = < .. > end +Line 2, characters 38-47: +2 | class type closes_via_application = [ ] ct;; + ^^^^^^^^^ +Error: The type parameter < m : int > + does not meet its constraint: it should be < .. > + Self type cannot be unified with a closed object type +|}];; diff --git a/ocaml/testsuite/tests/typing-objects/errors.ml b/ocaml/testsuite/tests/typing-objects/errors.ml index bd905628515..7b13b58882f 100644 --- a/ocaml/testsuite/tests/typing-objects/errors.ml +++ b/ocaml/testsuite/tests/typing-objects/errors.ml @@ -13,3 +13,40 @@ Error: The type of this class, contains non-collapsible conjunctive types in constraints. Type int is not compatible with type float |}] + +class type ct = object + method x : int +end + +class c (y : 'a * float) : ct = object + method x = y +end +[%%expect{| +class type ct = object method x : int end +Lines 5-7, characters 32-3: +5 | ................................object +6 | method x = y +7 | end +Error: The class type object method x : 'a * float end + is not matched by the class type ct + The class type object method x : 'a * float end + is not matched by the class type object method x : int end + The method x has type 'a * float but is expected to have type int + Type 'a * float is not compatible with type int +|}] + +let foo = 42#m;; +[%%expect{| +Line 1, characters 10-12: +1 | let foo = 42#m;; + ^^ +Error: This expression is not an object; it has type int +|}] + +let foo = object (self) method foo = self#bar end;; +[%%expect{| +Line 1, characters 37-41: +1 | let foo = object (self) method foo = self#bar end;; + ^^^^ +Error: This expression has no method bar +|}] diff --git a/ocaml/testsuite/tests/typing-objects/field_kind.ml b/ocaml/testsuite/tests/typing-objects/field_kind.ml new file mode 100644 index 00000000000..097c0748109 --- /dev/null +++ b/ocaml/testsuite/tests/typing-objects/field_kind.ml @@ -0,0 +1,73 @@ +(* TEST + * expect +*) + +type _ t = Int : int t;; +[%%expect{| +type _ t = Int : int t +|}] + +let o = + object (self) + method private x = 3 + method m : type a. a t -> a = fun Int -> (self#x : int) + end;; +[%%expect{| +val o : < m : 'a. 'a t -> 'a > = +|}] + +let o' = + object (self : 's) + method private x = 3 + method m : type a. a t -> 's -> a = fun Int other -> (other#x : int) + end;; + +let aargh = assert (o'#m Int o' = 3);; +[%%expect{| +Lines 2-5, characters 2-5: +2 | ..object (self : 's) +3 | method private x = 3 +4 | method m : type a. a t -> 's -> a = fun Int other -> (other#x : int) +5 | end.. +Warning 15 [implicit-public-methods]: the following private methods were made public implicitly: + x. +val o' : < m : 'a. 'a t -> 'b -> 'a; x : int > as 'b = +val aargh : unit = () +|}] + +let o2 = + object (self : 's) + method private x = 3 + method m : 's -> int = fun other -> (other#x : int) + end;; +[%%expect{| +Lines 2-5, characters 2-5: +2 | ..object (self : 's) +3 | method private x = 3 +4 | method m : 's -> int = fun other -> (other#x : int) +5 | end.. +Warning 15 [implicit-public-methods]: the following private methods were made public implicitly: + x. +val o2 : < m : 'a -> int; x : int > as 'a = +|}] + +let o3 = + object (self : 's) + method private x = 3 + method m : 's -> int = fun other -> + let module M = struct let other = other end in (M.other#x : int) + end;; + +let aargh = assert (o3#m o3 = 3);; +[%%expect{| +Lines 2-6, characters 2-5: +2 | ..object (self : 's) +3 | method private x = 3 +4 | method m : 's -> int = fun other -> +5 | let module M = struct let other = other end in (M.other#x : int) +6 | end.. +Warning 15 [implicit-public-methods]: the following private methods were made public implicitly: + x. +val o3 : < m : 'a -> int; x : int > as 'a = +val aargh : unit = () +|}] diff --git a/ocaml/testsuite/tests/typing-objects/pr6907_bad.ml b/ocaml/testsuite/tests/typing-objects/pr6907_bad.ml index 427ad987012..cafe04f4404 100644 --- a/ocaml/testsuite/tests/typing-objects/pr6907_bad.ml +++ b/ocaml/testsuite/tests/typing-objects/pr6907_bad.ml @@ -18,6 +18,5 @@ Line 2, characters 2-27: ^^^^^^^^^^^^^^^^^^^^^^^^^ Error: Some type variables are unbound in this type: class base : 'e -> ['e] t - The method update has type 'e -> < update : 'a; .. > as 'a where 'e - is unbound + The method update has type 'e -> #base where 'e is unbound |}];; diff --git a/ocaml/testsuite/tests/typing-objects/unbound-type-var.ml b/ocaml/testsuite/tests/typing-objects/unbound-type-var.ml new file mode 100644 index 00000000000..9e00cea2021 --- /dev/null +++ b/ocaml/testsuite/tests/typing-objects/unbound-type-var.ml @@ -0,0 +1,19 @@ +(* TEST + * expect +*) + +class test a c = +object + method b = c +end + +[%%expect{| +Lines 1-4, characters 0-3: +1 | class test a c = +2 | object +3 | method b = c +4 | end +Error: Some type variables are unbound in this type: + class test : 'a -> 'b -> object method b : 'b end + The method b has type 'b where 'b is unbound +|}] diff --git a/ocaml/testsuite/tests/typing-poly-bugs/pr5322_ok.ml b/ocaml/testsuite/tests/typing-poly-bugs/pr5322_ok.ml index aeda3322f4f..7534c64f3ec 100644 --- a/ocaml/testsuite/tests/typing-poly-bugs/pr5322_ok.ml +++ b/ocaml/testsuite/tests/typing-poly-bugs/pr5322_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-poly-bugs/pr5673_ok.ml b/ocaml/testsuite/tests/typing-poly-bugs/pr5673_ok.ml index f5a5cec747e..f30487b18d3 100644 --- a/ocaml/testsuite/tests/typing-poly-bugs/pr5673_ok.ml +++ b/ocaml/testsuite/tests/typing-poly-bugs/pr5673_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-poly-bugs/pr6922_ok.ml b/ocaml/testsuite/tests/typing-poly-bugs/pr6922_ok.ml index 0e8b7a4aae4..1db9e73bf91 100644 --- a/ocaml/testsuite/tests/typing-poly-bugs/pr6922_ok.ml +++ b/ocaml/testsuite/tests/typing-poly-bugs/pr6922_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-poly/error_messages.ml b/ocaml/testsuite/tests/typing-poly/error_messages.ml index eb26a7f9983..02a6b748f7b 100644 --- a/ocaml/testsuite/tests/typing-poly/error_messages.ml +++ b/ocaml/testsuite/tests/typing-poly/error_messages.ml @@ -38,8 +38,8 @@ Line 4, characters 49-50: ^ Error: This expression has type < a : 'a; b : 'a > but an expression was expected of type < a : 'a; b : 'a0. 'a0 > - The method b has type 'a, but the expected method type was 'a. 'a - The universal variable 'a would escape its scope + The method b has type 'a, but the expected method type was 'a0. 'a0 + The universal variable 'a0 would escape its scope |}] @@ -58,9 +58,9 @@ Lines 5-7, characters 10-5: 5 | ..........(object 6 | method f _ = 0 7 | end).. -Error: This expression has type < f : 'a -> int > +Error: This expression has type < f : 'b -> int > but an expression was expected of type t_a - The method f has type 'a -> int, but the expected method type was + The method f has type 'b -> int, but the expected method type was 'a. 'a -> int The universal variable 'a would escape its scope |} @@ -77,9 +77,9 @@ val f : uv -> int = Line 4, characters 11-49: 4 | let () = f ( `A (object method f _ = 0 end): _ v);; ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This expression has type 'a v but an expression was expected of type +Error: This expression has type 'b v but an expression was expected of type uv - The method f has type 'a -> int, but the expected method type was + The method f has type 'b -> int, but the expected method type was 'a. 'a -> int The universal variable 'a would escape its scope |}] diff --git a/ocaml/testsuite/tests/typing-poly/poly.ml b/ocaml/testsuite/tests/typing-poly/poly.ml index 9687949d477..c213f00b50f 100644 --- a/ocaml/testsuite/tests/typing-poly/poly.ml +++ b/ocaml/testsuite/tests/typing-poly/poly.ml @@ -966,6 +966,19 @@ Error: Constraints are not satisfied in this type. Type 'a u t should be an instance of g t |}];; +(* Full unification trace reported for "Constraints are not satisfied in this type" *) +type ('a,'b) t constraint 'a = 'b + constraint 'a = int + and 'a u = (float,string) t;; +[%%expect {| +Line 3, characters 13-29: +3 | and 'a u = (float,string) t;; + ^^^^^^^^^^^^^^^^ +Error: Constraints are not satisfied in this type. + Type (float, string) t should be an instance of (int, int) t + Type float is not compatible with type int +|}] + (* Example of wrong expansion *) type 'a u = < m : 'a v > and 'a v = 'a list u;; [%%expect {| @@ -1005,14 +1018,14 @@ type u = 'a t as 'a |}];; (* pass typetexp, but fails during Typedecl.check_recursion *) -type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] -and ('a, 'b) b = 'b -> unit constraint 'b = [> `A of ('a, 'b) a as 'a];; +type ('a1, 'b1) ty1 = 'a1 -> unit constraint 'a1 = [> `V1 of ('a1, 'b1) ty2 as 'b1] +and ('a2, 'b2) ty2 = 'b2 -> unit constraint 'b2 = [> `V2 of ('a2, 'b2) ty1 as 'a2];; [%%expect {| -Line 1, characters 0-71: -1 | type ('a, 'b) a = 'a -> unit constraint 'a = [> `B of ('a, 'b) b as 'b] - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: The definition of a contains a cycle: - [> `B of ('a, 'b) b as 'b ] as 'a +Line 1, characters 0-83: +1 | type ('a1, 'b1) ty1 = 'a1 -> unit constraint 'a1 = [> `V1 of ('a1, 'b1) ty2 as 'b1] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: The definition of ty1 contains a cycle: + [> `V1 of ('a, 'b) ty2 as 'b ] as 'a |}];; (* PR#8359: expanding may change original in Ctype.unify2 *) @@ -1092,12 +1105,11 @@ Line 4, characters 11-60: Warning 15 [implicit-public-methods]: the following private methods were made public implicitly: n. val f : unit -> < m : int; n : int > = -Line 5, characters 11-56: +Line 5, characters 27-39: 5 | let f () = object (self:c) method n = 1 method m = 2 end;; - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: This object is expected to have type c but actually has type - < m : int; n : 'a > - The first object type has no method n + ^^^^^^^^^^^^ +Error: This object is expected to have type : c + This type does not have a method n. |}];; @@ -1117,9 +1129,9 @@ Error: This expression has type < m : 'a. 'a * < m : 'a * 'b > > as 'b but an expression was expected of type < m : 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd) > The method m has type - 'a. 'a * (< m : 'a * < m : 'c. 'c * 'b > > as 'b), + 'a. 'a * (< m : 'a * < m : 'c. 'c * 'd > > as 'd), but the expected method type was - 'c. 'c * < m : 'a * < m : 'c. 'b > > as 'b + 'c. 'c * < m : 'a * < m : 'c. 'e > > as 'e The universal variable 'a would escape its scope |}];; @@ -1164,6 +1176,12 @@ Error: Signature mismatch: val f : (< m : 'a. 'a * ('a * 'b) > as 'b) -> unit is not included in val f : < m : 'b. 'b * ('b * < m : 'c. 'c * 'a > as 'a) > -> unit + The type (< m : 'a. 'a * ('a * 'd) > as 'd) -> unit + is not compatible with the type + < m : 'b. 'b * ('b * < m : 'c. 'c * 'e > as 'e) > -> unit + The method m has type 'a. 'a * ('a * < m : 'a. 'f >) as 'f, + but the expected method type was 'c. 'c * ('b * < m : 'c. 'g >) as 'g + The universal variable 'b would escape its scope |}];; module M : sig type 'a t type u = end @@ -1236,8 +1254,7 @@ Lines 2-3, characters 2-47: 3 | :> as 'b) -> int>).. Error: Type < m : 'a. (< p : int; .. > as 'a) -> int > is not a subtype of < m : 'b. (< p : int; q : int; .. > as 'b) -> int > - Type < p : int; q : int; .. > as 'c is not a subtype of - < p : int; .. > as 'd + Type < p : int; q : int; .. > is not a subtype of < p : int; .. > |}];; (* Keep sharing the epsilons *) @@ -1523,6 +1540,15 @@ Error: This expression has type < m : 'x. [< `Foo of 'x ] -> 'x > but an expression was expected of type < m : 'a. [< `Foo of int ] -> 'a > The universal variable 'x would escape its scope +|}, Principal{| +Line 2, characters 2-72: +2 | object method m : 'x. [< `Foo of 'x] -> 'x = fun x -> assert false end;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This expression has type < m : 'x. [< `Foo of 'x ] -> 'x > + but an expression was expected of type < m : 'a. 'b -> 'a > + The method m has type 'x. [< `Foo of 'x ] -> 'x, + but the expected method type was 'a. 'b -> 'a + The universal variable 'x would escape its scope |}];; (* ok *) let f (n : < m : 'a 'r. [< `Foo of 'a & int | `Bar] as 'r >) = @@ -1556,6 +1582,11 @@ Error: Values do not match: is not included in val f : < m : 'a. [< `Bar | `Foo of 'b & int ] as 'c > -> < m : 'b. 'c > + The type + < m : 'a. [< `Bar | `Foo of 'b & int ] as 'c > -> < m : 'b. 'c > + is not compatible with the type + < m : 'a. [< `Bar | `Foo of 'b & int ] as 'd > -> < m : 'b. 'd > + Types for tag `Foo are incompatible |}] (* PR#6171 *) @@ -1863,7 +1894,7 @@ Line 1, characters 17-18: ^ Error: This expression has type u but an expression was expected of type v The method m has type 'a s list * < m : 'b > as 'b, - but the expected method type was 'a. 'a s list * < m : 'a. 'b > as 'b + but the expected method type was 'a. 'a s list * < m : 'a. 'c > as 'c The universal variable 'a would escape its scope |}] diff --git a/ocaml/testsuite/tests/typing-poly/poly_params.ml b/ocaml/testsuite/tests/typing-poly/poly_params.ml new file mode 100644 index 00000000000..aba9bce510d --- /dev/null +++ b/ocaml/testsuite/tests/typing-poly/poly_params.ml @@ -0,0 +1,359 @@ +(* TEST + * expect +*) + +let poly1 (id : 'a. 'a -> 'a) = id 3, id "three" +[%%expect {| +val poly1 : ('a. 'a -> 'a) -> int * string = +|}];; + +let _ = poly1 (fun x -> x) +[%%expect {| +- : int * string = (3, "three") +|}];; + +let _ = poly1 (fun x -> x + 1) +[%%expect {| +Line 1, characters 14-30: +1 | let _ = poly1 (fun x -> x + 1) + ^^^^^^^^^^^^^^^^ +Error: This argument has type int -> int which is less general than + 'a. 'a -> 'a +|}];; + +let id x = x +let _ = poly1 id +[%%expect {| +val id : 'a -> 'a = +- : int * string = (3, "three") +|}];; + +let _ = poly1 (id (fun x -> x)) +[%%expect {| +Line 1, characters 14-31: +1 | let _ = poly1 (id (fun x -> x)) + ^^^^^^^^^^^^^^^^^ +Error: This argument has type 'b -> 'b which is less general than + 'a. 'a -> 'a +|}];; + +let _ = poly1 (let r = ref None in fun x -> r := Some x; x) +[%%expect {| +Line 1, characters 14-59: +1 | let _ = poly1 (let r = ref None in fun x -> r := Some x; x) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This argument has type 'b -> 'b which is less general than + 'a. 'a -> 'a +|}];; + +let escape f = poly1 (fun x -> f x; x) +[%%expect {| +Line 1, characters 21-38: +1 | let escape f = poly1 (fun x -> f x; x) + ^^^^^^^^^^^^^^^^^ +Error: This argument has type 'b -> 'b which is less general than + 'a. 'a -> 'a +|}];; + +let poly2 : ('a. 'a -> 'a) -> int * string = + fun id -> id 3, id "three" +[%%expect {| +val poly2 : ('a. 'a -> 'a) -> int * string = +|}];; + +let _ = poly2 (fun x -> x) +[%%expect {| +- : int * string = (3, "three") +|}];; + +let _ = poly2 (fun x -> x + 1) +[%%expect {| +Line 1, characters 14-30: +1 | let _ = poly2 (fun x -> x + 1) + ^^^^^^^^^^^^^^^^ +Error: This argument has type int -> int which is less general than + 'a. 'a -> 'a +|}];; + +let poly3 : 'b. ('a. 'a -> 'a) -> 'b -> 'b * 'b option = + fun id x -> id x, id (Some x) +[%%expect {| +val poly3 : ('a. 'a -> 'a) -> 'b -> 'b * 'b option = +|}];; + +let _ = poly3 (fun x -> x) 8 +[%%expect {| +- : int * int option = (8, Some 8) +|}];; + +let _ = poly3 (fun x -> x + 1) 8 +[%%expect {| +Line 1, characters 14-30: +1 | let _ = poly3 (fun x -> x + 1) 8 + ^^^^^^^^^^^^^^^^ +Error: This argument has type int -> int which is less general than + 'a. 'a -> 'a +|}];; + +let rec poly4 p (id : 'a. 'a -> 'a) = + if p then poly4 false id else id 4, id "four" +[%%expect {| +val poly4 : bool -> ('a. 'a -> 'a) -> int * string = +|}];; + +let _ = poly4 true (fun x -> x) +[%%expect {| +- : int * string = (4, "four") +|}];; + +let _ = poly4 true (fun x -> x + 1) +[%%expect {| +Line 1, characters 19-35: +1 | let _ = poly4 true (fun x -> x + 1) + ^^^^^^^^^^^^^^^^ +Error: This argument has type int -> int which is less general than + 'a. 'a -> 'a +|}];; + +let rec poly5 : bool -> ('a. 'a -> 'a) -> int * string = + fun p id -> + if p then poly5 false id else id 5, id "five" +[%%expect {| +val poly5 : bool -> ('a. 'a -> 'a) -> int * string = +|}];; + +let _ = poly5 true (fun x -> x) +[%%expect {| +- : int * string = (5, "five") +|}];; + +let _ = poly5 true (fun x -> x + 1) +[%%expect {| +Line 1, characters 19-35: +1 | let _ = poly5 true (fun x -> x + 1) + ^^^^^^^^^^^^^^^^ +Error: This argument has type int -> int which is less general than + 'a. 'a -> 'a +|}];; + + +let rec poly6 : 'b. bool -> ('a. 'a -> 'a) -> 'b -> 'b * 'b option = + fun p id x -> + if p then poly6 false id x else id x, id (Some x) +[%%expect {| +val poly6 : bool -> ('a. 'a -> 'a) -> 'b -> 'b * 'b option = +|}];; + +let _ = poly6 true (fun x -> x) 8 +[%%expect {| +- : int * int option = (8, Some 8) +|}];; + +let _ = poly6 true (fun x -> x + 1) 8 +[%%expect {| +Line 1, characters 19-35: +1 | let _ = poly6 true (fun x -> x + 1) 8 + ^^^^^^^^^^^^^^^^ +Error: This argument has type int -> int which is less general than + 'a. 'a -> 'a +|}];; + +let needs_magic (magic : 'a 'b. 'a -> 'b) = (magic 5 : string) +let _ = needs_magic (fun x -> x) +[%%expect {| +val needs_magic : ('a 'b. 'a -> 'b) -> string = +Line 2, characters 20-32: +2 | let _ = needs_magic (fun x -> x) + ^^^^^^^^^^^^ +Error: This argument has type 'c. 'c -> 'c which is less general than + 'a 'b. 'a -> 'b +|}];; + +let with_id (f : ('a. 'a -> 'a) -> 'b) = f (fun x -> x) +[%%expect {| +val with_id : (('a. 'a -> 'a) -> 'b) -> 'b = +|}];; + +let _ = with_id (fun id -> id 4, id "four") +[%%expect {| +- : int * string = (4, "four") +|}];; + +let non_principal1 p f = + if p then with_id f + else f (fun x -> x) +[%%expect {| +val non_principal1 : bool -> (('a. 'a -> 'a) -> 'b) -> 'b = +|}, Principal{| +Line 3, characters 7-21: +3 | else f (fun x -> x) + ^^^^^^^^^^^^^^ +Warning 18 [not-principal]: applying a higher-rank function here is not principal. +val non_principal1 : bool -> (('a. 'a -> 'a) -> 'b) -> 'b = +|}];; + +let non_principal2 p f = + if p then f (fun x -> x) + else with_id f +[%%expect {| +Line 3, characters 15-16: +3 | else with_id f + ^ +Error: This expression has type ('b -> 'b) -> 'c + but an expression was expected of type ('a. 'a -> 'a) -> 'd + The universal variable 'a would escape its scope +|}];; + +let principal1 p (f : ('a. 'a -> 'a) -> 'b) = + if p then f (fun x -> x) + else with_id f +[%%expect {| +val principal1 : bool -> (('a. 'a -> 'a) -> 'b) -> 'b = +|}];; + +let principal2 : bool -> (('a. 'a -> 'a) -> 'b) -> 'b = + fun p f -> + if p then f (fun x -> x) + else with_id f +[%%expect {| +val principal2 : bool -> (('a. 'a -> 'a) -> 'b) -> 'b = +|}];; + +type poly = ('a. 'a -> 'a) -> int * string + +let principal3 : poly option list = [ None; Some (fun x -> x 5, x "hello") ] +[%%expect {| +type poly = ('a. 'a -> 'a) -> int * string +val principal3 : poly option list = [None; Some ] +|}];; + +let non_principal3 = + [ (Some (fun x -> x 5, x "hello") : poly option); + Some (fun y -> y 6, y "goodbye") ] +[%%expect {| +val non_principal3 : poly option list = [Some ; Some ] +|}, Principal{| +Line 3, characters 9-36: +3 | Some (fun y -> y 6, y "goodbye") ] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 18 [not-principal]: this higher-rank function is not principal. +val non_principal3 : poly option list = [Some ; Some ] +|}];; + +let non_principal4 = + [ Some (fun y -> y 6, y "goodbye"); + (Some (fun x -> x 5, x "hello") : poly option) ] +[%%expect {| +Line 2, characters 26-35: +2 | [ Some (fun y -> y 6, y "goodbye"); + ^^^^^^^^^ +Error: This expression has type string but an expression was expected of type + int +|}];; + +(* Functions with polymorphic parameters are separate from other functions *) +type 'a arg = 'b + constraint 'a = 'b -> 'c +type really_poly = (('a. 'a -> 'a) -> string) arg +[%%expect {| +type 'a arg = 'b constraint 'a = 'b -> 'c +Line 3, characters 20-44: +3 | type really_poly = (('a. 'a -> 'a) -> string) arg + ^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This type ('a. 'a -> 'a) -> string should be an instance of type + 'b -> 'c + The universal variable 'a would escape its scope +|}];; + +(* Polymorphic parameters are (mostly) treated as invariant *) +type p1 = ('a. 'a -> 'a) -> int +type p2 = ('a 'b. 'a -> 'b) -> int +[%%expect {| +type p1 = ('a. 'a -> 'a) -> int +type p2 = ('a 'b. 'a -> 'b) -> int +|}];; + +let foo (f : p1) : p2 = f +[%%expect {| +Line 1, characters 24-25: +1 | let foo (f : p1) : p2 = f + ^ +Error: This expression has type p1 = ('a. 'a -> 'a) -> int + but an expression was expected of type p2 = ('a 'b. 'a -> 'b) -> int + Type 'a is not compatible with type 'b +|}];; + +let foo f = (f : p1 :> p2) +[%%expect {| +Line 1, characters 12-26: +1 | let foo f = (f : p1 :> p2) + ^^^^^^^^^^^^^^ +Error: Type p1 = ('a. 'a -> 'a) -> int is not a subtype of + p2 = ('a 'b. 'a -> 'b) -> int + Type 'b is not a subtype of 'a +|}];; + +module Foo (X : sig val f : p1 end) : sig val f : p2 end = X +[%%expect {| +Line 1, characters 59-60: +1 | module Foo (X : sig val f : p1 end) : sig val f : p2 end = X + ^ +Error: Signature mismatch: + Modules do not match: + sig val f : p1 end + is not included in + sig val f : p2 end + Values do not match: val f : p1 is not included in val f : p2 + The type p1 = ('a. 'a -> 'a) -> int is not compatible with the type + p2 = ('a 'b. 'a -> 'b) -> int + Type 'a is not compatible with type 'b +|}];; + +let foo (f : p1) : p2 = (fun id -> f id) +[%%expect {| +val foo : p1 -> p2 = +|}];; + +(* Following the existing behaviour for polymorphic methods, you can + subtype from a polymorphic parameter to a monomorphic + parameter. Elsewhere it still behaves as invariant. *) +type p1 = (bool -> bool) -> int +type p2 = ('a. 'a -> 'a) -> int + +let foo (x : p1) : p2 = x +[%%expect {| +type p1 = (bool -> bool) -> int +type p2 = ('a. 'a -> 'a) -> int +Line 4, characters 24-25: +4 | let foo (x : p1) : p2 = x + ^ +Error: This expression has type p1 = (bool -> bool) -> int + but an expression was expected of type p2 = ('a. 'a -> 'a) -> int + Type bool is not compatible with type 'a +|}];; + +let foo x = (x : p1 :> p2) +[%%expect {| +val foo : p1 -> p2 = +|}];; + +module Foo (X : sig val f : p1 end) : sig val f : p2 end = X +[%%expect {| +Line 1, characters 59-60: +1 | module Foo (X : sig val f : p1 end) : sig val f : p2 end = X + ^ +Error: Signature mismatch: + Modules do not match: + sig val f : p1 end + is not included in + sig val f : p2 end + Values do not match: val f : p1 is not included in val f : p2 + The type p1 = (bool -> bool) -> int is not compatible with the type + p2 = ('a. 'a -> 'a) -> int + Type bool is not compatible with type 'a +|}];; + +let foo (f : p1) : p2 = (fun id -> f id) +[%%expect {| +val foo : p1 -> p2 = +|}];; diff --git a/ocaml/testsuite/tests/typing-poly/pr11544.ml b/ocaml/testsuite/tests/typing-poly/pr11544.ml new file mode 100644 index 00000000000..98d588bb5ae --- /dev/null +++ b/ocaml/testsuite/tests/typing-poly/pr11544.ml @@ -0,0 +1,11 @@ +(* TEST + * expect +*) + +module M = struct type t = T end +let poly3 : 'b. M.t -> 'b -> 'b = + fun T x -> x +[%%expect {| +module M : sig type t = T end +val poly3 : M.t -> 'b -> 'b = +|}];; diff --git a/ocaml/testsuite/tests/typing-poly/pr9603.ml b/ocaml/testsuite/tests/typing-poly/pr9603.ml index 9052a1a43f7..02f1e921b9d 100644 --- a/ocaml/testsuite/tests/typing-poly/pr9603.ml +++ b/ocaml/testsuite/tests/typing-poly/pr9603.ml @@ -29,8 +29,5 @@ Error: This expression has type < m : 'left 'right. < left : 'left; right : 'right > pair > but an expression was expected of type < m : 'left 'right. < left : 'left; right : 'right > pair > - Type < left : 'left; right : 'right > pair = 'a * 'b - is not compatible with type < left : 'left0; right : 'right0 > pair - The method left has type 'a, but the expected method type was 'left - The universal variable 'left would escape its scope + Types for method m are incompatible |}] diff --git a/ocaml/testsuite/tests/typing-polyvariants-bugs-2/pr3918c.compilers.reference b/ocaml/testsuite/tests/typing-polyvariants-bugs-2/pr3918c.compilers.reference index fe848a573ad..82ba615155e 100644 --- a/ocaml/testsuite/tests/typing-polyvariants-bugs-2/pr3918c.compilers.reference +++ b/ocaml/testsuite/tests/typing-polyvariants-bugs-2/pr3918c.compilers.reference @@ -1,6 +1,5 @@ File "pr3918c.ml", line 24, characters 11-12: 24 | let f x = (x : 'a vlist :> 'b vlist) ^ -Error: This expression has type 'b Pr3918b.vlist = 'a - but an expression was expected of type 'b Pr3918b.vlist = 'c - The type variable 'a occurs inside ('e * 'd) Pr3918a.voption as 'd +Error: This expression has type 'b Pr3918b.vlist + but an expression was expected of type 'b Pr3918b.vlist diff --git a/ocaml/testsuite/tests/typing-polyvariants-bugs-2/pr3918c.ml b/ocaml/testsuite/tests/typing-polyvariants-bugs-2/pr3918c.ml index f3a7ccca140..7eabcd700b3 100644 --- a/ocaml/testsuite/tests/typing-polyvariants-bugs-2/pr3918c.ml +++ b/ocaml/testsuite/tests/typing-polyvariants-bugs-2/pr3918c.ml @@ -1,5 +1,5 @@ (* TEST -files = "pr3918a.mli pr3918b.mli" +readonly_files = "pr3918a.mli pr3918b.mli" * setup-ocamlc.byte-build-env ** ocamlc.byte module = "pr3918a.mli" diff --git a/ocaml/testsuite/tests/typing-polyvariants-bugs/pr4775_ok.ml b/ocaml/testsuite/tests/typing-polyvariants-bugs/pr4775_ok.ml index e471f4ec38d..e5d5f5978eb 100644 --- a/ocaml/testsuite/tests/typing-polyvariants-bugs/pr4775_ok.ml +++ b/ocaml/testsuite/tests/typing-polyvariants-bugs/pr4775_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-polyvariants-bugs/pr4933_ok.ml b/ocaml/testsuite/tests/typing-polyvariants-bugs/pr4933_ok.ml index 353169220ff..7a0bffcd54a 100644 --- a/ocaml/testsuite/tests/typing-polyvariants-bugs/pr4933_ok.ml +++ b/ocaml/testsuite/tests/typing-polyvariants-bugs/pr4933_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-polyvariants-bugs/pr5057_ok.ml b/ocaml/testsuite/tests/typing-polyvariants-bugs/pr5057_ok.ml index 8edd6b7f824..355eecd3ab4 100644 --- a/ocaml/testsuite/tests/typing-polyvariants-bugs/pr5057_ok.ml +++ b/ocaml/testsuite/tests/typing-polyvariants-bugs/pr5057_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-polyvariants-bugs/pr5057a_bad.ml b/ocaml/testsuite/tests/typing-polyvariants-bugs/pr5057a_bad.ml index 11a84c597ff..fa610017227 100644 --- a/ocaml/testsuite/tests/typing-polyvariants-bugs/pr5057a_bad.ml +++ b/ocaml/testsuite/tests/typing-polyvariants-bugs/pr5057a_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-polyvariants-bugs/pr7199_ok.ml b/ocaml/testsuite/tests/typing-polyvariants-bugs/pr7199_ok.ml index 02675e057d1..75ef0cce6a6 100644 --- a/ocaml/testsuite/tests/typing-polyvariants-bugs/pr7199_ok.ml +++ b/ocaml/testsuite/tests/typing-polyvariants-bugs/pr7199_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-polyvariants-bugs/pr7817_bad.ml b/ocaml/testsuite/tests/typing-polyvariants-bugs/pr7817_bad.ml index 85d82c928da..fc9cf7fbdaa 100644 --- a/ocaml/testsuite/tests/typing-polyvariants-bugs/pr7817_bad.ml +++ b/ocaml/testsuite/tests/typing-polyvariants-bugs/pr7817_bad.ml @@ -26,4 +26,8 @@ Error: Signature mismatch: val write : _[< `A of '_weak2 | `B of '_weak3 ] -> unit is not included in val write : [< `A of string | `B of int ] -> unit + The type _[< `A of '_weak2 | `B of '_weak3 ] -> unit + is not compatible with the type [< `A of string | `B of int ] -> unit + Type _[< `A of '_weak2 | `B of '_weak3 ] is not compatible with type + [< `A of string | `B of int ] |}] diff --git a/ocaml/testsuite/tests/typing-polyvariants-bugs/pr8575.ml b/ocaml/testsuite/tests/typing-polyvariants-bugs/pr8575.ml new file mode 100644 index 00000000000..f69d10adaca --- /dev/null +++ b/ocaml/testsuite/tests/typing-polyvariants-bugs/pr8575.ml @@ -0,0 +1,36 @@ +(* TEST + * expect +*) + +module A = struct type t = A | B let x = B end;; +[%%expect{| +module A : sig type t = A | B val x : t end +|}] + +let test () = + match A.x with + | A as a -> `A_t a + | B when false -> `Onoes + | B -> if Random.bool () then `Onoes else `A_t B;; +[%%expect{| +val test : unit -> [> `A_t of A.t | `Onoes ] = +|}, Principal{| +Line 5, characters 49-50: +5 | | B -> if Random.bool () then `Onoes else `A_t B;; + ^ +Error: Unbound constructor B +|}] + +let test () = + match A.x with + | B when false -> `Onoes + | A as a -> `A_t a + | B -> if Random.bool () then `Onoes else `A_t B;; +[%%expect{| +val test : unit -> [> `A_t of A.t | `Onoes ] = +|}, Principal{| +Line 5, characters 49-50: +5 | | B -> if Random.bool () then `Onoes else `A_t B;; + ^ +Error: Unbound constructor B +|}] diff --git a/ocaml/testsuite/tests/typing-polyvariants-bugs/privrowsabate_ok.ml b/ocaml/testsuite/tests/typing-polyvariants-bugs/privrowsabate_ok.ml index 7c7383469a9..9274c9d4af5 100644 --- a/ocaml/testsuite/tests/typing-polyvariants-bugs/privrowsabate_ok.ml +++ b/ocaml/testsuite/tests/typing-polyvariants-bugs/privrowsabate_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-private-bugs/pr5026_bad.ml b/ocaml/testsuite/tests/typing-private-bugs/pr5026_bad.ml index 52c135b3dcd..c62a3cb99cc 100644 --- a/ocaml/testsuite/tests/typing-private-bugs/pr5026_bad.ml +++ b/ocaml/testsuite/tests/typing-private-bugs/pr5026_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-private-bugs/pr5469_ok.ml b/ocaml/testsuite/tests/typing-private-bugs/pr5469_ok.ml index e7311b1a5cc..a5f36390a75 100644 --- a/ocaml/testsuite/tests/typing-private-bugs/pr5469_ok.ml +++ b/ocaml/testsuite/tests/typing-private-bugs/pr5469_ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-private/invalid_private_row.ml b/ocaml/testsuite/tests/typing-private/invalid_private_row.ml new file mode 100644 index 00000000000..361b982c11b --- /dev/null +++ b/ocaml/testsuite/tests/typing-private/invalid_private_row.ml @@ -0,0 +1,52 @@ +(* TEST + * expect +*) + +(** Error message for trying to make private a row type variable + that only exists syntactically *) + +type a = [`A | `C | `D] +type b = [`B | `D | `E] +type c = private [< a | b > `A `B `C `D `E] +[%%expect {| +type a = [ `A | `C | `D ] +type b = [ `B | `D | `E ] +Line 6, characters 0-43: +6 | type c = private [< a | b > `A `B `C `D `E] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This private row type declaration is invalid. + The type expression on the right-hand side reduces to + [ `A | `B | `C | `D | `E ] + which does not have a free row type variable. + Hint: If you intended to define a private type abbreviation, + write explicitly + private [ `A | `B | `C | `D | `E ] +|}] + +type u = private < x:int; .. > as 'a constraint 'a = < x: int > ;; +[%%expect {| +Line 1, characters 0-63: +1 | type u = private < x:int; .. > as 'a constraint 'a = < x: int > ;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This private row type declaration is invalid. + The type expression on the right-hand side reduces to + < x : int > + which does not have a free row type variable. + Hint: If you intended to define a private type abbreviation, + write explicitly + private < x : int > +|}] + +type u = private [> `A ] as 'a constraint 'a = [< `A ] ;; +[%%expect {| +Line 1, characters 0-54: +1 | type u = private [> `A ] as 'a constraint 'a = [< `A ] ;; + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Error: This private row type declaration is invalid. + The type expression on the right-hand side reduces to + [ `A ] + which does not have a free row type variable. + Hint: If you intended to define a private type abbreviation, + write explicitly + private [ `A ] +|}] diff --git a/ocaml/testsuite/tests/typing-private/private.compilers.principal.reference b/ocaml/testsuite/tests/typing-private/private.compilers.principal.reference index 2be849e1028..43f72b285df 100644 --- a/ocaml/testsuite/tests/typing-private/private.compilers.principal.reference +++ b/ocaml/testsuite/tests/typing-private/private.compilers.principal.reference @@ -30,6 +30,7 @@ Error: Signature mismatch: type t = M2.t is not included in type t = private M3.t + The type M2.t is not equal to the type M3.t Line 1, characters 44-45: 1 | module M4 : sig type t = private M3.t end = M;; (* fails *) ^ @@ -42,6 +43,7 @@ Error: Signature mismatch: type t = < m : int > is not included in type t = private M3.t + The type < m : int > is not equal to the type M3.t Line 1, characters 44-46: 1 | module M4 : sig type t = private M3.t end = M1;; (* might be ok *) ^^ @@ -54,6 +56,7 @@ Error: Signature mismatch: type t = M1.t is not included in type t = private M3.t + The type M1.t is not equal to the type M3.t module M5 : sig type t = private M1.t end Line 1, characters 53-55: 1 | module M6 : sig type t = private < n:int; .. > end = M1;; (* fails *) @@ -67,6 +70,7 @@ Error: Signature mismatch: type t = M1.t is not included in type t = private < n : int; .. > + The implementation is missing the method n Line 3, characters 2-51: 3 | struct type t = int let f (x : int) = (x : t) end;; (* must fail *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ @@ -79,6 +83,7 @@ Error: Signature mismatch: type t = int is not included in type t = private Foobar.t + The type int is not equal to the type Foobar.t module M : sig type t = private T of int val mk : int -> t end module M1 : sig type t = M.t val mk : int -> t end module M2 : sig type t = M.t val mk : int -> t end @@ -87,7 +92,7 @@ Line 3, characters 4-27: 3 | type t = M.t = T of int ^^^^^^^^^^^^^^^^^^^^^^^ Error: This variant or record definition does not match that of type M.t - A private type would be revealed. + Private variant constructor(s) would be revealed. module M5 : sig type t = M.t = private T of int val mk : int -> t end module M6 : sig type t = private T of int val mk : int -> t end module M' : @@ -117,7 +122,8 @@ Error: Type declarations do not match: type !'a t = private 'a constraint 'a = < x : int; .. > is not included in type 'a t - Their constraints differ. + Their parameters differ + The type < x : int; .. > is not equal to the type 'a type 'a t = private 'a constraint 'a = < x : int; .. > type t = [ `Closed ] type nonrec t = private [> t ] diff --git a/ocaml/testsuite/tests/typing-private/private.compilers.reference b/ocaml/testsuite/tests/typing-private/private.compilers.reference index 06968cd0e08..b282f9d1c86 100644 --- a/ocaml/testsuite/tests/typing-private/private.compilers.reference +++ b/ocaml/testsuite/tests/typing-private/private.compilers.reference @@ -30,6 +30,7 @@ Error: Signature mismatch: type t = M2.t is not included in type t = private M3.t + The type M2.t is not equal to the type M3.t Line 1, characters 44-45: 1 | module M4 : sig type t = private M3.t end = M;; (* fails *) ^ @@ -42,6 +43,7 @@ Error: Signature mismatch: type t = < m : int > is not included in type t = private M3.t + The type < m : int > is not equal to the type M3.t Line 1, characters 44-46: 1 | module M4 : sig type t = private M3.t end = M1;; (* might be ok *) ^^ @@ -54,6 +56,7 @@ Error: Signature mismatch: type t = M1.t is not included in type t = private M3.t + The type M1.t is not equal to the type M3.t module M5 : sig type t = private M1.t end Line 1, characters 53-55: 1 | module M6 : sig type t = private < n:int; .. > end = M1;; (* fails *) @@ -67,6 +70,7 @@ Error: Signature mismatch: type t = M1.t is not included in type t = private < n : int; .. > + The implementation is missing the method n Line 3, characters 2-51: 3 | struct type t = int let f (x : int) = (x : t) end;; (* must fail *) ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ @@ -79,6 +83,7 @@ Error: Signature mismatch: type t = int is not included in type t = private Foobar.t + The type int is not equal to the type Foobar.t module M : sig type t = private T of int val mk : int -> t end module M1 : sig type t = M.t val mk : int -> t end module M2 : sig type t = M.t val mk : int -> t end @@ -87,7 +92,7 @@ Line 3, characters 4-27: 3 | type t = M.t = T of int ^^^^^^^^^^^^^^^^^^^^^^^ Error: This variant or record definition does not match that of type M.t - A private type would be revealed. + Private variant constructor(s) would be revealed. module M5 : sig type t = M.t = private T of int val mk : int -> t end module M6 : sig type t = private T of int val mk : int -> t end module M' : @@ -117,7 +122,8 @@ Error: Type declarations do not match: type !'a t = private < x : int; .. > constraint 'a = 'a t is not included in type 'a t - Their constraints differ. + Their parameters differ + The type 'b t as 'b is not equal to the type 'a type 'a t = private 'a constraint 'a = < x : int; .. > type t = [ `Closed ] type nonrec t = private [> t ] diff --git a/ocaml/testsuite/tests/typing-recmod/t01bad.ml b/ocaml/testsuite/tests/typing-recmod/t01bad.ml index f0ae828a80e..5bf6197f370 100644 --- a/ocaml/testsuite/tests/typing-recmod/t01bad.ml +++ b/ocaml/testsuite/tests/typing-recmod/t01bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-recmod/t02bad.ml b/ocaml/testsuite/tests/typing-recmod/t02bad.ml index 9a490d890a9..1faba72b875 100644 --- a/ocaml/testsuite/tests/typing-recmod/t02bad.ml +++ b/ocaml/testsuite/tests/typing-recmod/t02bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-recmod/t03ok.ml b/ocaml/testsuite/tests/typing-recmod/t03ok.ml index 948d9bf8274..a1c9b32a95d 100644 --- a/ocaml/testsuite/tests/typing-recmod/t03ok.ml +++ b/ocaml/testsuite/tests/typing-recmod/t03ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-recmod/t04bad.ml b/ocaml/testsuite/tests/typing-recmod/t04bad.ml index 3de1bb109dc..a671b414d4c 100644 --- a/ocaml/testsuite/tests/typing-recmod/t04bad.ml +++ b/ocaml/testsuite/tests/typing-recmod/t04bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-recmod/t05bad.ml b/ocaml/testsuite/tests/typing-recmod/t05bad.ml index c413cec2bb0..1f1df6c590b 100644 --- a/ocaml/testsuite/tests/typing-recmod/t05bad.ml +++ b/ocaml/testsuite/tests/typing-recmod/t05bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-recmod/t06ok.ml b/ocaml/testsuite/tests/typing-recmod/t06ok.ml index 4305f243467..a0cfebdbc2d 100644 --- a/ocaml/testsuite/tests/typing-recmod/t06ok.ml +++ b/ocaml/testsuite/tests/typing-recmod/t06ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-recmod/t07bad.ml b/ocaml/testsuite/tests/typing-recmod/t07bad.ml index 1aa75ab7a9b..27e8f1859f7 100644 --- a/ocaml/testsuite/tests/typing-recmod/t07bad.ml +++ b/ocaml/testsuite/tests/typing-recmod/t07bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-recmod/t08bad.ml b/ocaml/testsuite/tests/typing-recmod/t08bad.ml index 0647311bfe2..46d2b727c4b 100644 --- a/ocaml/testsuite/tests/typing-recmod/t08bad.ml +++ b/ocaml/testsuite/tests/typing-recmod/t08bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-recmod/t09bad.ml b/ocaml/testsuite/tests/typing-recmod/t09bad.ml index ce281c5f7a7..9ac5d3133d8 100644 --- a/ocaml/testsuite/tests/typing-recmod/t09bad.ml +++ b/ocaml/testsuite/tests/typing-recmod/t09bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-recmod/t10ok.ml b/ocaml/testsuite/tests/typing-recmod/t10ok.ml index e91fe998fb8..626ab888fcb 100644 --- a/ocaml/testsuite/tests/typing-recmod/t10ok.ml +++ b/ocaml/testsuite/tests/typing-recmod/t10ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-recmod/t11bad.ml b/ocaml/testsuite/tests/typing-recmod/t11bad.ml index 1c8fbee299c..f6f2fed8468 100644 --- a/ocaml/testsuite/tests/typing-recmod/t11bad.ml +++ b/ocaml/testsuite/tests/typing-recmod/t11bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-recmod/t12bad.ml b/ocaml/testsuite/tests/typing-recmod/t12bad.ml index a0094bed219..cbc8c5bbaf8 100644 --- a/ocaml/testsuite/tests/typing-recmod/t12bad.ml +++ b/ocaml/testsuite/tests/typing-recmod/t12bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-recmod/t13ok.ml b/ocaml/testsuite/tests/typing-recmod/t13ok.ml index 5ba8026eabf..ee50f89041a 100644 --- a/ocaml/testsuite/tests/typing-recmod/t13ok.ml +++ b/ocaml/testsuite/tests/typing-recmod/t13ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-recmod/t14bad.ml b/ocaml/testsuite/tests/typing-recmod/t14bad.ml index 4ef061678bd..4fe91cccc18 100644 --- a/ocaml/testsuite/tests/typing-recmod/t14bad.ml +++ b/ocaml/testsuite/tests/typing-recmod/t14bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-recmod/t15bad.ml b/ocaml/testsuite/tests/typing-recmod/t15bad.ml index 71aa31c1463..efb99e681ea 100644 --- a/ocaml/testsuite/tests/typing-recmod/t15bad.ml +++ b/ocaml/testsuite/tests/typing-recmod/t15bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-recmod/t16ok.ml b/ocaml/testsuite/tests/typing-recmod/t16ok.ml index abd6d6a4cc8..1e87f4f82d2 100644 --- a/ocaml/testsuite/tests/typing-recmod/t16ok.ml +++ b/ocaml/testsuite/tests/typing-recmod/t16ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-recmod/t17ok.ml b/ocaml/testsuite/tests/typing-recmod/t17ok.ml index b59e80e2ed9..2a760d10135 100644 --- a/ocaml/testsuite/tests/typing-recmod/t17ok.ml +++ b/ocaml/testsuite/tests/typing-recmod/t17ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-recmod/t18ok.ml b/ocaml/testsuite/tests/typing-recmod/t18ok.ml index 3523f338c9b..e4e3ffa6112 100644 --- a/ocaml/testsuite/tests/typing-recmod/t18ok.ml +++ b/ocaml/testsuite/tests/typing-recmod/t18ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-recmod/t20ok.ml b/ocaml/testsuite/tests/typing-recmod/t20ok.ml index 98222594e01..ae0eed32640 100644 --- a/ocaml/testsuite/tests/typing-recmod/t20ok.ml +++ b/ocaml/testsuite/tests/typing-recmod/t20ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-recmod/t21ok.ml b/ocaml/testsuite/tests/typing-recmod/t21ok.ml index 59cdcc9f915..2c97da3fb9b 100644 --- a/ocaml/testsuite/tests/typing-recmod/t21ok.ml +++ b/ocaml/testsuite/tests/typing-recmod/t21ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-recmod/t22ok.ml b/ocaml/testsuite/tests/typing-recmod/t22ok.ml index 16e9cbcfed8..4709f23c9a7 100644 --- a/ocaml/testsuite/tests/typing-recmod/t22ok.ml +++ b/ocaml/testsuite/tests/typing-recmod/t22ok.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a " +flags = " -w -a " * setup-ocamlc.byte-build-env ** ocamlc.byte *** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/typing-rectypes-bugs/pr5343_bad.ml b/ocaml/testsuite/tests/typing-rectypes-bugs/pr5343_bad.ml index 588c9479bf9..518dafe0194 100644 --- a/ocaml/testsuite/tests/typing-rectypes-bugs/pr5343_bad.ml +++ b/ocaml/testsuite/tests/typing-rectypes-bugs/pr5343_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a -rectypes " +flags = " -w -a -rectypes " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-rectypes-bugs/pr6174_bad.ml b/ocaml/testsuite/tests/typing-rectypes-bugs/pr6174_bad.ml index 1c95a47dc0a..d5c704416cc 100644 --- a/ocaml/testsuite/tests/typing-rectypes-bugs/pr6174_bad.ml +++ b/ocaml/testsuite/tests/typing-rectypes-bugs/pr6174_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a -rectypes " +flags = " -w -a -rectypes " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-rectypes-bugs/pr6870_bad.ml b/ocaml/testsuite/tests/typing-rectypes-bugs/pr6870_bad.ml index 4c771b87b4f..186e07088b0 100644 --- a/ocaml/testsuite/tests/typing-rectypes-bugs/pr6870_bad.ml +++ b/ocaml/testsuite/tests/typing-rectypes-bugs/pr6870_bad.ml @@ -1,5 +1,5 @@ (* TEST -flags = " -w a -rectypes " +flags = " -w -a -rectypes " ocamlc_byte_exit_status = "2" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/typing-safe-linking/b_bad.ml b/ocaml/testsuite/tests/typing-safe-linking/b_bad.ml index 4dc6e6b400d..8b4fb768369 100644 --- a/ocaml/testsuite/tests/typing-safe-linking/b_bad.ml +++ b/ocaml/testsuite/tests/typing-safe-linking/b_bad.ml @@ -1,5 +1,5 @@ (* TEST -files = "a.ml" +readonly_files = "a.ml" * setup-ocamlc.byte-build-env ** ocamlc.byte module = "a.ml" diff --git a/ocaml/testsuite/tests/typing-shadowing-of-pervasives-submodules/redefine_largefile_top.ml b/ocaml/testsuite/tests/typing-shadowing-of-pervasives-submodules/redefine_largefile_top.ml index 2b4ee4735a2..883e8c79430 100644 --- a/ocaml/testsuite/tests/typing-shadowing-of-pervasives-submodules/redefine_largefile_top.ml +++ b/ocaml/testsuite/tests/typing-shadowing-of-pervasives-submodules/redefine_largefile_top.ml @@ -1,5 +1,5 @@ (* TEST - files = "largeFile.ml" + readonly_files = "largeFile.ml" * setup-ocaml-build-env ** ocamlc.byte compile_only = "true" diff --git a/ocaml/testsuite/tests/typing-short-paths/errors.ml b/ocaml/testsuite/tests/typing-short-paths/errors.ml index 2f08791d292..577c1499302 100644 --- a/ocaml/testsuite/tests/typing-short-paths/errors.ml +++ b/ocaml/testsuite/tests/typing-short-paths/errors.ml @@ -15,7 +15,7 @@ Line 5, characters 14-15: 5 | let x : M.t = S ^ Error: This variant expression is expected to have type t - The constructor S does not belong to type t + There is no constructor S within type t |}] module M = struct diff --git a/ocaml/testsuite/tests/typing-short-paths/short-paths.compilers.reference b/ocaml/testsuite/tests/typing-short-paths/short-paths.compilers.reference index 7265fe11bcb..2238467f5f8 100644 --- a/ocaml/testsuite/tests/typing-short-paths/short-paths.compilers.reference +++ b/ocaml/testsuite/tests/typing-short-paths/short-paths.compilers.reference @@ -96,6 +96,7 @@ Error: Signature mismatch: type t = int is not included in type t = string + The type t is not equal to the type string module A : sig module B : sig type t = T end end module M2 : sig type u = A.B.t type foo = int type v = u end diff --git a/ocaml/testsuite/tests/typing-short-paths/short-paths.ml b/ocaml/testsuite/tests/typing-short-paths/short-paths.ml index b55e41339ca..e6721af45fd 100644 --- a/ocaml/testsuite/tests/typing-short-paths/short-paths.ml +++ b/ocaml/testsuite/tests/typing-short-paths/short-paths.ml @@ -57,6 +57,10 @@ module N2 = struct type u = v and v = M1.v end;; module type PR6566 = sig type t = string end;; module PR6566 = struct type t = int end;; module PR6566' : PR6566 = PR6566;; +(* Short-paths is currently a bit overzealous with this error message: we print + "The type t is not equal to the type string" instead of "The type int is not + equal to the type string". This is correct, but less clear than it could + be. *) module A = struct module B = struct type t = T end end;; module M2 = struct type u = A.B.t type foo = int type v = A.B.t end;; diff --git a/ocaml/testsuite/tests/typing-signatures/nondep_regression.ml b/ocaml/testsuite/tests/typing-signatures/nondep_regression.ml new file mode 100644 index 00000000000..76033b3c4e3 --- /dev/null +++ b/ocaml/testsuite/tests/typing-signatures/nondep_regression.ml @@ -0,0 +1,17 @@ +(* TEST + * expect +*) + +type 'a seq = 'a list + +module Make (A : sig type t end) = struct + type t = A.t seq +end + +module H = Make (struct type t end) + +[%%expect{| +type 'a seq = 'a list +module Make : functor (A : sig type t end) -> sig type t = A.t seq end +module H : sig type t end +|}] diff --git a/ocaml/testsuite/tests/typing-sigsubst/sig_local_aliases_syntax_errors.compilers.reference b/ocaml/testsuite/tests/typing-sigsubst/sig_local_aliases_syntax_errors.compilers.reference index 860a36bfba8..be874969512 100644 --- a/ocaml/testsuite/tests/typing-sigsubst/sig_local_aliases_syntax_errors.compilers.reference +++ b/ocaml/testsuite/tests/typing-sigsubst/sig_local_aliases_syntax_errors.compilers.reference @@ -26,11 +26,7 @@ Error: Syntax error Line 4, characters 9-10: 4 | and u3 = char ^ -Error: Syntax error: 'end' expected -Line 2, characters 24-27: -2 | module type Rejected3 = sig - ^^^ - This 'sig' might be unmatched +Error: Syntax error Line 3, characters 7-13: 3 | type nonrec t := int ^^^^^^ diff --git a/ocaml/testsuite/tests/typing-sigsubst/sigsubst.ml b/ocaml/testsuite/tests/typing-sigsubst/sigsubst.ml index 92ffcee5083..5636e9abe25 100644 --- a/ocaml/testsuite/tests/typing-sigsubst/sigsubst.ml +++ b/ocaml/testsuite/tests/typing-sigsubst/sigsubst.ml @@ -24,11 +24,11 @@ end Line 3, characters 2-36: 3 | include Comparable with type t = t ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Error: Illegal shadowing of included type t/278 by t/282 +Error: Illegal shadowing of included type t/284 by t/289 Line 2, characters 2-19: - Type t/278 came from this include + Type t/284 came from this include Line 3, characters 2-23: - The value print has no valid type if t/278 is shadowed + The value print has no valid type if t/284 is shadowed |}] module type Sunderscore = sig diff --git a/ocaml/testsuite/tests/typing-sigsubst/test_locations.compilers.reference b/ocaml/testsuite/tests/typing-sigsubst/test_locations.compilers.reference index c3155381227..bfdcf939951 100644 --- a/ocaml/testsuite/tests/typing-sigsubst/test_locations.compilers.reference +++ b/ocaml/testsuite/tests/typing-sigsubst/test_locations.compilers.reference @@ -7,6 +7,7 @@ Error: Signature mismatch: type elt = String.t is not included in type elt = unit + The type String.t = string is not equal to the type unit File "test_loc_type_eq.ml", line 1, characters 31-46: Expected declaration File "test_functor.ml", line 8, characters 45-61: Actual declaration @@ -26,6 +27,7 @@ Error: Signature mismatch: type elt = String.t is not included in type elt = unit + The type String.t = string is not equal to the type unit File "test_loc_modtype_type_eq.ml", line 1, characters 36-51: Expected declaration File "test_functor.ml", line 8, characters 45-61: Actual declaration @@ -45,7 +47,10 @@ Error: Signature mismatch: val create : elt -> t is not included in val create : unit -> t - File "test_functor.ml", line 5, characters 2-23: Expected declaration + The type elt -> t is not compatible with the type unit -> t + Type elt = string is not compatible with type unit + File "test_loc_type_subst.ml", line 1, characters 11-47: + Expected declaration File "test_functor.ml", line 5, characters 2-23: Actual declaration File "test_loc_modtype_type_subst.ml", line 3, characters 15-42: 3 | module M : S = Test_functor.Apply (String) @@ -63,5 +68,8 @@ Error: Signature mismatch: val create : elt -> t is not included in val create : unit -> t - File "test_functor.ml", line 5, characters 2-23: Expected declaration + The type elt -> t is not compatible with the type unit -> t + Type elt = string is not compatible with type unit + File "test_loc_modtype_type_subst.ml", line 1, characters 16-52: + Expected declaration File "test_functor.ml", line 5, characters 2-23: Actual declaration diff --git a/ocaml/testsuite/tests/typing-sigsubst/test_locations.ml b/ocaml/testsuite/tests/typing-sigsubst/test_locations.ml index 310840011a8..4e727100f45 100644 --- a/ocaml/testsuite/tests/typing-sigsubst/test_locations.ml +++ b/ocaml/testsuite/tests/typing-sigsubst/test_locations.ml @@ -1,5 +1,5 @@ (* TEST -files = "test_functor.ml test_loc_modtype_type_eq.ml \ +readonly_files = "test_functor.ml test_loc_modtype_type_eq.ml \ test_loc_modtype_type_subst.ml test_loc_type_eq.ml \ test_loc_type_subst.ml mpr7852.mli" * setup-ocamlc.byte-build-env diff --git a/ocaml/testsuite/tests/typing-unboxed/test.ml b/ocaml/testsuite/tests/typing-unboxed/test.ml index fb1ecb82b6f..850713cf6ae 100644 --- a/ocaml/testsuite/tests/typing-unboxed/test.ml +++ b/ocaml/testsuite/tests/typing-unboxed/test.ml @@ -119,9 +119,33 @@ Error: Signature mismatch: external f : int -> (int [@untagged]) = "f" "f_nat" is not included in external f : int -> int = "f" "f_nat" + The two primitives' results have different representations |}] module Bad2 : sig + external f : int -> int = "f" "f_nat" +end = struct + external f : (int [@untagged]) -> int = "f" "f_nat" +end;; + +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | external f : (int [@untagged]) -> int = "f" "f_nat" +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig external f : (int [@untagged]) -> int = "f" "f_nat" end + is not included in + sig external f : int -> int = "f" "f_nat" end + Values do not match: + external f : (int [@untagged]) -> int = "f" "f_nat" + is not included in + external f : int -> int = "f" "f_nat" + The two primitives' 1st arguments have different representations +|}] + +module Bad3 : sig external f : int -> int = "a" "a_nat" end = struct external f : (int [@untagged]) -> int = "f" "f_nat" @@ -141,9 +165,10 @@ Error: Signature mismatch: external f : (int [@untagged]) -> int = "f" "f_nat" is not included in external f : int -> int = "a" "a_nat" + The names of the primitives are not the same |}] -module Bad3 : sig +module Bad4 : sig external f : float -> float = "f" "f_nat" end = struct external f : float -> (float [@unboxed]) = "f" "f_nat" @@ -163,9 +188,33 @@ Error: Signature mismatch: external f : float -> (float [@unboxed]) = "f" "f_nat" is not included in external f : float -> float = "f" "f_nat" + The two primitives' results have different representations |}] -module Bad4 : sig +module Bad5 : sig + external f : float -> float = "f" "f_nat" +end = struct + external f : (float [@unboxed]) -> float = "f" "f_nat" +end;; + +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | external f : (float [@unboxed]) -> float = "f" "f_nat" +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig external f : (float [@unboxed]) -> float = "f" "f_nat" end + is not included in + sig external f : float -> float = "f" "f_nat" end + Values do not match: + external f : (float [@unboxed]) -> float = "f" "f_nat" + is not included in + external f : float -> float = "f" "f_nat" + The two primitives' 1st arguments have different representations +|}] + +module Bad6 : sig external f : float -> float = "a" "a_nat" end = struct external f : (float [@unboxed]) -> float = "f" "f_nat" @@ -185,11 +234,35 @@ Error: Signature mismatch: external f : (float [@unboxed]) -> float = "f" "f_nat" is not included in external f : float -> float = "a" "a_nat" + The names of the primitives are not the same +|}] + +module Bad7 : sig + external f : int -> int = "f" "f_nat" +end = struct + external f : int -> int = "f" "f_nat" [@@noalloc] +end;; + +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | external f : int -> int = "f" "f_nat" [@@noalloc] +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig external f : int -> int = "f" "f_nat" [@@noalloc] end + is not included in + sig external f : int -> int = "f" "f_nat" end + Values do not match: + external f : int -> int = "f" "f_nat" [@@noalloc] + is not included in + external f : int -> int = "f" "f_nat" + The first primitive is [@@noalloc] but the second is not |}] (* Bad: attributes in the interface but not in the implementation *) -module Bad5 : sig +module Bad8 : sig external f : int -> (int [@untagged]) = "f" "f_nat" end = struct external f : int -> int = "f" "f_nat" @@ -209,9 +282,33 @@ Error: Signature mismatch: external f : int -> int = "f" "f_nat" is not included in external f : int -> (int [@untagged]) = "f" "f_nat" + The two primitives' results have different representations |}] -module Bad6 : sig +module Bad9 : sig + external f : (int [@untagged]) -> int = "f" "f_nat" +end = struct + external f : int -> int = "f" "f_nat" +end;; + +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | external f : int -> int = "f" "f_nat" +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig external f : int -> int = "f" "f_nat" end + is not included in + sig external f : (int [@untagged]) -> int = "f" "f_nat" end + Values do not match: + external f : int -> int = "f" "f_nat" + is not included in + external f : (int [@untagged]) -> int = "f" "f_nat" + The two primitives' 1st arguments have different representations +|}] + +module Bad10 : sig external f : (int [@untagged]) -> int = "f" "f_nat" end = struct external f : int -> int = "a" "a_nat" @@ -231,9 +328,10 @@ Error: Signature mismatch: external f : int -> int = "a" "a_nat" is not included in external f : (int [@untagged]) -> int = "f" "f_nat" + The names of the primitives are not the same |}] -module Bad7 : sig +module Bad11 : sig external f : float -> (float [@unboxed]) = "f" "f_nat" end = struct external f : float -> float = "f" "f_nat" @@ -253,9 +351,33 @@ Error: Signature mismatch: external f : float -> float = "f" "f_nat" is not included in external f : float -> (float [@unboxed]) = "f" "f_nat" + The two primitives' results have different representations |}] -module Bad8 : sig +module Bad12 : sig + external f : (float [@unboxed]) -> float = "f" "f_nat" +end = struct + external f : float -> float = "f" "f_nat" +end;; + +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | external f : float -> float = "f" "f_nat" +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig external f : float -> float = "f" "f_nat" end + is not included in + sig external f : (float [@unboxed]) -> float = "f" "f_nat" end + Values do not match: + external f : float -> float = "f" "f_nat" + is not included in + external f : (float [@unboxed]) -> float = "f" "f_nat" + The two primitives' 1st arguments have different representations +|}] + +module Bad13 : sig external f : (float [@unboxed]) -> float = "f" "f_nat" end = struct external f : float -> float = "a" "a_nat" @@ -275,6 +397,227 @@ Error: Signature mismatch: external f : float -> float = "a" "a_nat" is not included in external f : (float [@unboxed]) -> float = "f" "f_nat" + The names of the primitives are not the same +|}] + +module Bad14 : sig + external f : int -> int = "f" "f_nat" [@@noalloc] +end = struct + external f : int -> int = "f" "f_nat" +end;; + +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | external f : int -> int = "f" "f_nat" +5 | end.. +Error: Signature mismatch: + Modules do not match: + sig external f : int -> int = "f" "f_nat" end + is not included in + sig external f : int -> int = "f" "f_nat" [@@noalloc] end + Values do not match: + external f : int -> int = "f" "f_nat" + is not included in + external f : int -> int = "f" "f_nat" [@@noalloc] + The second primitive is [@@noalloc] but the first is not +|}] + +(* Bad: claiming something is a primitive when it isn't *) + +module Bad15 : sig + external f : int -> int = "f" "f_nat" +end = struct + let f x = x + 1 +end + +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | let f x = x + 1 +5 | end +Error: Signature mismatch: + Modules do not match: + sig val f : int -> int end + is not included in + sig external f : int -> int = "f" "f_nat" end + Values do not match: + val f : int -> int + is not included in + external f : int -> int = "f" "f_nat" + The implementation is not a primitive. +|}] + +(* Good: not claiming something is a primitive when it is *) + +module Good16 : sig + val f : int -> int +end = struct + external f : int -> int = "f" "f_nat" +end +(* The expected error here is that "f" isn't defined -- that means typechecking + succeeded *) + +[%%expect{| +Line 1: +Error: The external function `f' is not available +|}] + +(* Bad: mismatched names and native names *) + +module Bad17 : sig + external f : int -> int = "f" "f_nat" +end = struct + external f : int -> int = "gg" "f_nat" +end + +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | external f : int -> int = "gg" "f_nat" +5 | end +Error: Signature mismatch: + Modules do not match: + sig external f : int -> int = "gg" "f_nat" end + is not included in + sig external f : int -> int = "f" "f_nat" end + Values do not match: + external f : int -> int = "gg" "f_nat" + is not included in + external f : int -> int = "f" "f_nat" + The names of the primitives are not the same +|}] + +module Bad18 : sig + external f : int -> int = "f" "f_nat" +end = struct + external f : int -> int = "f" "gg_nat" +end + +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | external f : int -> int = "f" "gg_nat" +5 | end +Error: Signature mismatch: + Modules do not match: + sig external f : int -> int = "f" "gg_nat" end + is not included in + sig external f : int -> int = "f" "f_nat" end + Values do not match: + external f : int -> int = "f" "gg_nat" + is not included in + external f : int -> int = "f" "f_nat" + The native names of the primitives are not the same +|}] + +module Bad19 : sig + external f : int -> int = "f" "f_nat" +end = struct + external f : int -> int = "gg" "gg_nat" +end + +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | external f : int -> int = "gg" "gg_nat" +5 | end +Error: Signature mismatch: + Modules do not match: + sig external f : int -> int = "gg" "gg_nat" end + is not included in + sig external f : int -> int = "f" "f_nat" end + Values do not match: + external f : int -> int = "gg" "gg_nat" + is not included in + external f : int -> int = "f" "f_nat" + The names of the primitives are not the same +|}] + +(* Bad: mismatched arities *) + +(* NB: The compiler checks primitive arities *syntactically*, based on the + number of arrows it sees. Thus, hiding function types behind type synonyms + will produce an error about the primitive arities not matching, even when the + types agree. *) + +module Bad20 : sig + type int_int := int -> int + external f : int -> int_int = "f" "f_nat" +end = struct + external f : int -> int -> int = "f" "f_nat" +end + +[%%expect{| +Lines 4-6, characters 6-3: +4 | ......struct +5 | external f : int -> int -> int = "f" "f_nat" +6 | end +Error: Signature mismatch: + Modules do not match: + sig external f : int -> int -> int = "f" "f_nat" end + is not included in + sig external f : int -> int -> int = "f" "f_nat" end + Values do not match: + external f : int -> int -> int = "f" "f_nat" + is not included in + external f : int -> int -> int = "f" "f_nat" + The syntactic arities of these primitives were not the same. + (They must have the same number of arrows present in the source.) +|}] + +module Bad21 : sig + external f : int -> int -> int = "f" "f_nat" +end = struct + type int_int = int -> int + external f : int -> int_int = "f" "f_nat" +end + +[%%expect{| +Lines 3-6, characters 6-3: +3 | ......struct +4 | type int_int = int -> int +5 | external f : int -> int_int = "f" "f_nat" +6 | end +Error: Signature mismatch: + Modules do not match: + sig + type int_int = int -> int + external f : int -> int_int = "f" "f_nat" + end + is not included in + sig external f : int -> int -> int = "f" "f_nat" end + Values do not match: + external f : int -> int_int = "f" "f_nat" + is not included in + external f : int -> int -> int = "f" "f_nat" + The syntactic arities of these primitives were not the same. + (They must have the same number of arrows present in the source.) +|}] + +(* This will fail with a *type* error, instead of an arity mismatch *) +module Bad22 : sig + external f : int -> int = "f" "f_nat" +end = struct + external f : int -> int -> int = "f" "f_nat" +end + +[%%expect{| +Lines 3-5, characters 6-3: +3 | ......struct +4 | external f : int -> int -> int = "f" "f_nat" +5 | end +Error: Signature mismatch: + Modules do not match: + sig external f : int -> int -> int = "f" "f_nat" end + is not included in + sig external f : int -> int = "f" "f_nat" end + Values do not match: + external f : int -> int -> int = "f" "f_nat" + is not included in + external f : int -> int = "f" "f_nat" + The type int -> int -> int is not compatible with the type int -> int + Type int -> int is not compatible with type int |}] (* Bad: unboxed or untagged with the wrong type *) diff --git a/ocaml/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml b/ocaml/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml index ef472aec0d6..76990b6b97b 100644 --- a/ocaml/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml +++ b/ocaml/testsuite/tests/typing-warnings/ambiguous_guarded_disjunction.ml @@ -1,5 +1,5 @@ (* TEST - flags = " -w A -strict-sequence " + flags = " -w +A -strict-sequence " * expect *) @@ -28,7 +28,9 @@ Line 2, characters 4-29: 2 | | ((Val x, _) | (_, Val x)) when x < 0 -> () ^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; -variable x may match different arguments. (See manual section 9.5) +variable x appears in different places in different or-pattern alternatives. +Only the first match will be used to evaluate the guard expression. +(See manual section 11.5) val ambiguous_typical_example : expr * expr -> unit = |}] @@ -95,7 +97,9 @@ Line 2, characters 4-43: 2 | | (`B (x, _, Some y) | `B (x, Some y, _)) when y -> ignore x ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; -variable y may match different arguments. (See manual section 9.5) +variable y appears in different places in different or-pattern alternatives. +Only the first match will be used to evaluate the guard expression. +(See manual section 11.5) val ambiguous__y : [> `B of 'a * bool option * bool option ] -> unit = |}] @@ -126,7 +130,9 @@ Line 2, characters 4-43: 2 | | (`B (x, _, Some y) | `B (x, Some y, _)) when x < y -> () ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; -variable y may match different arguments. (See manual section 9.5) +variable y appears in different places in different or-pattern alternatives. +Only the first match will be used to evaluate the guard expression. +(See manual section 11.5) val ambiguous__x_y : [> `B of 'a * 'a option * 'a option ] -> unit = |}] @@ -139,7 +145,9 @@ Line 2, characters 4-43: 2 | | (`B (x, z, Some y) | `B (x, Some y, z)) when x < y || Some x = z -> () ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; -variables y,z may match different arguments. (See manual section 9.5) +variables y, z appear in different places in different or-pattern alternatives. +Only the first match will be used to evaluate the guard expression. +(See manual section 11.5) val ambiguous__x_y_z : [> `B of 'a * 'a option * 'a option ] -> unit = |}] @@ -170,7 +178,9 @@ Line 2, characters 4-40: 2 | | `A (`B (Some x, _) | `B (_, Some x)) when x -> () ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; -variable x may match different arguments. (See manual section 9.5) +variable x appears in different places in different or-pattern alternatives. +Only the first match will be used to evaluate the guard expression. +(See manual section 11.5) val ambiguous__in_depth : [> `A of [> `B of bool option * bool option ] ] -> unit = |}] @@ -201,7 +211,9 @@ Lines 2-3, characters 4-58: 2 | ....`A ((`B (Some x, _) | `B (_, Some x)), 3 | (`C (Some y, Some _, _) | `C (Some y, _, Some _)))................. Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; -variable x may match different arguments. (See manual section 9.5) +variable x appears in different places in different or-pattern alternatives. +Only the first match will be used to evaluate the guard expression. +(See manual section 11.5) val ambiguous__first_orpat : [> `A of [> `B of 'a option * 'a option ] * @@ -219,7 +231,9 @@ Lines 2-3, characters 4-42: 2 | ....`A ((`B (Some x, Some _, _) | `B (Some x, _, Some _)), 3 | (`C (Some y, _) | `C (_, Some y)))................. Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; -variable y may match different arguments. (See manual section 9.5) +variable y appears in different places in different or-pattern alternatives. +Only the first match will be used to evaluate the guard expression. +(See manual section 11.5) val ambiguous__second_orpat : [> `A of [> `B of 'a option * 'b option * 'c option ] * @@ -312,7 +326,9 @@ Lines 2-3, characters 2-17: 2 | ..X (Z x,Y (y,0)) 3 | | X (Z y,Y (x,_)) Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; -variables x,y may match different arguments. (See manual section 9.5) +variables x, y appear in different places in different or-pattern alternatives. +Only the first match will be used to evaluate the guard expression. +(See manual section 11.5) val ambiguous__amoi : amoi -> int = |}] @@ -332,7 +348,9 @@ Lines 2-3, characters 4-24: 2 | ....(module M:S),_,(1,_) 3 | | _,(module M:S),(_,1)................... Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; -variable M may match different arguments. (See manual section 9.5) +variable M appears in different places in different or-pattern alternatives. +Only the first match will be used to evaluate the guard expression. +(See manual section 11.5) val ambiguous__module_variable : (module S) * (module S) * (int * int) -> bool -> int = |}] @@ -379,7 +397,9 @@ Line 2, characters 4-56: 2 | | A (x as z,(0 as y))|A (0 as y as z,x)|B (x,(y as z)) when g x (y+z) -> 1 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; -variables x,y may match different arguments. (See manual section 9.5) +variables x, y appear in different places in different or-pattern alternatives. +Only the first match will be used to evaluate the guard expression. +(See manual section 11.5) val ambiguous_xy_but_not_ambiguous_z : (int -> int -> bool) -> t2 -> int = |}, Principal{| @@ -408,7 +428,9 @@ Line 2, characters 4-56: 2 | | A (x as z,(0 as y))|A (0 as y as z,x)|B (x,(y as z)) when g x (y+z) -> 1 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; -variables x,y may match different arguments. (See manual section 9.5) +variables x, y appear in different places in different or-pattern alternatives. +Only the first match will be used to evaluate the guard expression. +(See manual section 11.5) val ambiguous_xy_but_not_ambiguous_z : (int -> int -> bool) -> t2 -> int = |}] @@ -467,7 +489,9 @@ Line 3, characters 4-29: 3 | | ((Val y, _) | (_, Val y)) when y < 0 -> () ^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; -variable y may match different arguments. (See manual section 9.5) +variable y appears in different places in different or-pattern alternatives. +Only the first match will be used to evaluate the guard expression. +(See manual section 11.5) val guarded_ambiguity : expr * expr -> unit = |}] @@ -496,7 +520,9 @@ Line 4, characters 4-29: 4 | | ((Val x, _) | (_, Val x)) when pred x -> () ^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 57 [ambiguous-var-in-pattern-guard]: Ambiguous or-pattern variables under guard; -variable x may match different arguments. (See manual section 9.5) +variable x appears in different places in different or-pattern alternatives. +Only the first match will be used to evaluate the guard expression. +(See manual section 11.5) val cmp : (a -> bool) -> a alg -> a alg -> unit = |}] diff --git a/ocaml/testsuite/tests/typing-warnings/application.ml b/ocaml/testsuite/tests/typing-warnings/application.ml index 6d7c4aada38..5a62cfe3df7 100644 --- a/ocaml/testsuite/tests/typing-warnings/application.ml +++ b/ocaml/testsuite/tests/typing-warnings/application.ml @@ -1,5 +1,5 @@ (* TEST - flags = " -w A -strict-sequence " + flags = " -w +A -strict-sequence " * expect *) diff --git a/ocaml/testsuite/tests/typing-warnings/coercions.ml b/ocaml/testsuite/tests/typing-warnings/coercions.ml index 0900975c368..9e05bd9f6f4 100644 --- a/ocaml/testsuite/tests/typing-warnings/coercions.ml +++ b/ocaml/testsuite/tests/typing-warnings/coercions.ml @@ -1,5 +1,5 @@ (* TEST - flags = " -w A -strict-sequence " + flags = " -w +A -strict-sequence " * expect *) diff --git a/ocaml/testsuite/tests/typing-warnings/disable_warnings_classes.ml b/ocaml/testsuite/tests/typing-warnings/disable_warnings_classes.ml new file mode 100644 index 00000000000..e8bed2defa8 --- /dev/null +++ b/ocaml/testsuite/tests/typing-warnings/disable_warnings_classes.ml @@ -0,0 +1,152 @@ +(* TEST + flags = " -w +A " + * expect +*) + +class c = object + + val a = + let b = 5 in () + [@@warning "-26"] + + val x = + let y = 5 in () + +end;; +[%%expect {| +Line 8, characters 8-9: +8 | let y = 5 in () + ^ +Warning 26 [unused-var]: unused variable y. +class c : object val a : unit val x : unit end +|}];; + +class c = object + + method a = + let b = 5 in () + [@@warning "-26"] + + method x = + let y = 5 in () + +end;; +[%%expect {| +Line 8, characters 8-9: +8 | let y = 5 in () + ^ +Warning 26 [unused-var]: unused variable y. +class c : object method a : unit method x : unit end +|}];; + +class c = object + + initializer + let b = 5 in () + [@@warning "-26"] + + initializer + let y = 5 in () + +end;; +[%%expect {| +Line 8, characters 8-9: +8 | let y = 5 in () + ^ +Warning 26 [unused-var]: unused variable y. +class c : object end +|}];; + +class c = (object + + val a = + let b = 5 in () + +end [@warning "-26"]) +[%%expect {| +class c : object val a : unit end +|}];; + +class c = object + + val a = + let b = 5 in () + + [@@@warning "-26"] + + val x = + let y = 5 in () + +end;; +[%%expect {| +Line 4, characters 8-9: +4 | let b = 5 in () + ^ +Warning 26 [unused-var]: unused variable b. +class c : object val a : unit val x : unit end +|}];; + +type dep +[@@deprecated "deprecated"] + +class type c = object + + val a : dep + [@@warning "-3"] + + val x : dep + +end;; +[%%expect {| +type dep +Line 9, characters 10-13: +9 | val x : dep + ^^^ +Alert deprecated: dep +deprecated +class type c = object val a : dep val x : dep end +|}];; + +class type c = object + + method a : dep + [@@warning "-3"] + + method x : dep + +end;; +[%%expect {| +Line 6, characters 13-16: +6 | method x : dep + ^^^ +Alert deprecated: dep +deprecated +class type c = object method a : dep method x : dep end +|}];; + +class type c = object [@warning "-3"] + + val a : dep + +end +[%%expect {| +class type c = object val a : dep end +|}];; + +class type c = object + + val a : dep + + [@@@warning "-3"] + + val x : dep + +end;; +[%%expect {| +Line 3, characters 10-13: +3 | val a : dep + ^^^ +Alert deprecated: dep +deprecated +class type c = object val a : dep val x : dep end +|}];; diff --git a/ocaml/testsuite/tests/typing-warnings/exhaustiveness.ml b/ocaml/testsuite/tests/typing-warnings/exhaustiveness.ml index 888034aad7e..db48bf9f747 100644 --- a/ocaml/testsuite/tests/typing-warnings/exhaustiveness.ml +++ b/ocaml/testsuite/tests/typing-warnings/exhaustiveness.ml @@ -1,5 +1,5 @@ (* TEST - flags = " -w A -strict-sequence " + flags = " -w +A -strict-sequence " * expect *) diff --git a/ocaml/testsuite/tests/typing-warnings/open_warnings.ml b/ocaml/testsuite/tests/typing-warnings/open_warnings.ml index 299809516b3..9220e69f001 100644 --- a/ocaml/testsuite/tests/typing-warnings/open_warnings.ml +++ b/ocaml/testsuite/tests/typing-warnings/open_warnings.ml @@ -1,5 +1,5 @@ (* TEST - flags = " -w A-41-42-18" + flags = " -w +A-41-42-18" * expect *) module T1 : sig end = struct diff --git a/ocaml/testsuite/tests/typing-warnings/pr5892.ml b/ocaml/testsuite/tests/typing-warnings/pr5892.ml index 5b318ef40b5..e20e1aeb04e 100644 --- a/ocaml/testsuite/tests/typing-warnings/pr5892.ml +++ b/ocaml/testsuite/tests/typing-warnings/pr5892.ml @@ -1,5 +1,5 @@ (* TEST - flags = " -w A -strict-sequence " + flags = " -w +A -strict-sequence " * expect *) diff --git a/ocaml/testsuite/tests/typing-warnings/pr6587.ml b/ocaml/testsuite/tests/typing-warnings/pr6587.ml index 665f6ed7e3a..36b9044718a 100644 --- a/ocaml/testsuite/tests/typing-warnings/pr6587.ml +++ b/ocaml/testsuite/tests/typing-warnings/pr6587.ml @@ -1,5 +1,5 @@ (* TEST - flags = " -w A -strict-sequence " + flags = " -w +A -strict-sequence " * expect *) @@ -36,4 +36,7 @@ Error: Signature mismatch: val f : fpclass -> Stdlib.fpclass is not included in val f : fpclass -> fpclass + The type fpclass -> Stdlib.fpclass is not compatible with the type + fpclass -> fpclass + Type Stdlib.fpclass is not compatible with type fpclass |}] diff --git a/ocaml/testsuite/tests/typing-warnings/pr6872.ml b/ocaml/testsuite/tests/typing-warnings/pr6872.ml index 3ca374336b1..6d17966c2a7 100644 --- a/ocaml/testsuite/tests/typing-warnings/pr6872.ml +++ b/ocaml/testsuite/tests/typing-warnings/pr6872.ml @@ -1,5 +1,5 @@ (* TEST - flags = " -w A -strict-sequence " + flags = " -w +A -strict-sequence " * expect *) diff --git a/ocaml/testsuite/tests/typing-warnings/pr7085.ml b/ocaml/testsuite/tests/typing-warnings/pr7085.ml index 3516ee4daa3..ee2e421a438 100644 --- a/ocaml/testsuite/tests/typing-warnings/pr7085.ml +++ b/ocaml/testsuite/tests/typing-warnings/pr7085.ml @@ -1,5 +1,5 @@ (* TEST - flags = " -w A -strict-sequence " + flags = " -w +A -strict-sequence " * expect *) diff --git a/ocaml/testsuite/tests/typing-warnings/pr7115.ml b/ocaml/testsuite/tests/typing-warnings/pr7115.ml index 43e06cad528..139e9f362c5 100644 --- a/ocaml/testsuite/tests/typing-warnings/pr7115.ml +++ b/ocaml/testsuite/tests/typing-warnings/pr7115.ml @@ -1,5 +1,5 @@ (* TEST - flags = " -w A -strict-sequence " + flags = " -w +A -strict-sequence " * expect *) diff --git a/ocaml/testsuite/tests/typing-warnings/pr7261.ml b/ocaml/testsuite/tests/typing-warnings/pr7261.ml index ecbbdda2255..65c44ecf176 100644 --- a/ocaml/testsuite/tests/typing-warnings/pr7261.ml +++ b/ocaml/testsuite/tests/typing-warnings/pr7261.ml @@ -1,5 +1,5 @@ (* TEST - flags = " -w A -strict-sequence " + flags = " -w +A -strict-sequence " * toplevel *) diff --git a/ocaml/testsuite/tests/typing-warnings/pr7297.ml b/ocaml/testsuite/tests/typing-warnings/pr7297.ml index 08a2a4be6dc..fba56c934c2 100644 --- a/ocaml/testsuite/tests/typing-warnings/pr7297.ml +++ b/ocaml/testsuite/tests/typing-warnings/pr7297.ml @@ -1,5 +1,5 @@ (* TEST - flags = " -w A -strict-sequence " + flags = " -w +A -strict-sequence " * expect *) diff --git a/ocaml/testsuite/tests/typing-warnings/pr7553.ml b/ocaml/testsuite/tests/typing-warnings/pr7553.ml index a76f19d4aab..24faa0e8cfc 100644 --- a/ocaml/testsuite/tests/typing-warnings/pr7553.ml +++ b/ocaml/testsuite/tests/typing-warnings/pr7553.ml @@ -1,5 +1,5 @@ (* TEST - flags = " -w A -strict-sequence " + flags = " -w +A -strict-sequence " * expect *) diff --git a/ocaml/testsuite/tests/typing-warnings/pr9244.ml b/ocaml/testsuite/tests/typing-warnings/pr9244.ml index 28bf91ff0cd..06dd9e9502b 100644 --- a/ocaml/testsuite/tests/typing-warnings/pr9244.ml +++ b/ocaml/testsuite/tests/typing-warnings/pr9244.ml @@ -1,5 +1,5 @@ (* TEST - flags = " -w A " + flags = " -w +A " * expect *) diff --git a/ocaml/testsuite/tests/typing-warnings/records.ml b/ocaml/testsuite/tests/typing-warnings/records.ml index 73938fc70b2..74b3de84896 100644 --- a/ocaml/testsuite/tests/typing-warnings/records.ml +++ b/ocaml/testsuite/tests/typing-warnings/records.ml @@ -1,5 +1,5 @@ (* TEST - flags = " -w A -strict-sequence " + flags = " -w +A -strict-sequence " * expect *) @@ -324,7 +324,7 @@ Line 4, characters 22-23: 4 | let b : bar = {x=3; y=4} ^ Error: This record expression is expected to have type bar - The field y does not belong to type bar + There is no field y within type bar |}] module M = struct type foo = {x:int;y:int} end;; @@ -404,7 +404,7 @@ Line 3, characters 44-45: 3 | let f r = ignore (r: foo); {r with x = 2; z = 3} ^ Error: This record expression is expected to have type M.foo - The field z does not belong to type M.foo + There is no field z within type M.foo |}] module M = struct include M @@ -432,7 +432,7 @@ Line 3, characters 45-46: 3 | let f r = ignore (r: foo); { r with x = 3; a = 4 } ^ Error: This record expression is expected to have type M.foo - The field a does not belong to type M.foo + There is no field a within type M.foo |}] module F7 = struct open M @@ -454,7 +454,7 @@ Line 4, characters 18-19: 4 | let r: other = {x=1; y=2} ^ Error: This record expression is expected to have type M.other - The field x does not belong to type M.other + There is no field x within type M.other |}] module A = struct type t = {x: int} end @@ -483,7 +483,7 @@ Line 3, characters 19-22: 3 | let a : t = {x=1;yyz=2} ^^^ Error: This record expression is expected to have type t - The field yyz does not belong to type t + There is no field yyz within type t Hint: Did you mean yyy? |}] diff --git a/ocaml/testsuite/tests/typing-warnings/unused_functor_parameter.ml b/ocaml/testsuite/tests/typing-warnings/unused_functor_parameter.ml index 997fca26ed4..30949a0103a 100644 --- a/ocaml/testsuite/tests/typing-warnings/unused_functor_parameter.ml +++ b/ocaml/testsuite/tests/typing-warnings/unused_functor_parameter.ml @@ -1,5 +1,5 @@ (* TEST - flags = " -w A " + flags = " -w +A " * expect *) diff --git a/ocaml/testsuite/tests/typing-warnings/unused_types.ml b/ocaml/testsuite/tests/typing-warnings/unused_types.ml index 3522069f12b..4192df5b79a 100644 --- a/ocaml/testsuite/tests/typing-warnings/unused_types.ml +++ b/ocaml/testsuite/tests/typing-warnings/unused_types.ml @@ -1,5 +1,5 @@ (* TEST - flags = " -w A -strict-sequence " + flags = " -w +A -strict-sequence " * expect *) @@ -345,3 +345,101 @@ Line 3, characters 2-30: Warning 34 [unused-type-declaration]: unused type t. module Unused_constructor_disable_warning : sig end |}] + + +module Unused_record : sig end = struct + type t = { a : int; b : int } + let foo (x : t) = x + let _ = foo +end;; +[%%expect {| +Line 2, characters 13-21: +2 | type t = { a : int; b : int } + ^^^^^^^^ +Warning 69 [unused-field]: unused record field a. +Line 2, characters 22-29: +2 | type t = { a : int; b : int } + ^^^^^^^ +Warning 69 [unused-field]: unused record field b. +module Unused_record : sig end +|}] + +module Unused_field : sig end = struct + type t = { a : int } + let foo () = { a = 0 } + let _ = foo +end;; +[%%expect {| +Line 2, characters 13-20: +2 | type t = { a : int } + ^^^^^^^ +Warning 69 [unused-field]: record field a is never read. +(However, this field is used to build or mutate values.) +module Unused_field : sig end +|}] + +module Unused_field : sig end = struct + type t = { a : int; b : int; c : int } + let foo () = { a = 0; b = 0; c = 0 } + let bar x = x.a + let baz { c; _ } = c + let _ = foo, bar, baz +end;; +[%%expect {| +Line 2, characters 22-30: +2 | type t = { a : int; b : int; c : int } + ^^^^^^^^ +Warning 69 [unused-field]: record field b is never read. +(However, this field is used to build or mutate values.) +module Unused_field : sig end +|}] + +module Unused_mutable_field : sig end = struct + type t = { a : int; mutable b : int } + let foo () = { a = 0; b = 0 } + let bar x = x.a, x.b + let _ = foo, bar +end;; +[%%expect {| +Line 2, characters 22-37: +2 | type t = { a : int; mutable b : int } + ^^^^^^^^^^^^^^^ +Warning 69 [unused-field]: mutable record field b is never mutated. +module Unused_mutable_field : sig end +|}] + +module Unused_field_exported_private : sig + type t = private { a : int } +end = struct + type t = { a : int } +end;; +[%%expect {| +module Unused_field_exported_private : sig type t = private { a : int; } end +|}] + +module Unused_field_exported_private : sig + type t = private { a : int } +end = struct + type t = { a : int } + let foo x = x.a + let _ = foo +end;; +[%%expect {| +module Unused_field_exported_private : sig type t = private { a : int; } end +|}] + +module Unused_mutable_field_exported_private : sig + type t = private { a : int; mutable b : int } +end = struct + type t = { a : int; mutable b : int } + let foo () = { a = 0; b = 0 } + let _ = foo +end;; +[%%expect {| +Line 4, characters 22-37: +4 | type t = { a : int; mutable b : int } + ^^^^^^^^^^^^^^^ +Warning 69 [unused-field]: mutable record field b is never mutated. +module Unused_mutable_field_exported_private : + sig type t = private { a : int; mutable b : int; } end +|}] diff --git a/ocaml/testsuite/tests/unboxed-primitive-args/test.ml b/ocaml/testsuite/tests/unboxed-primitive-args/test.ml index 02a4823976c..49819fac412 100644 --- a/ocaml/testsuite/tests/unboxed-primitive-args/test.ml +++ b/ocaml/testsuite/tests/unboxed-primitive-args/test.ml @@ -1,6 +1,6 @@ (* TEST -files = "common.mli common.ml test_common.c test_common.h" +readonly_files = "common.mli common.ml test_common.c test_common.h" * setup-ocamlopt.opt-build-env ** ocaml diff --git a/ocaml/testsuite/tests/unwind/driver.ml b/ocaml/testsuite/tests/unwind/driver.ml index 38fd7f0647c..07aafc0c97d 100644 --- a/ocaml/testsuite/tests/unwind/driver.ml +++ b/ocaml/testsuite/tests/unwind/driver.ml @@ -1,7 +1,7 @@ (* TEST script = "sh ${test_source_directory}/check-linker-version.sh" -files = "mylib.mli mylib.ml stack_walker.c" +readonly_files = "mylib.mli mylib.ml stack_walker.c" * macos ** arch_amd64 diff --git a/ocaml/testsuite/tests/warnings/deprecated_module.ml b/ocaml/testsuite/tests/warnings/deprecated_module.ml index b6a0121d825..178483d728f 100644 --- a/ocaml/testsuite/tests/warnings/deprecated_module.ml +++ b/ocaml/testsuite/tests/warnings/deprecated_module.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A" +flags = "-w +A" * bytecode diff --git a/ocaml/testsuite/tests/warnings/deprecated_module_assigment.ml b/ocaml/testsuite/tests/warnings/deprecated_module_assigment.ml index 93f0e30580b..c4f9b2b6762 100644 --- a/ocaml/testsuite/tests/warnings/deprecated_module_assigment.ml +++ b/ocaml/testsuite/tests/warnings/deprecated_module_assigment.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A" +flags = "-w +A-70" * bytecode diff --git a/ocaml/testsuite/tests/warnings/deprecated_module_use.ml b/ocaml/testsuite/tests/warnings/deprecated_module_use.ml index adf01474590..ca582ee1f6a 100644 --- a/ocaml/testsuite/tests/warnings/deprecated_module_use.ml +++ b/ocaml/testsuite/tests/warnings/deprecated_module_use.ml @@ -4,12 +4,12 @@ modules = "deprecated_module.mli deprecated_module.ml" * setup-ocamlc.byte-build-env ** ocamlc.byte -flags = "-w a" +flags = "-w -a" module = "deprecated_module.mli" *** ocamlc.byte module = "deprecated_module.ml" **** ocamlc.byte -flags = "-w A" +flags = "-w +A-70" module = "deprecated_module_use.ml" ***** check-ocamlc.byte-output diff --git a/ocaml/testsuite/tests/warnings/deprecated_mutable.compilers.reference b/ocaml/testsuite/tests/warnings/deprecated_mutable.compilers.reference new file mode 100644 index 00000000000..620dc57de9b --- /dev/null +++ b/ocaml/testsuite/tests/warnings/deprecated_mutable.compilers.reference @@ -0,0 +1,4 @@ +File "deprecated_mutable.ml", line 13, characters 11-12: +13 | let () = y.x <- 42 + ^ +Alert deprecated: mutating field x diff --git a/ocaml/testsuite/tests/warnings/deprecated_mutable.ml b/ocaml/testsuite/tests/warnings/deprecated_mutable.ml new file mode 100644 index 00000000000..78fb12ac413 --- /dev/null +++ b/ocaml/testsuite/tests/warnings/deprecated_mutable.ml @@ -0,0 +1,13 @@ +(* TEST + +flags = "-w +A-70" + +* bytecode + +*) + +type t = {mutable x : int [@deprecated_mutable]} + +let y : t = {x = 5} + +let () = y.x <- 42 diff --git a/ocaml/testsuite/tests/warnings/deprecated_warning_specs.ml b/ocaml/testsuite/tests/warnings/deprecated_warning_specs.ml new file mode 100644 index 00000000000..ac41e084c11 --- /dev/null +++ b/ocaml/testsuite/tests/warnings/deprecated_warning_specs.ml @@ -0,0 +1,38 @@ +(* TEST + * expect +*) + +(** Deprecated sequences of unsigned letters *) + +[@@@warning "fragile-math"] +[%%expect {| +Line 3, characters 0-27: +3 | [@@@warning "fragile-math"] + ^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Alert ocaml_deprecated_cli: Setting a warning with a sequence of lowercase or uppercase letters, +like 'ath', is deprecated. +Use the equivalent signed form: -f-r-a-g-i-l-e-m-a-t-h. +Hint: Enabling or disabling a warning by its mnemonic name requires a + or - prefix. +Hint: Did you make a spelling mistake when using a mnemonic name? +|}] + +[@@@warning "ab-cdg+efh"] +[%%expect {| +Line 1, characters 0-25: +1 | [@@@warning "ab-cdg+efh"] + ^^^^^^^^^^^^^^^^^^^^^^^^^ +Alert ocaml_deprecated_cli: Setting a warning with a sequence of lowercase or uppercase letters, +like 'fh', is deprecated. +Use the equivalent signed form: -a-b-c-d-g+e-f-h. +Hint: Enabling or disabling a warning by its mnemonic name requires a + or - prefix. +|}] + + +(** -w "a+10..." and -w "A-10..." are still supported *) +[@@@warning "a+1..20+50"] +[%%expect {| +|}] + +[@@@warning "A-3..14-56"] +[%%expect {| +|}] diff --git a/ocaml/testsuite/tests/warnings/w01.ml b/ocaml/testsuite/tests/warnings/w01.ml index 91782259e65..e72ec1901dc 100644 --- a/ocaml/testsuite/tests/warnings/w01.ml +++ b/ocaml/testsuite/tests/warnings/w01.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A" +flags = "-w +A-70" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/warnings/w03.compilers.reference b/ocaml/testsuite/tests/warnings/w03.compilers.reference index fc79e8cc5de..07f77aaedcf 100644 --- a/ocaml/testsuite/tests/warnings/w03.compilers.reference +++ b/ocaml/testsuite/tests/warnings/w03.compilers.reference @@ -2,7 +2,7 @@ File "w03.ml", line 14, characters 8-9: 14 | let _ = A ^ Alert deprecated: A -File "w03.ml", line 17, characters 12-26: +File "w03.ml", line 17, characters 15-25: 17 | exception B [@@deprecated] - ^^^^^^^^^^^^^^ + ^^^^^^^^^^ Warning 53 [misplaced-attribute]: the "deprecated" attribute cannot appear in this context diff --git a/ocaml/testsuite/tests/warnings/w03.ml b/ocaml/testsuite/tests/warnings/w03.ml index b9f70b1df53..d0a581220a4 100644 --- a/ocaml/testsuite/tests/warnings/w03.ml +++ b/ocaml/testsuite/tests/warnings/w03.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A" +flags = "-w +A-70" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/warnings/w04.ml b/ocaml/testsuite/tests/warnings/w04.ml index dd0fa00ffe5..21a09f52da3 100644 --- a/ocaml/testsuite/tests/warnings/w04.ml +++ b/ocaml/testsuite/tests/warnings/w04.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A" +flags = "-w +A-70" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/warnings/w04_failure.ml b/ocaml/testsuite/tests/warnings/w04_failure.ml index 98a84ff18d3..0ce23ca0ae9 100644 --- a/ocaml/testsuite/tests/warnings/w04_failure.ml +++ b/ocaml/testsuite/tests/warnings/w04_failure.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A" +flags = "-w +A-70" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/warnings/w06.ml b/ocaml/testsuite/tests/warnings/w06.ml index e8c64ffb4b1..dc4e6e6a6ae 100644 --- a/ocaml/testsuite/tests/warnings/w06.ml +++ b/ocaml/testsuite/tests/warnings/w06.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A" +flags = "-w +A-70" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/warnings/w32.ml b/ocaml/testsuite/tests/warnings/w32.ml index cab52568ebc..1a8e7b7a1de 100644 --- a/ocaml/testsuite/tests/warnings/w32.ml +++ b/ocaml/testsuite/tests/warnings/w32.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A" +flags = "-w +A" * setup-ocamlc.byte-build-env ** ocamlc.byte @@ -65,3 +65,7 @@ module F (X : sig val x : int end) = struct end module G (X : sig val x : int end) = X module H (X : sig val x : int end) = X + +module type S = sig + module F: sig val x : int end -> sig end +end diff --git a/ocaml/testsuite/tests/warnings/w32.mli b/ocaml/testsuite/tests/warnings/w32.mli index 8ffe03dd23f..80fb6735ae0 100644 --- a/ocaml/testsuite/tests/warnings/w32.mli +++ b/ocaml/testsuite/tests/warnings/w32.mli @@ -14,3 +14,7 @@ module F (X : sig val x : int end) : sig end module G (X : sig val x : int end) : sig end module H (X : sig val x : int end) : sig val x : int end + +module type S = sig + module F: sig val x : int end -> sig end +end diff --git a/ocaml/testsuite/tests/warnings/w32b.ml b/ocaml/testsuite/tests/warnings/w32b.ml index 7f56659e03b..bcb2fc2588e 100644 --- a/ocaml/testsuite/tests/warnings/w32b.ml +++ b/ocaml/testsuite/tests/warnings/w32b.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A" +flags = "-w +A-70" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/warnings/w33.ml b/ocaml/testsuite/tests/warnings/w33.ml index cff8d9f3609..4c4abfd6667 100644 --- a/ocaml/testsuite/tests/warnings/w33.ml +++ b/ocaml/testsuite/tests/warnings/w33.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A" +flags = "-w +A-70" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/warnings/w45.ml b/ocaml/testsuite/tests/warnings/w45.ml index 3442c745cf1..01af3e796e2 100644 --- a/ocaml/testsuite/tests/warnings/w45.ml +++ b/ocaml/testsuite/tests/warnings/w45.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A" +flags = "-w +A-70" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/warnings/w47_inline.ml b/ocaml/testsuite/tests/warnings/w47_inline.ml index e4b74860112..fcdaedc4750 100644 --- a/ocaml/testsuite/tests/warnings/w47_inline.ml +++ b/ocaml/testsuite/tests/warnings/w47_inline.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A" +flags = "-w +A-70" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/warnings/w50.ml b/ocaml/testsuite/tests/warnings/w50.ml index d0ac351c2ed..b6e868f89ad 100644 --- a/ocaml/testsuite/tests/warnings/w50.ml +++ b/ocaml/testsuite/tests/warnings/w50.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A" +flags = "-w +A-70" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/warnings/w51.ml b/ocaml/testsuite/tests/warnings/w51.ml index 7f89800c0fd..8ab7ec08ca8 100644 --- a/ocaml/testsuite/tests/warnings/w51.ml +++ b/ocaml/testsuite/tests/warnings/w51.ml @@ -1,5 +1,5 @@ (* TEST - flags = "-w A" + flags = "-w +A-70" * expect *) diff --git a/ocaml/testsuite/tests/warnings/w51_bis.ml b/ocaml/testsuite/tests/warnings/w51_bis.ml index 58382556833..bb5bcaac1a6 100644 --- a/ocaml/testsuite/tests/warnings/w51_bis.ml +++ b/ocaml/testsuite/tests/warnings/w51_bis.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A" +flags = "-w +A-70" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/warnings/w52.ml b/ocaml/testsuite/tests/warnings/w52.ml index bf6bd6843d4..85c372460b9 100644 --- a/ocaml/testsuite/tests/warnings/w52.ml +++ b/ocaml/testsuite/tests/warnings/w52.ml @@ -1,5 +1,5 @@ (* TEST - flags = "-w A" + flags = "-w +A" * expect *) @@ -10,7 +10,7 @@ Line 1, characters 38-43: ^^^^^ Warning 52 [fragile-literal-pattern]: Code should not depend on the actual values of this constructor's arguments. They are only for information -and may change in future versions. (See manual section 9.5) +and may change in future versions. (See manual section 11.5) |}];; let () = try () with Match_failure ("Any",_,_) -> ();; @@ -20,7 +20,7 @@ Line 1, characters 35-46: ^^^^^^^^^^^ Warning 52 [fragile-literal-pattern]: Code should not depend on the actual values of this constructor's arguments. They are only for information -and may change in future versions. (See manual section 9.5) +and may change in future versions. (See manual section 11.5) |}];; let () = try () with Match_failure (_,0,_) -> ();; @@ -30,7 +30,7 @@ Line 1, characters 35-42: ^^^^^^^ Warning 52 [fragile-literal-pattern]: Code should not depend on the actual values of this constructor's arguments. They are only for information -and may change in future versions. (See manual section 9.5) +and may change in future versions. (See manual section 11.5) |}];; type t = @@ -55,7 +55,7 @@ Line 2, characters 7-17: ^^^^^^^^^^ Warning 52 [fragile-literal-pattern]: Code should not depend on the actual values of this constructor's arguments. They are only for information -and may change in future versions. (See manual section 9.5) +and may change in future versions. (See manual section 11.5) val f : t -> unit = |}];; @@ -68,7 +68,7 @@ Line 2, characters 8-10: ^^ Warning 52 [fragile-literal-pattern]: Code should not depend on the actual values of this constructor's arguments. They are only for information -and may change in future versions. (See manual section 9.5) +and may change in future versions. (See manual section 11.5) val g : t -> unit = |}];; @@ -95,6 +95,6 @@ Line 2, characters 7-34: ^^^^^^^^^^^^^^^^^^^^^^^^^^^ Warning 52 [fragile-literal-pattern]: Code should not depend on the actual values of this constructor's arguments. They are only for information -and may change in future versions. (See manual section 9.5) +and may change in future versions. (See manual section 11.5) val j : t -> unit = |}];; diff --git a/ocaml/testsuite/tests/warnings/w53.compilers.reference b/ocaml/testsuite/tests/warnings/w53.compilers.reference index 75b910487c2..8559ab4abae 100644 --- a/ocaml/testsuite/tests/warnings/w53.compilers.reference +++ b/ocaml/testsuite/tests/warnings/w53.compilers.reference @@ -1,7 +1,15 @@ +File "w53.ml", line 64, characters 37-46: +64 | let test_ppwarning = 42 [@@ppwarning "warning"] + ^^^^^^^^^ +Warning 22 [preprocessor]: warning File "w53.ml", line 12, characters 4-5: 12 | let h x = x [@inline] (* rejected *) ^ Warning 32 [unused-value-declaration]: unused value h. +File "w53.ml", line 334, characters 2-33: +334 | let x : int64 = 42L [@@noalloc] (* rejected *) + ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "noalloc" attribute cannot appear in this context File "w53.ml", line 12, characters 14-20: 12 | let h x = x [@inline] (* rejected *) ^^^^^^ @@ -34,14 +42,22 @@ File "w53.ml", line 25, characters 16-24: 25 | let q x = h x [@tailcall] (* rejected *) ^^^^^^^^ Warning 53 [misplaced-attribute]: the "tailcall" attribute cannot appear in this context -File "w53.ml", line 33, characters 0-32: +File "w53.ml", line 33, characters 25-31: 33 | module C = struct end [@@inline] (* rejected *) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ + ^^^^^^ Warning 53 [misplaced-attribute]: the "inline" attribute cannot appear in this context -File "w53.ml", line 34, characters 0-39: +File "w53.ml", line 34, characters 26-38: 34 | module C' = struct end [@@ocaml.inline] (* rejected *) - ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ -Warning 53 [misplaced-attribute]: the "inline" attribute cannot appear in this context + ^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "ocaml.inline" attribute cannot appear in this context +File "w53.ml", line 35, characters 25-32: +35 | module D = struct end [@@inlined] (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "inlined" attribute cannot appear in this context +File "w53.ml", line 36, characters 26-39: +36 | module D' = struct end [@@ocaml.inlined] (* rejected *) + ^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "ocaml.inlined" attribute cannot appear in this context File "w53.ml", line 40, characters 16-22: 40 | module G = (A [@inline])(struct end) (* rejected *) ^^^^^^ @@ -66,3 +82,511 @@ File "w53.ml", line 49, characters 24-37: 49 | module J' = Set.Make [@@ocaml.inlined] ^^^^^^^^^^^^^ Warning 53 [misplaced-attribute]: the "ocaml.inlined" attribute cannot appear in this context +File "w53.ml", line 52, characters 17-27: +52 | val a1 : int [@deprecated] (* rejected *) + ^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "deprecated" attribute cannot appear in this context +File "w53.ml", line 57, characters 6-14: +57 | let [@unrolled 42] rec test_unrolled x = (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "unrolled" attribute cannot appear in this context +File "w53.ml", line 69, characters 23-46: +69 | | Lit_pat2 of int [@@warn_on_literal_pattern] (* rejected *) + ^^^^^^^^^^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "warn_on_literal_pattern" attribute cannot appear in this context +File "w53.ml", line 73, characters 14-23: +73 | type t2 [@@@immediate] (* rejected *) + ^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "immediate" attribute cannot appear in this context +File "w53.ml", line 75, characters 14-25: +75 | type t4 [@@@immediate64] (* rejected *) + ^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "immediate64" attribute cannot appear in this context +File "w53.ml", line 79, characters 32-43: +79 | let x = (4 [@immediate], 42 [@immediate64]) (* rejected *) + ^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "immediate64" attribute cannot appear in this context +File "w53.ml", line 79, characters 15-24: +79 | let x = (4 [@immediate], 42 [@immediate64]) (* rejected *) + ^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "immediate" attribute cannot appear in this context +File "w53.ml", line 84, characters 26-31: +84 | type t2 = {x : int} [@@@boxed] (* rejected *) + ^^^^^ +Warning 53 [misplaced-attribute]: the "boxed" attribute cannot appear in this context +File "w53.ml", line 86, characters 26-33: +86 | type t4 = {x : int} [@@@unboxed] (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "unboxed" attribute cannot appear in this context +File "w53.ml", line 87, characters 17-24: +87 | val x : int [@@unboxed] (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "unboxed" attribute cannot appear in this context +File "w53.ml", line 91, characters 30-35: +91 | let x = (5 [@unboxed], 42 [@boxed]) (* rejected *) + ^^^^^ +Warning 53 [misplaced-attribute]: the "boxed" attribute cannot appear in this context +File "w53.ml", line 91, characters 15-22: +91 | let x = (5 [@unboxed], 42 [@boxed]) (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "unboxed" attribute cannot appear in this context +File "w53.ml", line 95, characters 21-30: +95 | type 'a t1 = 'a [@@principal] (* rejected *) + ^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "principal" attribute cannot appear in this context +File "w53.ml", line 96, characters 21-32: +96 | type 'a t2 = 'a [@@noprincipal] (* rejected *) + ^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "noprincipal" attribute cannot appear in this context +File "w53.ml", line 98, characters 19-28: +98 | type s1 = Foo1 [@principal] (* rejected *) + ^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "principal" attribute cannot appear in this context +File "w53.ml", line 99, characters 19-30: +99 | type s2 = Foo2 [@noprincipal] (* rejected *) + ^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "noprincipal" attribute cannot appear in this context +File "w53.ml", line 101, characters 16-25: +101 | val x : int [@principal] (* rejected *) + ^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "principal" attribute cannot appear in this context +File "w53.ml", line 102, characters 16-27: +102 | val y : int [@noprincipal] (* rejected *) + ^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "noprincipal" attribute cannot appear in this context +File "w53.ml", line 109, characters 21-30: +109 | type 'a t1 = 'a [@@principal] (* rejected *) + ^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "principal" attribute cannot appear in this context +File "w53.ml", line 110, characters 21-32: +110 | type 'a t2 = 'a [@@noprincipal] (* rejected *) + ^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "noprincipal" attribute cannot appear in this context +File "w53.ml", line 112, characters 19-28: +112 | type s1 = Foo1 [@principal] (* rejected *) + ^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "principal" attribute cannot appear in this context +File "w53.ml", line 113, characters 19-30: +113 | type s2 = Foo2 [@noprincipal] (* rejected *) + ^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "noprincipal" attribute cannot appear in this context +File "w53.ml", line 115, characters 14-23: +115 | let x = 5 [@principal] (* rejected *) + ^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "principal" attribute cannot appear in this context +File "w53.ml", line 116, characters 15-26: +116 | let y = 42 [@noprincipal] (* rejected *) + ^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "noprincipal" attribute cannot appear in this context +File "w53.ml", line 123, characters 21-29: +123 | type 'a t1 = 'a [@@nolabels] (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "nolabels" attribute cannot appear in this context +File "w53.ml", line 125, characters 19-27: +125 | type s1 = Foo1 [@nolabels] (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "nolabels" attribute cannot appear in this context +File "w53.ml", line 127, characters 16-24: +127 | val x : int [@nolabels] (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "nolabels" attribute cannot appear in this context +File "w53.ml", line 133, characters 21-29: +133 | type 'a t1 = 'a [@@nolabels] (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "nolabels" attribute cannot appear in this context +File "w53.ml", line 135, characters 19-27: +135 | type s1 = Foo1 [@nolabels] (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "nolabels" attribute cannot appear in this context +File "w53.ml", line 137, characters 14-22: +137 | let x = 5 [@nolabels] (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "nolabels" attribute cannot appear in this context +File "w53.ml", line 143, characters 21-31: +143 | type 'a t1 = 'a [@@flambda_o3] (* rejected *) + ^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "flambda_o3" attribute cannot appear in this context +File "w53.ml", line 144, characters 21-37: +144 | type 'a t2 = 'a [@@flambda_oclassic] (* rejected *) + ^^^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "flambda_oclassic" attribute cannot appear in this context +File "w53.ml", line 146, characters 19-29: +146 | type s1 = Foo1 [@flambda_o3] (* rejected *) + ^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "flambda_o3" attribute cannot appear in this context +File "w53.ml", line 147, characters 19-35: +147 | type s2 = Foo2 [@flambda_oclassic] (* rejected *) + ^^^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "flambda_oclassic" attribute cannot appear in this context +File "w53.ml", line 149, characters 16-26: +149 | val x : int [@flambda_o3] (* rejected *) + ^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "flambda_o3" attribute cannot appear in this context +File "w53.ml", line 150, characters 16-32: +150 | val y : int [@flambda_oclassic] (* rejected *) + ^^^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "flambda_oclassic" attribute cannot appear in this context +File "w53.ml", line 152, characters 6-16: +152 | [@@@flambda_o3] (* rejected *) + ^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "flambda_o3" attribute cannot appear in this context +File "w53.ml", line 153, characters 6-22: +153 | [@@@flambda_oclassic] (* rejected *) + ^^^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "flambda_oclassic" attribute cannot appear in this context +File "w53.ml", line 157, characters 21-31: +157 | type 'a t1 = 'a [@@flambda_o3] (* rejected *) + ^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "flambda_o3" attribute cannot appear in this context +File "w53.ml", line 158, characters 21-37: +158 | type 'a t2 = 'a [@@flambda_oclassic] (* rejected *) + ^^^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "flambda_oclassic" attribute cannot appear in this context +File "w53.ml", line 160, characters 19-29: +160 | type s1 = Foo1 [@flambda_o3] (* rejected *) + ^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "flambda_o3" attribute cannot appear in this context +File "w53.ml", line 161, characters 19-35: +161 | type s2 = Foo2 [@flambda_oclassic] (* rejected *) + ^^^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "flambda_oclassic" attribute cannot appear in this context +File "w53.ml", line 163, characters 14-24: +163 | let x = 5 [@flambda_o3] (* rejected *) + ^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "flambda_o3" attribute cannot appear in this context +File "w53.ml", line 164, characters 15-31: +164 | let y = 42 [@flambda_oclassic] (* rejected *) + ^^^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "flambda_oclassic" attribute cannot appear in this context +File "w53.ml", line 171, characters 21-35: +171 | type 'a t1 = 'a [@@afl_inst_ratio 42] (* rejected *) + ^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "afl_inst_ratio" attribute cannot appear in this context +File "w53.ml", line 173, characters 19-33: +173 | type s1 = Foo1 [@afl_inst_ratio 42] (* rejected *) + ^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "afl_inst_ratio" attribute cannot appear in this context +File "w53.ml", line 175, characters 16-30: +175 | val x : int [@afl_inst_ratio 42] (* rejected *) + ^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "afl_inst_ratio" attribute cannot appear in this context +File "w53.ml", line 177, characters 6-20: +177 | [@@@afl_inst_ratio 42] (* rejected *) + ^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "afl_inst_ratio" attribute cannot appear in this context +File "w53.ml", line 181, characters 21-35: +181 | type 'a t1 = 'a [@@afl_inst_ratio 42] (* rejected *) + ^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "afl_inst_ratio" attribute cannot appear in this context +File "w53.ml", line 183, characters 19-33: +183 | type s1 = Foo1 [@afl_inst_ratio 42] (* rejected *) + ^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "afl_inst_ratio" attribute cannot appear in this context +File "w53.ml", line 185, characters 14-28: +185 | let x = 5 [@afl_inst_ratio 42] (* rejected *) + ^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "afl_inst_ratio" attribute cannot appear in this context +File "w53.ml", line 192, characters 21-26: +192 | type 'a t1 = 'a [@@curry 42] (* rejected *) + ^^^^^ +Warning 53 [misplaced-attribute]: the "curry" attribute cannot appear in this context +File "w53.ml", line 194, characters 19-24: +194 | type s1 = Foo1 [@curry 42] (* rejected *) + ^^^^^ +Warning 53 [misplaced-attribute]: the "curry" attribute cannot appear in this context +File "w53.ml", line 196, characters 16-21: +196 | val x : int [@curry 42] (* rejected *) + ^^^^^ +Warning 53 [misplaced-attribute]: the "curry" attribute cannot appear in this context +File "w53.ml", line 198, characters 6-11: +198 | [@@@curry 42] (* rejected *) + ^^^^^ +Warning 53 [misplaced-attribute]: the "curry" attribute cannot appear in this context +File "w53.ml", line 202, characters 21-26: +202 | type 'a t1 = 'a [@@curry 42] (* rejected *) + ^^^^^ +Warning 53 [misplaced-attribute]: the "curry" attribute cannot appear in this context +File "w53.ml", line 204, characters 19-24: +204 | type s1 = Foo1 [@curry 42] (* rejected *) + ^^^^^ +Warning 53 [misplaced-attribute]: the "curry" attribute cannot appear in this context +File "w53.ml", line 206, characters 14-19: +206 | let x = 5 [@curry 42] (* rejected *) + ^^^^^ +Warning 53 [misplaced-attribute]: the "curry" attribute cannot appear in this context +File "w53.ml", line 208, characters 6-11: +208 | [@@@curry 42] (* rejected *) + ^^^^^ +Warning 53 [misplaced-attribute]: the "curry" attribute cannot appear in this context +File "w53.ml", line 213, characters 21-36: +213 | type 'a t1 = 'a [@@include_functor 42] (* rejected *) + ^^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "include_functor" attribute cannot appear in this context +File "w53.ml", line 215, characters 19-34: +215 | type s1 = Foo1 [@include_functor 42] (* rejected *) + ^^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "include_functor" attribute cannot appear in this context +File "w53.ml", line 217, characters 16-31: +217 | val x : int [@include_functor 42] (* rejected *) + ^^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "include_functor" attribute cannot appear in this context +File "w53.ml", line 219, characters 6-21: +219 | [@@@include_functor 42] (* rejected *) + ^^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "include_functor" attribute cannot appear in this context +File "w53.ml", line 223, characters 21-36: +223 | type 'a t1 = 'a [@@include_functor 42] (* rejected *) + ^^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "include_functor" attribute cannot appear in this context +File "w53.ml", line 225, characters 19-34: +225 | type s1 = Foo1 [@include_functor 42] (* rejected *) + ^^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "include_functor" attribute cannot appear in this context +File "w53.ml", line 227, characters 14-29: +227 | let x = 5 [@include_functor 42] (* rejected *) + ^^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "include_functor" attribute cannot appear in this context +File "w53.ml", line 229, characters 6-21: +229 | [@@@include_functor 42] (* rejected *) + ^^^^^^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "include_functor" attribute cannot appear in this context +File "w53.ml", line 233, characters 21-30: +233 | type 'a t1 = 'a [@@local_opt] (* rejected *) + ^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "local_opt" attribute cannot appear in this context +File "w53.ml", line 234, characters 19-28: +234 | type s1 = Foo1 [@local_opt] (* rejected *) + ^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "local_opt" attribute cannot appear in this context +File "w53.ml", line 235, characters 19-28: +235 | val x : int64 [@@local_opt] (* rejected *) + ^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "local_opt" attribute cannot appear in this context +File "w53.ml", line 238, characters 39-48: +238 | external z : int64 -> int64 = "x" [@@local_opt] (* rejected *) + ^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "local_opt" attribute cannot appear in this context +File "w53.ml", line 242, characters 21-30: +242 | type 'a t1 = 'a [@@local_opt] (* rejected *) + ^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "local_opt" attribute cannot appear in this context +File "w53.ml", line 243, characters 19-28: +243 | type s1 = Foo1 [@local_opt] (* rejected *) + ^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "local_opt" attribute cannot appear in this context +File "w53.ml", line 244, characters 25-34: +244 | let x : int64 = 42L [@@local_opt] (* rejected *) + ^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "local_opt" attribute cannot appear in this context +File "w53.ml", line 247, characters 39-48: +247 | external z : int64 -> int64 = "x" [@@local_opt] (* rejected *) + ^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "local_opt" attribute cannot appear in this context +File "w53.ml", line 251, characters 20-25: +251 | type 'a t1 = 'a [@local] (* rejected *) + ^^^^^ +Warning 53 [misplaced-attribute]: the "local" attribute cannot appear in this context +File "w53.ml", line 252, characters 21-27: +252 | type 'a t1' = 'a [@global] (* rejected *) + ^^^^^^ +Warning 53 [misplaced-attribute]: the "global" attribute cannot appear in this context +File "w53.ml", line 253, characters 22-30: +253 | type 'a t1'' = 'a [@nonlocal] (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "nonlocal" attribute cannot appear in this context +File "w53.ml", line 255, characters 24-29: +255 | type t2 = { x : int [@local] } (* rejected *) + ^^^^^ +Warning 53 [misplaced-attribute]: the "local" attribute cannot appear in this context +File "w53.ml", line 259, characters 27-32: +259 | val x : 'a list -> ('a [@local]) list (* rejected *) + ^^^^^ +Warning 53 [misplaced-attribute]: the "local" attribute cannot appear in this context +File "w53.ml", line 260, characters 28-34: +260 | val x' : 'a list -> ('a [@global]) list (* rejected *) + ^^^^^^ +Warning 53 [misplaced-attribute]: the "global" attribute cannot appear in this context +File "w53.ml", line 261, characters 29-37: +261 | val x'' : 'a list -> ('a [@nonlocal]) list (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "nonlocal" attribute cannot appear in this context +File "w53.ml", line 264, characters 33-39: +264 | val y' : 'a -> f:(('a -> 'b) [@global]) -> 'b (* rejected *) + ^^^^^^ +Warning 53 [misplaced-attribute]: the "global" attribute cannot appear in this context +File "w53.ml", line 265, characters 34-42: +265 | val y'' : 'a -> f:(('a -> 'b) [@nonlocal]) -> 'b (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "nonlocal" attribute cannot appear in this context +File "w53.ml", line 267, characters 16-21: +267 | val z : 'a [@@local] (* rejected *) + ^^^^^ +Warning 53 [misplaced-attribute]: the "local" attribute cannot appear in this context +File "w53.ml", line 268, characters 17-23: +268 | val z' : 'a [@@global] (* rejected *) + ^^^^^^ +Warning 53 [misplaced-attribute]: the "global" attribute cannot appear in this context +File "w53.ml", line 269, characters 18-26: +269 | val z'' : 'a [@@nonlocal] (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "nonlocal" attribute cannot appear in this context +File "w53.ml", line 271, characters 17-22: +271 | val w : 'a [@@@local] (* rejected *) + ^^^^^ +Warning 53 [misplaced-attribute]: the "local" attribute cannot appear in this context +File "w53.ml", line 272, characters 18-24: +272 | val w' : 'a [@@@global] (* rejected *) + ^^^^^^ +Warning 53 [misplaced-attribute]: the "global" attribute cannot appear in this context +File "w53.ml", line 273, characters 19-27: +273 | val w'' : 'a [@@@nonlocal] (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "nonlocal" attribute cannot appear in this context +File "w53.ml", line 277, characters 20-25: +277 | type 'a t1 = 'a [@local] (* rejected *) + ^^^^^ +Warning 53 [misplaced-attribute]: the "local" attribute cannot appear in this context +File "w53.ml", line 278, characters 21-27: +278 | type 'a t1' = 'a [@global] (* rejected *) + ^^^^^^ +Warning 53 [misplaced-attribute]: the "global" attribute cannot appear in this context +File "w53.ml", line 279, characters 22-30: +279 | type 'a t1'' = 'a [@nonlocal] (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "nonlocal" attribute cannot appear in this context +File "w53.ml", line 281, characters 24-29: +281 | type t2 = { x : int [@local] } (* rejected *) + ^^^^^ +Warning 53 [misplaced-attribute]: the "local" attribute cannot appear in this context +File "w53.ml", line 286, characters 13-19: +286 | let g (a [@global]) = a (* rejected *) + ^^^^^^ +Warning 53 [misplaced-attribute]: the "global" attribute cannot appear in this context +File "w53.ml", line 287, characters 13-21: +287 | let h (a [@nonlocal]) = a (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "nonlocal" attribute cannot appear in this context +File "w53.ml", line 292, characters 20-24: +292 | type 'a t1 = 'a [@tail] (* rejected *) + ^^^^ +Warning 53 [misplaced-attribute]: the "tail" attribute cannot appear in this context +File "w53.ml", line 293, characters 21-28: +293 | type 'a t1' = 'a [@nontail] (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "nontail" attribute cannot appear in this context +File "w53.ml", line 295, characters 24-28: +295 | type t2 = { x : int [@tail] } (* rejected *) + ^^^^ +Warning 53 [misplaced-attribute]: the "tail" attribute cannot appear in this context +File "w53.ml", line 296, characters 25-32: +296 | type t2' = { x : int [@nontail] } (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "nontail" attribute cannot appear in this context +File "w53.ml", line 298, characters 32-36: +298 | val y : 'a -> f:(('a -> 'b) [@tail]) -> 'b (* rejected *) + ^^^^ +Warning 53 [misplaced-attribute]: the "tail" attribute cannot appear in this context +File "w53.ml", line 299, characters 33-40: +299 | val y' : 'a -> f:(('a -> 'b) [@nontail]) -> 'b (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "nontail" attribute cannot appear in this context +File "w53.ml", line 301, characters 16-20: +301 | val z : 'a [@@tail] (* rejected *) + ^^^^ +Warning 53 [misplaced-attribute]: the "tail" attribute cannot appear in this context +File "w53.ml", line 302, characters 17-24: +302 | val z' : 'a [@@nontail] (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "nontail" attribute cannot appear in this context +File "w53.ml", line 304, characters 6-10: +304 | [@@@tail] (* rejected *) + ^^^^ +Warning 53 [misplaced-attribute]: the "tail" attribute cannot appear in this context +File "w53.ml", line 305, characters 6-13: +305 | [@@@nontail] (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "nontail" attribute cannot appear in this context +File "w53.ml", line 309, characters 13-17: +309 | let f (a [@tail]) = a (* rejected *) + ^^^^ +Warning 53 [misplaced-attribute]: the "tail" attribute cannot appear in this context +File "w53.ml", line 310, characters 14-21: +310 | let f' (a [@nontail]) = a (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "nontail" attribute cannot appear in this context +File "w53.ml", line 312, characters 8-12: +312 | let [@tail] g a = a (* rejected *) + ^^^^ +Warning 53 [misplaced-attribute]: the "tail" attribute cannot appear in this context +File "w53.ml", line 313, characters 8-15: +313 | let [@nontail] g' a = a (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "nontail" attribute cannot appear in this context +File "w53.ml", line 315, characters 16-20: +315 | let h a = a [@tail] (* rejected *) + ^^^^ +Warning 53 [misplaced-attribute]: the "tail" attribute cannot appear in this context +File "w53.ml", line 316, characters 17-24: +316 | let h' a = a [@nontail] (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "nontail" attribute cannot appear in this context +File "w53.ml", line 323, characters 21-28: +323 | type 'a t1 = 'a [@@noalloc] (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "noalloc" attribute cannot appear in this context +File "w53.ml", line 324, characters 19-26: +324 | type s1 = Foo1 [@noalloc] (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "noalloc" attribute cannot appear in this context +File "w53.ml", line 325, characters 19-26: +325 | val x : int64 [@@noalloc] (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "noalloc" attribute cannot appear in this context +File "w53.ml", line 327, characters 24-31: +327 | external y : (int64 [@noalloc]) -> (int64 [@noalloc]) = "x" (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "noalloc" attribute cannot appear in this context +File "w53.ml", line 327, characters 46-53: +327 | external y : (int64 [@noalloc]) -> (int64 [@noalloc]) = "x" (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "noalloc" attribute cannot appear in this context +File "w53.ml", line 332, characters 21-28: +332 | type 'a t1 = 'a [@@noalloc] (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "noalloc" attribute cannot appear in this context +File "w53.ml", line 333, characters 19-26: +333 | type s1 = Foo1 [@noalloc] (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "noalloc" attribute cannot appear in this context +File "w53.ml", line 336, characters 24-31: +336 | external y : (int64 [@noalloc]) -> (int64 [@noalloc]) = "x" (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "noalloc" attribute cannot appear in this context +File "w53.ml", line 336, characters 46-53: +336 | external y : (int64 [@noalloc]) -> (int64 [@noalloc]) = "x" (* rejected *) + ^^^^^^^ +Warning 53 [misplaced-attribute]: the "noalloc" attribute cannot appear in this context +File "w53.ml", line 341, characters 21-29: +341 | type 'a t1 = 'a [@@untagged] (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "untagged" attribute cannot appear in this context +File "w53.ml", line 342, characters 19-27: +342 | type s1 = Foo1 [@untagged] (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "untagged" attribute cannot appear in this context +File "w53.ml", line 343, characters 17-25: +343 | val x : int [@@untagged] (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "untagged" attribute cannot appear in this context +File "w53.ml", line 350, characters 21-29: +350 | type 'a t1 = 'a [@@untagged] (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "untagged" attribute cannot appear in this context +File "w53.ml", line 351, characters 19-27: +351 | type s1 = Foo1 [@untagged] (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "untagged" attribute cannot appear in this context +File "w53.ml", line 352, characters 22-30: +352 | let x : int = 42 [@@untagged] (* rejected *) + ^^^^^^^^ +Warning 53 [misplaced-attribute]: the "untagged" attribute cannot appear in this context diff --git a/ocaml/testsuite/tests/warnings/w53.ml b/ocaml/testsuite/tests/warnings/w53.ml index 2de8a05417a..f19e03e19ff 100644 --- a/ocaml/testsuite/tests/warnings/w53.ml +++ b/ocaml/testsuite/tests/warnings/w53.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A-60" +flags = "-w +A-60-70" * setup-ocamlc.byte-build-env ** ocamlc.byte @@ -47,3 +47,311 @@ module I' = Set.Make [@ocaml.inlined] module J = Set.Make [@@inlined] module J' = Set.Make [@@ocaml.inlined] + +module type K = sig + val a1 : int [@deprecated] (* rejected *) + val a2 : int [@@deprecated] (* accepted *) + [@@@deprecated] (* accepted*) +end + +let [@unrolled 42] rec test_unrolled x = (* rejected *) + match x with + | 0 -> () + | n -> test_unrolled (n - 1) + +let () = (test_unrolled [@unrolled 42]) 10 (* accepted *) + +let test_ppwarning = 42 [@@ppwarning "warning"] + (* accepted (but issues its own warning *) + +type test_literal_pattern = + | Lit_pat1 of int [@warn_on_literal_pattern] (* accepted *) + | Lit_pat2 of int [@@warn_on_literal_pattern] (* rejected *) + +module type TestImmediate = sig + type t1 [@@immediate] (* accepted *) + type t2 [@@@immediate] (* rejected *) + type t3 [@@immediate64] (* accepted *) + type t4 [@@@immediate64] (* rejected *) +end + +module TestImmediate2 = struct + let x = (4 [@immediate], 42 [@immediate64]) (* rejected *) +end + +module type TestBoxed = sig + type t1 = {x : int} [@@boxed] (* accepted *) + type t2 = {x : int} [@@@boxed] (* rejected *) + type t3 = {x : int} [@@unboxed] (* accepted *) + type t4 = {x : int} [@@@unboxed] (* rejected *) + val x : int [@@unboxed] (* rejected *) +end + +module TestBoxed2 = struct + let x = (5 [@unboxed], 42 [@boxed]) (* rejected *) +end + +module type TestPrincipalSig = sig + type 'a t1 = 'a [@@principal] (* rejected *) + type 'a t2 = 'a [@@noprincipal] (* rejected *) + + type s1 = Foo1 [@principal] (* rejected *) + type s2 = Foo2 [@noprincipal] (* rejected *) + + val x : int [@principal] (* rejected *) + val y : int [@noprincipal] (* rejected *) + + [@@@principal] (* accepted *) + [@@@noprincipal] (* accepted *) +end + +module TestPrincipalStruct = struct + type 'a t1 = 'a [@@principal] (* rejected *) + type 'a t2 = 'a [@@noprincipal] (* rejected *) + + type s1 = Foo1 [@principal] (* rejected *) + type s2 = Foo2 [@noprincipal] (* rejected *) + + let x = 5 [@principal] (* rejected *) + let y = 42 [@noprincipal] (* rejected *) + + [@@@principal] (* accepted *) + [@@@noprincipal] (* accepted *) +end + +module type TestNolabelsSig = sig + type 'a t1 = 'a [@@nolabels] (* rejected *) + + type s1 = Foo1 [@nolabels] (* rejected *) + + val x : int [@nolabels] (* rejected *) + + [@@@nolabels] (* accepted *) +end + +module TestNolabelsStruct = struct + type 'a t1 = 'a [@@nolabels] (* rejected *) + + type s1 = Foo1 [@nolabels] (* rejected *) + + let x = 5 [@nolabels] (* rejected *) + + [@@@nolabels] (* accepted *) +end + +module type TestFlambdaSig = sig + type 'a t1 = 'a [@@flambda_o3] (* rejected *) + type 'a t2 = 'a [@@flambda_oclassic] (* rejected *) + + type s1 = Foo1 [@flambda_o3] (* rejected *) + type s2 = Foo2 [@flambda_oclassic] (* rejected *) + + val x : int [@flambda_o3] (* rejected *) + val y : int [@flambda_oclassic] (* rejected *) + + [@@@flambda_o3] (* rejected *) + [@@@flambda_oclassic] (* rejected *) +end + +module TestFlambdaStruct = struct + type 'a t1 = 'a [@@flambda_o3] (* rejected *) + type 'a t2 = 'a [@@flambda_oclassic] (* rejected *) + + type s1 = Foo1 [@flambda_o3] (* rejected *) + type s2 = Foo2 [@flambda_oclassic] (* rejected *) + + let x = 5 [@flambda_o3] (* rejected *) + let y = 42 [@flambda_oclassic] (* rejected *) + + [@@@flambda_o3] (* accepted *) + [@@@flambda_oclassic] (* accepted *) +end + +module type TestAflInstRatioSig = sig + type 'a t1 = 'a [@@afl_inst_ratio 42] (* rejected *) + + type s1 = Foo1 [@afl_inst_ratio 42] (* rejected *) + + val x : int [@afl_inst_ratio 42] (* rejected *) + + [@@@afl_inst_ratio 42] (* rejected *) +end + +module TestAflInstRatioStruct = struct + type 'a t1 = 'a [@@afl_inst_ratio 42] (* rejected *) + + type s1 = Foo1 [@afl_inst_ratio 42] (* rejected *) + + let x = 5 [@afl_inst_ratio 42] (* rejected *) + + [@@@afl_inst_ratio 42] (* accepted *) +end + +(* No "accepted" test for curry because the user shouldn't write it *) +module type TestCurry = sig + type 'a t1 = 'a [@@curry 42] (* rejected *) + + type s1 = Foo1 [@curry 42] (* rejected *) + + val x : int [@curry 42] (* rejected *) + + [@@@curry 42] (* rejected *) +end + +module TestCurryStruct = struct + type 'a t1 = 'a [@@curry 42] (* rejected *) + + type s1 = Foo1 [@curry 42] (* rejected *) + + let x = 5 [@curry 42] (* rejected *) + + [@@@curry 42] (* rejected *) +end + +(* No "accepted" test for include_functor because the user shouldn't write it *) +module type TestIncludeFunctor = sig + type 'a t1 = 'a [@@include_functor 42] (* rejected *) + + type s1 = Foo1 [@include_functor 42] (* rejected *) + + val x : int [@include_functor 42] (* rejected *) + + [@@@include_functor 42] (* rejected *) +end + +module TestIncludeFunctorStruct = struct + type 'a t1 = 'a [@@include_functor 42] (* rejected *) + + type s1 = Foo1 [@include_functor 42] (* rejected *) + + let x = 5 [@include_functor 42] (* rejected *) + + [@@@include_functor 42] (* rejected *) +end + +module type TestLocalOptSig = sig + type 'a t1 = 'a [@@local_opt] (* rejected *) + type s1 = Foo1 [@local_opt] (* rejected *) + val x : int64 [@@local_opt] (* rejected *) + + external y : (int64 [@local_opt]) -> (int64 [@local_opt]) = "x" (* accepted *) + external z : int64 -> int64 = "x" [@@local_opt] (* rejected *) +end + +module TestLocalOptStruct = struct + type 'a t1 = 'a [@@local_opt] (* rejected *) + type s1 = Foo1 [@local_opt] (* rejected *) + let x : int64 = 42L [@@local_opt] (* rejected *) + + external y : (int64 [@local_opt]) -> (int64 [@local_opt]) = "x" (* accepted *) + external z : int64 -> int64 = "x" [@@local_opt] (* rejected *) +end + +module type TestLocalGlobalSig = sig + type 'a t1 = 'a [@local] (* rejected *) + type 'a t1' = 'a [@global] (* rejected *) + type 'a t1'' = 'a [@nonlocal] (* rejected *) + + type t2 = { x : int [@local] } (* rejected *) + type t2' = { x : int [@global] } (* accepted *) + type t2'' = { x : int [@nonlocal] } (* accepted *) + + val x : 'a list -> ('a [@local]) list (* rejected *) + val x' : 'a list -> ('a [@global]) list (* rejected *) + val x'' : 'a list -> ('a [@nonlocal]) list (* rejected *) + + val y : 'a -> f:(('a -> 'b) [@local]) -> 'b (* accepted *) + val y' : 'a -> f:(('a -> 'b) [@global]) -> 'b (* rejected *) + val y'' : 'a -> f:(('a -> 'b) [@nonlocal]) -> 'b (* rejected *) + + val z : 'a [@@local] (* rejected *) + val z' : 'a [@@global] (* rejected *) + val z'' : 'a [@@nonlocal] (* rejected *) + + val w : 'a [@@@local] (* rejected *) + val w' : 'a [@@@global] (* rejected *) + val w'' : 'a [@@@nonlocal] (* rejected *) +end + +module TestLocalGlobalStruct = struct + type 'a t1 = 'a [@local] (* rejected *) + type 'a t1' = 'a [@global] (* rejected *) + type 'a t1'' = 'a [@nonlocal] (* rejected *) + + type t2 = { x : int [@local] } (* rejected *) + type t2' = { x : int [@global] } (* accepted *) + type t2'' = { x : int [@nonlocal] } (* accepted *) + + let f (a [@local]) = a (* accepted *) + let g (a [@global]) = a (* rejected *) + let h (a [@nonlocal]) = a (* rejected *) +end + + +module type TestTail = sig + type 'a t1 = 'a [@tail] (* rejected *) + type 'a t1' = 'a [@nontail] (* rejected *) + + type t2 = { x : int [@tail] } (* rejected *) + type t2' = { x : int [@nontail] } (* rejected *) + + val y : 'a -> f:(('a -> 'b) [@tail]) -> 'b (* rejected *) + val y' : 'a -> f:(('a -> 'b) [@nontail]) -> 'b (* rejected *) + + val z : 'a [@@tail] (* rejected *) + val z' : 'a [@@nontail] (* rejected *) + + [@@@tail] (* rejected *) + [@@@nontail] (* rejected *) +end + +module TestTail = struct + let f (a [@tail]) = a (* rejected *) + let f' (a [@nontail]) = a (* rejected *) + + let [@tail] g a = a (* rejected *) + let [@nontail] g' a = a (* rejected *) + + let h a = a [@tail] (* rejected *) + let h' a = a [@nontail] (* rejected *) + + let rec k x = k x [@tail] (* accepted *) + let rec k' x = k' x [@nontail] (* accepted *) +end + +module type TestNoallocSig = sig + type 'a t1 = 'a [@@noalloc] (* rejected *) + type s1 = Foo1 [@noalloc] (* rejected *) + val x : int64 [@@noalloc] (* rejected *) + + external y : (int64 [@noalloc]) -> (int64 [@noalloc]) = "x" (* rejected *) + external z : int64 -> int64 = "x" [@@noalloc] (* accepted *) +end + +module TestNoallocStruct = struct + type 'a t1 = 'a [@@noalloc] (* rejected *) + type s1 = Foo1 [@noalloc] (* rejected *) + let x : int64 = 42L [@@noalloc] (* rejected *) + + external y : (int64 [@noalloc]) -> (int64 [@noalloc]) = "x" (* rejected *) + external z : int64 -> int64 = "x" [@@noalloc] (* accepted *) +end + +module type TestUntaggedSig = sig + type 'a t1 = 'a [@@untagged] (* rejected *) + type s1 = Foo1 [@untagged] (* rejected *) + val x : int [@@untagged] (* rejected *) + + external y : (int [@untagged]) -> (int [@untagged]) = "x" "y" (* accepted *) + external z : int -> int = "x" "y" [@@untagged] (* accepted *) +end + +module TestUntaggedStruct = struct + type 'a t1 = 'a [@@untagged] (* rejected *) + type s1 = Foo1 [@untagged] (* rejected *) + let x : int = 42 [@@untagged] (* rejected *) + + external y : (int [@untagged]) -> (int [@untagged]) = "x" "y" (* accepted *) + external z : int -> int = "x" "y" [@@untagged] (* accepted *) +end + diff --git a/ocaml/testsuite/tests/warnings/w53_mli.compilers.reference b/ocaml/testsuite/tests/warnings/w53_mli.compilers.reference new file mode 100644 index 00000000000..9fb328f37af --- /dev/null +++ b/ocaml/testsuite/tests/warnings/w53_mli.compilers.reference @@ -0,0 +1,4 @@ +File "w53_mli.mli", line 14, characters 15-25: +14 | val a1 : int [@deprecated] (* rejected *) + ^^^^^^^^^^ +Warning 53 [misplaced-attribute]: the "deprecated" attribute cannot appear in this context diff --git a/ocaml/testsuite/tests/warnings/w53_mli.mli b/ocaml/testsuite/tests/warnings/w53_mli.mli new file mode 100644 index 00000000000..6826e66b58d --- /dev/null +++ b/ocaml/testsuite/tests/warnings/w53_mli.mli @@ -0,0 +1,16 @@ +(* TEST + +flags = "-w +A-60-70" + +* setup-ocamlc.byte-build-env +** ocamlc.byte +compile_only = "true" +*** check-ocamlc.byte-output + +*) + +(* Just ensure that we're running the check on mli files too *) + +val a1 : int [@deprecated] (* rejected *) +val a2 : int [@@deprecated] (* accepted *) + diff --git a/ocaml/testsuite/tests/warnings/w54.ml b/ocaml/testsuite/tests/warnings/w54.ml index 95bd04bd9f3..e9f29cb3e2a 100644 --- a/ocaml/testsuite/tests/warnings/w54.ml +++ b/ocaml/testsuite/tests/warnings/w54.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A" +flags = "-w +A-70" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/warnings/w55.ml b/ocaml/testsuite/tests/warnings/w55.ml index 67fecee7aea..d597d466878 100644 --- a/ocaml/testsuite/tests/warnings/w55.ml +++ b/ocaml/testsuite/tests/warnings/w55.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A" +flags = "-w +A-70" compile_only = "true" * setup-ocamlc.byte-build-env diff --git a/ocaml/testsuite/tests/warnings/w58.ml b/ocaml/testsuite/tests/warnings/w58.ml index 4e59ca5cf91..cb8ab6194ec 100644 --- a/ocaml/testsuite/tests/warnings/w58.ml +++ b/ocaml/testsuite/tests/warnings/w58.ml @@ -1,7 +1,7 @@ (* TEST -flags = "-w A" -files = "module_without_cmx.mli" +flags = "-w +A-70" +readonly_files = "module_without_cmx.mli" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/warnings/w59.ml b/ocaml/testsuite/tests/warnings/w59.ml index 0a6d35291b2..08e7f18f43a 100644 --- a/ocaml/testsuite/tests/warnings/w59.ml +++ b/ocaml/testsuite/tests/warnings/w59.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A" +flags = "-w +A-70" compile_only = "true" * setup-ocamlc.byte-build-env diff --git a/ocaml/testsuite/tests/warnings/w60.ml b/ocaml/testsuite/tests/warnings/w60.ml index 2e59615cca1..aeab53db9d9 100644 --- a/ocaml/testsuite/tests/warnings/w60.ml +++ b/ocaml/testsuite/tests/warnings/w60.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A-67" +flags = "-w +A-67" * setup-ocamlc.byte-build-env ** ocamlc.byte diff --git a/ocaml/testsuite/tests/warnings/w68.ml b/ocaml/testsuite/tests/warnings/w68.ml index e1de6ebc486..71ca09516bd 100644 --- a/ocaml/testsuite/tests/warnings/w68.ml +++ b/ocaml/testsuite/tests/warnings/w68.ml @@ -1,6 +1,6 @@ (* TEST -flags = "-w A" +flags = "-w +A-70" * setup-ocamlopt.byte-build-env ** ocamlopt.byte diff --git a/ocaml/testsuite/tests/win-unicode/mltest.compilers.reference b/ocaml/testsuite/tests/win-unicode/mltest.compilers.reference index 5a17c421419..7912d17c8f3 100644 --- a/ocaml/testsuite/tests/win-unicode/mltest.compilers.reference +++ b/ocaml/testsuite/tests/win-unicode/mltest.compilers.reference @@ -14,7 +14,8 @@ val unix_readdir : string -> string list = val sys_readdir : string -> string list = val test_readdir : (string -> string list) -> string list = val test_open_in : unit -> string list = -val test_getenv : unit -> (string * string) list = +val test_getenv : unit -> ((string * string) * (string * string)) list = + val test_mkdir : unit -> (bool * bool) list = val test_chdir : (string -> unit) -> (unit -> 'a) -> 'a list = val test_rmdir : unit -> bool list = @@ -76,8 +77,11 @@ val t_sys_rename : ((bool * bool) * (bool * bool)) list = val t_sys_chdir : string list = ["été"; "simple"; "sœur"; "你好"] val t_unix_chdir : string list = ["été"; "simple"; "sœur"; "你好"] - : bool list = [false; false; false; false] -val t_getenv : (string * string) list = - [("верблюды", "верблюды"); ("骆驼", "骆驼"); - ("קעמל", "קעמל"); ("اونٹ", "اونٹ")] +val t_getenv : ((string * string) * (string * string)) list = + [(("верблюды", "верблюды"), + ("верблюдыверблюды", "верблюдыверблюды")); + (("骆驼", "骆驼"), ("骆驼骆驼", "骆驼骆驼")); + (("קעמל", "קעמל"), ("קעמלקעמל", "קעמלקעמל")); + (("اونٹ", "اونٹ"), ("اونٹاونٹ", "اونٹاونٹ"))] - : bool = true diff --git a/ocaml/testsuite/tests/win-unicode/mltest.ml b/ocaml/testsuite/tests/win-unicode/mltest.ml index 802cf5042fd..1523e27cfa5 100644 --- a/ocaml/testsuite/tests/win-unicode/mltest.ml +++ b/ocaml/testsuite/tests/win-unicode/mltest.ml @@ -1,6 +1,6 @@ (* TEST include unix -flags += "-strict-sequence -safe-string -w A -warn-error A" +flags += "-strict-sequence -safe-string -w +A -warn-error +A" * windows-unicode ** toplevel *) @@ -144,9 +144,18 @@ let test_open_in () = ;; let test_getenv () = + let equiv l r = + assert (l = r); + l, r + in let doit key s = Unix.putenv key s; - Sys.getenv key, getenvironmentenv key + let l = equiv (Sys.getenv key) (getenvironmentenv key) in + let r = + Unix.putenv key (s ^ s); + equiv (Sys.getenv key) (getenvironmentenv key) + in + l, r in List.map2 doit foreign_names foreign_names2 ;; diff --git a/ocaml/testsuite/tools/Makefile b/ocaml/testsuite/tools/Makefile index a34116dbc0b..5da3aed3107 100644 --- a/ocaml/testsuite/tools/Makefile +++ b/ocaml/testsuite/tools/Makefile @@ -14,25 +14,30 @@ .NOTPARALLEL: -TOPDIR = ../.. +ROOTDIR = ../.. -COMPILERLIBSDIR = $(TOPDIR)/compilerlibs +COMPILERLIBSDIR = $(ROOTDIR)/compilerlibs RUNTIME_VARIANT ?= ASPPFLAGS ?= -include $(TOPDIR)/Makefile.tools +include $(ROOTDIR)/Makefile.common +include $(ROOTDIR)/Makefile.best_binaries + +STDLIBFLAGS = -nostdlib -I $(ROOTDIR)/stdlib +OCAMLC ?= $(BEST_OCAMLC) $(STDLIBFLAGS) +OCAMLOPT ?= $(BEST_OCAMLOPT) $(STDLIBFLAGS) expect_MAIN=expect_test expect_PROG=$(expect_MAIN)$(EXE) expect_DIRS = parsing utils driver typing toplevel -expect_OCAMLFLAGS = $(addprefix -I $(TOPDIR)/,$(expect_DIRS)) +expect_OCAMLFLAGS = $(addprefix -I $(ROOTDIR)/,$(expect_DIRS)) expect_LIBS := $(addprefix $(COMPILERLIBSDIR)/,\ ocamlcommon ocamlbytecomp ocamltoplevel) codegen_PROG = codegen$(EXE) codegen_DIRS = parsing utils typing middle_end bytecomp lambda asmcomp -codegen_OCAMLFLAGS = $(addprefix -I $(TOPDIR)/, $(codegen_DIRS)) -w +40 -g +codegen_OCAMLFLAGS = $(addprefix -I $(ROOTDIR)/, $(codegen_DIRS)) -w +40 -g codegen_LIBS = $(addprefix $(COMPILERLIBSDIR)/,\ ocamlcommon ocamloptcomp) @@ -63,13 +68,7 @@ $(codegen_PROG): COMPFLAGS = $(codegen_OCAMLFLAGS) codegen_main.cmo: parsecmm.cmo $(codegen_PROG): $(codegen_OBJECTS) - $(OCAMLC) -o $@ $(codegen_LIBS:=.cma) $^ - -parsecmm.mli parsecmm.ml: parsecmm.mly - $(OCAMLYACC) -q parsecmm.mly - -lexcmm.ml: lexcmm.mll - $(OCAMLLEX) -q lexcmm.mll + $(OCAMLC) -o $@ $(COMPFLAGS) $(codegen_LIBS:=.cma) $^ parsecmmaux.cmo: parsecmmaux.cmi @@ -82,13 +81,13 @@ asmgen_i386.obj: asmgen_i386nt.asm $(ASM) $@ $^ | tail -n +2 %.cmi: %.mli - $(OCAMLC) -c $< + $(OCAMLC) $(COMPFLAGS) -c $< %.cmo: %.ml - $(OCAMLC) -c $< + $(OCAMLC) $(COMPFLAGS) -c $< %.cmx: %.ml - $(OCAMLOPT) -c $< + $(OCAMLOPT) $(COMPFLAGS) -c $< %.$(O): %.S $(ASPP) $(ASPPFLAGS) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) -o $@ $< diff --git a/ocaml/testsuite/tools/expect_test.ml b/ocaml/testsuite/tools/expect_test.ml index fed821fc5a1..386397b6e83 100644 --- a/ocaml/testsuite/tools/expect_test.ml +++ b/ocaml/testsuite/tools/expect_test.ml @@ -139,19 +139,19 @@ let collect_formatters buf pps ~f = let ppb = Format.formatter_of_buffer buf in let out_functions = Format.pp_get_formatter_out_functions ppb () in - List.iter (fun pp -> Format.pp_print_flush pp ()) pps; + List.iter ~f:(fun pp -> Format.pp_print_flush pp ()) pps; let save = - List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps + List.map ~f:(fun pp -> Format.pp_get_formatter_out_functions pp ()) pps in let restore () = List.iter2 - (fun pp out_functions -> + ~f:(fun pp out_functions -> Format.pp_print_flush pp (); Format.pp_set_formatter_out_functions pp out_functions) pps save in List.iter - (fun pp -> Format.pp_set_formatter_out_functions pp out_functions) + ~f:(fun pp -> Format.pp_set_formatter_out_functions pp out_functions) pps; match f () with | x -> restore (); x @@ -234,7 +234,7 @@ let eval_expect_file _fname ~file_contents = acc && let snap = Btype.snapshot () in try - exec_phrase ppf phrase + Sys.with_async_exns (fun () -> exec_phrase ppf phrase) with exn -> let bt = Printexc.get_raw_backtrace () in begin try Location.report_exception ppf exn @@ -336,7 +336,8 @@ let main fname = end; Compmisc.init_path (); Toploop.initialize_toplevel_env (); - Sys.interactive := false; + (* We are in interactive mode and should record directive error on stdout *) + Sys.interactive := true; process_expect_file fname; exit 0 diff --git a/ocaml/testsuite/tools/parsecmm.mly b/ocaml/testsuite/tools/parsecmm.mly index baa0c0b1f41..9ebf9ef6ce9 100644 --- a/ocaml/testsuite/tools/parsecmm.mly +++ b/ocaml/testsuite/tools/parsecmm.mly @@ -43,7 +43,7 @@ let make_switch n selector caselist = List.iter (fun pos -> index.(pos) <- i) posl; actv.(i) <- (e, dbg) done; - Cswitch(selector, index, actv, dbg) + Cswitch(selector, index, actv, dbg, value_kind ()) let access_array base numelt size = match numelt with @@ -180,6 +180,7 @@ fundecl: No_CSE; ] else [ Reduce_code_size ]; + fun_poll = Lambda.Default_poll; fun_dbg = debuginfo ()} } ; fun_name: @@ -227,7 +228,8 @@ expr: | LPAREN binaryop expr expr RPAREN { Cop($2, [$3; $4], debuginfo ()) } | LPAREN SEQ sequence RPAREN { $3 } | LPAREN IF expr expr expr RPAREN - { Cifthenelse($3, debuginfo (), $4, debuginfo (), $5, debuginfo ()) } + { Cifthenelse($3, debuginfo (), $4, debuginfo (), $5, debuginfo (), + value_kind ()) } | LPAREN SWITCH INTCONST expr caselist RPAREN { make_switch $3 $4 $5 } | LPAREN WHILE expr sequence RPAREN { @@ -238,21 +240,21 @@ expr: Cconst_int (x, _) when x <> 0 -> $4 | _ -> Cifthenelse($3, debuginfo (), $4, debuginfo (), (Cexit(lbl0,[])), - debuginfo ()) in + debuginfo (), value_kind ()) in Ccatch(Nonrecursive, [lbl0, [], Ctuple [], debuginfo ()], Ccatch(Recursive, [lbl1, [], Csequence(body, Cexit(lbl1, [])), debuginfo ()], - Cexit(lbl1, []))) } + Cexit(lbl1, []), value_kind ()), value_kind ()) } | LPAREN EXIT IDENT exprlist RPAREN { Cexit(find_label $3, List.rev $4) } | LPAREN CATCH sequence WITH catch_handlers RPAREN { let handlers = $5 in List.iter (fun (_, l, _, _) -> List.iter (fun (x, _) -> unbind_ident x) l) handlers; - Ccatch(Recursive, handlers, $3) } + Ccatch(Recursive, handlers, $3, value_kind ()) } | EXIT { Cexit(0,[]) } | LPAREN TRY sequence WITH bind_ident sequence RPAREN - { unbind_ident $5; Ctrywith($3, $5, $6, debuginfo ()) } + { unbind_ident $5; Ctrywith($3, $5, $6, debuginfo (), value_kind ()) } | LPAREN VAL expr expr RPAREN { let open Asttypes in Cop(Cload (Word_val, Mutable), [access_array $3 $4 Arch.size_addr], @@ -276,7 +278,8 @@ expr: { Cop(Cstore (Word_int, Assignment), [access_array $3 $4 Arch.size_int; $5], Debuginfo.none) } | LPAREN FLOATASET expr expr expr RPAREN - { Cop(Cstore (Double, Assignment), + { let open Lambda in + Cop(Cstore (Double, Assignment), [access_array $3 $4 Arch.size_float; $5], Debuginfo.none) } ; exprlist: diff --git a/ocaml/testsuite/tools/parsecmmaux.ml b/ocaml/testsuite/tools/parsecmmaux.ml index af7aaea25be..5a19ddc9d5a 100644 --- a/ocaml/testsuite/tools/parsecmmaux.ml +++ b/ocaml/testsuite/tools/parsecmmaux.ml @@ -60,3 +60,11 @@ let debuginfo ?(loc=Location.symbol_rloc ()) () = ~scopes:Scoped_location.empty_scopes loc ) ) + +let value_kind () = + (* CR-someday poechsel: As the value_kind is only used when building cmm + for the first time, its precise value is not important afterward. + For now we can say that the cmm code read by parsecmm will only contain + Pgenval and it should make no difference, but this should probably be + fixed. *) + Cmm.Vval Lambda.Pgenval diff --git a/ocaml/testsuite/tools/parsecmmaux.mli b/ocaml/testsuite/tools/parsecmmaux.mli index a6728b494b9..f4f85208b8d 100644 --- a/ocaml/testsuite/tools/parsecmmaux.mli +++ b/ocaml/testsuite/tools/parsecmmaux.mli @@ -29,3 +29,5 @@ type error = exception Error of error val report_error: error -> unit + +val value_kind : unit -> Cmm.value_kind diff --git a/ocaml/tools/.depend b/ocaml/tools/.depend index a8a34a8c45b..dadf6aeb47d 100644 --- a/ocaml/tools/.depend +++ b/ocaml/tools/.depend @@ -30,6 +30,14 @@ cmpbyt.cmx : \ ../bytecomp/bytesections.cmx cvt_emit.cmo : cvt_emit.cmx : +debug_printers.cmo : \ + ../typing/printtyp.cmi \ + ../typing/path.cmi \ + ../typing/ident.cmi +debug_printers.cmx : \ + ../typing/printtyp.cmx \ + ../typing/path.cmx \ + ../typing/ident.cmx dumpobj.cmo : \ ../bytecomp/symtable.cmi \ opnames.cmo \ @@ -87,9 +95,11 @@ make_opcodes.cmx : objinfo.cmo : \ ../bytecomp/symtable.cmi \ ../utils/symbol.cmi \ + ../typing/shape.cmi \ ../middle_end/printclambda.cmi \ ../utils/misc.cmi \ ../lambda/lambda.cmi \ + ../utils/import_info.cmi \ ../typing/ident.cmi \ ../middle_end/flambda/export_info.cmi \ ../utils/compilation_unit.cmi \ @@ -103,9 +113,11 @@ objinfo.cmo : \ objinfo.cmx : \ ../bytecomp/symtable.cmx \ ../utils/symbol.cmx \ + ../typing/shape.cmx \ ../middle_end/printclambda.cmx \ ../utils/misc.cmx \ ../lambda/lambda.cmx \ + ../utils/import_info.cmx \ ../typing/ident.cmx \ ../middle_end/flambda/export_info.cmx \ ../utils/compilation_unit.cmx \ @@ -124,6 +136,7 @@ ocamlcmt.cmo : \ ../utils/load_path.cmi \ ../typing/envaux.cmi \ ../driver/compmisc.cmi \ + ../utils/compilation_unit.cmi \ ../file_formats/cmt_format.cmi \ ../typing/cmt2annot.cmo \ ../utils/clflags.cmi \ @@ -136,6 +149,7 @@ ocamlcmt.cmx : \ ../utils/load_path.cmx \ ../typing/envaux.cmx \ ../driver/compmisc.cmx \ + ../utils/compilation_unit.cmx \ ../file_formats/cmt_format.cmx \ ../typing/cmt2annot.cmx \ ../utils/clflags.cmx \ @@ -151,15 +165,11 @@ ocamldep.cmo : \ ocamldep.cmx : \ ../driver/makedepend.cmx ocamlmklib.cmo : \ - ocamlmklibconfig.cmo \ ../utils/misc.cmi \ ../utils/config.cmi ocamlmklib.cmx : \ - ocamlmklibconfig.cmx \ ../utils/misc.cmx \ ../utils/config.cmx -ocamlmklibconfig.cmo : -ocamlmklibconfig.cmx : ocamlmktop.cmo : \ ../utils/config.cmi \ ../utils/ccomp.cmi diff --git a/ocaml/tools/Makefile b/ocaml/tools/Makefile index cd2be26541b..c44b265848f 100644 --- a/ocaml/tools/Makefile +++ b/ocaml/tools/Makefile @@ -13,16 +13,17 @@ #* * #************************************************************************** -MAKEFLAGS := -r -R ROOTDIR = .. - +# NOTE: it is important that OCAMLLEX is defined *before* Makefile.common +# gets included, so that its definition here takes precedence +# over the one there. +OCAMLLEX ?= $(BOOT_OCAMLLEX) include $(ROOTDIR)/Makefile.common -DESTDIR ?= # Setup GNU make variables storing per-target source and target, # a list of installed tools, and a function to quote a filename for # the shell. -override installed_tools := ocamldep ocamlprof ocamlcp ocamloptp \ +installed_tools := ocamldep ocamlprof ocamlcp ocamloptp \ ocamlmktop ocamlmklib ocamlobjinfo install_files := @@ -30,96 +31,81 @@ define byte2native $(patsubst %.cmo,%.cmx,$(patsubst %.cma,%.cmxa,$1)) endef -# $1 = target, $2 = OCaml object dependencies, $3 = other dependencies -# There is a lot of subtle code here. The multiple layers of expansion -# are due to `make`'s eval() function, which evaluates the string -# passed to it as a makefile fragment. So it is crucial that variables -# not get expanded too many times. -define byte_and_opt_ -# This check is defensive programming -$(and $(filter-out 1,$(words $1)),$(error \ - cannot build file with whitespace in name)) -$(call PROGRAM_SYNONYM, $1) - -$1$(EXE): $3 $2 - $$(CAMLC) $$(LINKFLAGS) -I $$(ROOTDIR) -o $$@ $2 - -$(call PROGRAM_SYNONYM, $1.opt) - -$1.opt$(EXE): $3 $$(call byte2native,$2) - $$(CAMLOPT_CMD) $$(LINKFLAGS) -I $$(ROOTDIR) -o $$@ \ - $$(call byte2native,$2) - -all: $1 - -opt.opt: $1.opt - -ifeq '$(filter $(installed_tools),$1)' '$1' -install_files += $1 -endif -clean:: - rm -f -- $1 $1.opt $1.exe $1.opt.exe - -endef - -# Escape any $ characters in the arguments and eval the result. -define byte_and_opt -$(eval $(call \ - byte_and_opt_,$(subst $$,$$$$,$1),$(subst $$,$$$$,$2),$(subst $$,$$$$,$3))) -endef - CAMLC = $(BOOT_OCAMLC) -g -nostdlib -I $(ROOTDIR)/boot \ -use-prims $(ROOTDIR)/runtime/primitives -I $(ROOTDIR) -CAMLOPT = $(CAMLRUN) $(ROOTDIR)/ocamlopt$(EXE) -g -nostdlib -I $(ROOTDIR)/stdlib -CAMLLEX = $(CAMLRUN) $(ROOTDIR)/boot/ocamllex +CAMLOPT = $(OCAMLRUN) $(ROOTDIR)/ocamlopt$(EXE) \ + -g -nostdlib -I $(ROOTDIR)/stdlib INCLUDES = $(addprefix -I $(ROOTDIR)/,utils parsing typing bytecomp \ middle_end middle_end/closure middle_end/flambda \ middle_end/flambda/base_types driver toplevel \ file_formats lambda) -COMPFLAGS = -absname -w +a-4-9-41-42-44-45-48 -strict-sequence -warn-error A \ - -principal -safe-string -strict-formats -bin-annot $(INCLUDES) +COMPFLAGS = -absname -w +a-4-9-41-42-44-45-48-70 -strict-sequence \ +-warn-error +A -principal -safe-string -strict-formats -bin-annot $(INCLUDES) LINKFLAGS = $(INCLUDES) VPATH := $(filter-out -I,$(INCLUDES)) +programs_byte := \ + ocamldep ocamlprof ocamlcp ocamloptp ocamlmklib \ + ocamlmktop ocamlcmt dumpobj ocamlobjinfo \ + primreq stripdebug cmpbyt +install_files += $(filter $(installed_tools), $(programs_byte)) +programs_opt := $(programs_byte:%=%.opt) + .PHONY: all allopt opt.opt # allopt and opt.opt are synonyms +all: $(programs_byte) +opt.opt: $(programs_opt) allopt: opt.opt +$(foreach program, $(programs_byte) $(programs_opt),\ + $(eval $(call PROGRAM_SYNONYM,$(program)))) + +$(programs_byte:%=%$(EXE)): + $(CAMLC) $(LINKFLAGS) -I $(ROOTDIR) -o $@ $(filter-out %.cmi,$^) + +$(programs_opt:%=%$(EXE)): + $(CAMLOPT_CMD) $(LINKFLAGS) -I $(ROOTDIR) -o $@ $(filter-out %.cmi,$^) + +clean:: + rm -f $(programs_byte) $(programs_byte:%=%.exe) + rm -f $(programs_opt) $(programs_opt:%=%.exe) + # The dependency generator -CAMLDEP_OBJ=ocamldep.cmo -CAMLDEP_IMPORTS= \ +OCAMLDEP = \ $(ROOTDIR)/compilerlibs/ocamlcommon.cma \ - $(ROOTDIR)/compilerlibs/ocamlbytecomp.cma -ocamldep$(EXE): LINKFLAGS += -compat-32 -$(call byte_and_opt,ocamldep,$(CAMLDEP_IMPORTS) $(CAMLDEP_OBJ),) -ocamldep$(EXE): depend.cmi -ocamldep.opt$(EXE): depend.cmi + $(ROOTDIR)/compilerlibs/ocamlbytecomp.cma \ + ocamldep.cmo depend.cmi -clean:: - rm -f ocamldep ocamldep.exe ocamldep.opt ocamldep.opt.exe +ocamldep$(EXE): LINKFLAGS += -compat-32 +ocamldep$(EXE): $(OCAMLDEP) +ocamldep.opt$(EXE): $(call byte2native, $(OCAMLDEP)) # The profiler -CSLPROF=ocamlprof.cmo -CSLPROF_IMPORTS=config.cmo build_path_prefix_map.cmo misc.cmo identifiable.cmo \ - numbers.cmo arg_helper.cmo clflags.cmo terminfo.cmo \ - warnings.cmo location.cmo longident.cmo docstrings.cmo \ +OCAMLPROF=config.cmo build_path_prefix_map.cmo misc.cmo identifiable.cmo \ + numbers.cmo arg_helper.cmo local_store.cmo load_path.cmo clflags.cmo \ + terminfo.cmo warnings.cmo location.cmo longident.cmo docstrings.cmo \ syntaxerr.cmo ast_helper.cmo \ - extensions.cmo \ + extensions.cmo builtin_attributes.cmo \ camlinternalMenhirLib.cmo parser.cmo \ pprintast.cmo \ - lexer.cmo parse.cmo + lexer.cmo parse.cmo ocamlprof.cmo -$(call byte_and_opt,ocamlprof,$(CSLPROF_IMPORTS) profiling.cmo $(CSLPROF),) +ocamlprof$(EXE): $(OCAMLPROF) +ocamlprof.opt$(EXE): $(call byte2native, $(OCAMLPROF)) +all: profiling.cmo +opt.opt: profiling.cmx -ocamlcp_cmos = config.cmo build_path_prefix_map.cmo misc.cmo profile.cmo \ - warnings.cmo identifiable.cmo numbers.cmo arg_helper.cmo \ - clflags.cmo local_store.cmo \ - terminfo.cmo location.cmo load_path.cmo ccomp.cmo compenv.cmo \ - main_args.cmo +OCAMLCP = config.cmo build_path_prefix_map.cmo misc.cmo profile.cmo \ + warnings.cmo identifiable.cmo numbers.cmo arg_helper.cmo \ + local_store.cmo load_path.cmo clflags.cmo \ + terminfo.cmo location.cmo ccomp.cmo compenv.cmo \ + main_args.cmo ocamlcp_common.cmo -$(call byte_and_opt,ocamlcp,$(ocamlcp_cmos) ocamlcp.cmo,) -$(call byte_and_opt,ocamloptp,$(ocamlcp_cmos) ocamloptp.cmo,) +ocamlcp$(EXE): $(OCAMLCP) ocamlcp.cmo +ocamlcp.opt$(EXE): $(call byte2native, $(OCAMLCP) ocamlcp.cmo) +ocamloptp$(EXE): $(OCAMLCP) ocamloptp.cmo +ocamloptp.opt$(EXE): $(call byte2native, $(OCAMLCP) ocamloptp.cmo) opt:: profiling.cmx @@ -139,32 +125,19 @@ installopt:: "$(INSTALL_LIBDIR)" # To help building mixed-mode libraries (OCaml + C) +OCAMLMKLIB = config.cmo build_path_prefix_map.cmo misc.cmo ocamlmklib.cmo -$(call byte_and_opt,ocamlmklib,ocamlmklibconfig.cmo config.cmo \ - build_path_prefix_map.cmo misc.cmo ocamlmklib.cmo,) - - -ocamlmklibconfig.ml: $(ROOTDIR)/Makefile.config Makefile - (echo 'let bindir = "$(BINDIR)"'; \ - echo 'let supports_shared_libraries = $(SUPPORTS_SHARED_LIBRARIES)';\ - echo 'let default_rpath = "$(RPATH)"'; \ - echo 'let mksharedlibrpath = "$(MKSHAREDLIBRPATH)"'; \ - echo 'let toolpref = "$(TOOLPREF)"';) \ - > ocamlmklibconfig.ml - -beforedepend:: ocamlmklibconfig.ml - -clean:: - rm -f ocamlmklibconfig.ml +ocamlmklib$(EXE): $(OCAMLMKLIB) +ocamlmklib.opt$(EXE): $(call byte2native, $(OCAMLMKLIB)) # To make custom toplevels -OCAMLMKTOP=ocamlmktop.cmo -OCAMLMKTOP_IMPORTS=config.cmo build_path_prefix_map.cmo misc.cmo \ - identifiable.cmo numbers.cmo arg_helper.cmo clflags.cmo \ - local_store.cmo load_path.cmo profile.cmo ccomp.cmo +OCAMLMKTOP=config.cmo build_path_prefix_map.cmo misc.cmo \ + identifiable.cmo numbers.cmo arg_helper.cmo local_store.cmo \ + load_path.cmo clflags.cmo profile.cmo ccomp.cmo ocamlmktop.cmo -$(call byte_and_opt,ocamlmktop,$(OCAMLMKTOP_IMPORTS) $(OCAMLMKTOP),) +ocamlmktop$(EXE): $(OCAMLMKTOP) +ocamlmktop.opt$(EXE): $(call byte2native, $(OCAMLMKTOP)) # Converter olabl/ocaml 2.99 to ocaml 3 @@ -214,14 +187,13 @@ beforedepend:: cvt_emit.ml # Reading cmt files -ocamlcmt_objects= \ +OCAMLCMT = \ $(ROOTDIR)/compilerlibs/ocamlcommon.cma \ $(ROOTDIR)/compilerlibs/ocamlbytecomp.cma \ - \ ocamlcmt.cmo -# Reading cmt files -$(call byte_and_opt,ocamlcmt,$(ocamlcmt_objects),) +ocamlcmt$(EXE): $(OCAMLCMT) +ocamlcmt.opt$(EXE): $(call byte2native, $(OCAMLCMT)) install:: if test -f ocamlcmt.opt$(EXE); then \ @@ -236,10 +208,10 @@ install:: DUMPOBJ= \ $(ROOTDIR)/compilerlibs/ocamlcommon.cma \ $(ROOTDIR)/compilerlibs/ocamlbytecomp.cma \ - \ opnames.cmo dumpobj.cmo -$(call byte_and_opt,dumpobj,$(DUMPOBJ),) +dumpobj$(EXE): $(DUMPOBJ) +dumpobj.opt$(EXE): $(call byte2native, $(DUMPOBJ)) make_opcodes := make_opcodes$(EXE) @@ -249,7 +221,7 @@ $(make_opcodes): make_opcodes.ml $(CAMLC) $< -o $@ opnames.ml: $(ROOTDIR)/runtime/caml/instruct.h $(make_opcodes) - $(ROOTDIR)/runtime/ocamlrun$(EXE) $(make_opcodes) -opnames < $< > $@ + $(NEW_OCAMLRUN) $(make_opcodes) -opnames < $< > $@ clean:: rm -f opnames.ml make_opcodes make_opcodes.exe make_opcodes.ml @@ -268,25 +240,27 @@ ifeq "$(SYSTEM)" "cygwin" DEF_SYMBOL_PREFIX = '-Dsymbol_prefix="_"' endif -OBJINFO=$(ROOTDIR)/compilerlibs/ocamlcommon.cma \ - $(ROOTDIR)/compilerlibs/ocamlbytecomp.cma \ - $(ROOTDIR)/compilerlibs/ocamlmiddleend.cma \ - objinfo.cmo +OCAMLOBJINFO=$(ROOTDIR)/compilerlibs/ocamlcommon.cma \ + $(ROOTDIR)/compilerlibs/ocamlbytecomp.cma \ + $(ROOTDIR)/compilerlibs/ocamlmiddleend.cma \ + objinfo.cmo -$(call byte_and_opt,ocamlobjinfo,$(OBJINFO),) +ocamlobjinfo$(EXE): $(OCAMLOBJINFO) +ocamlobjinfo.opt$(EXE): $(call byte2native, $(OCAMLOBJINFO)) -primreq=$(ROOTDIR)/compilerlibs/ocamlcommon.cma \ +PRIMREQ=$(ROOTDIR)/compilerlibs/ocamlcommon.cma \ $(ROOTDIR)/compilerlibs/ocamlbytecomp.cma \ primreq.cmo # Scan object files for required primitives -$(call byte_and_opt,primreq,$(primreq),) +primreq$(EXE): $(PRIMREQ) +primreq.opt$(EXE): $(call byte2native, $(PRIMREQ)) LINTAPIDIFF=$(ROOTDIR)/compilerlibs/ocamlcommon.cmxa \ $(ROOTDIR)/compilerlibs/ocamlbytecomp.cmxa \ $(ROOTDIR)/compilerlibs/ocamlmiddleend.cmxa \ - $(ROOTDIR)/otherlibs/str/str.cmxa \ - lintapidiff.cmx + $(ROOTDIR)/otherlibs/str/str.cmxa \ + lintapidiff.cmx lintapidiff.opt$(EXE): INCLUDES+= -I $(ROOTDIR)/otherlibs/str lintapidiff.opt$(EXE): $(LINTAPIDIFF) @@ -304,11 +278,12 @@ install:: # Copy a bytecode executable, stripping debug info -stripdebug=$(ROOTDIR)/compilerlibs/ocamlcommon.cma \ +STRIPDEBUG=$(ROOTDIR)/compilerlibs/ocamlcommon.cma \ $(ROOTDIR)/compilerlibs/ocamlbytecomp.cma \ stripdebug.cmo -$(call byte_and_opt,stripdebug,$(stripdebug),) +stripdebug$(EXE): $(STRIPDEBUG) +stripdebug.opt$(EXE): $(call byte2native, $(STRIPDEBUG)) # Compare two bytecode executables @@ -316,7 +291,8 @@ CMPBYT=$(ROOTDIR)/compilerlibs/ocamlcommon.cma \ $(ROOTDIR)/compilerlibs/ocamlbytecomp.cma \ cmpbyt.cmo -$(call byte_and_opt,cmpbyt,$(CMPBYT),) +cmpbyt$(EXE): $(CMPBYT) +cmpbyt.opt$(EXE): $(call byte2native, $(CMPBYT)) caml_tex_files := \ $(ROOTDIR)/compilerlibs/ocamlcommon.cma \ @@ -326,15 +302,23 @@ caml_tex_files := \ $(ROOTDIR)/otherlibs/$(UNIXLIB)/unix.cma \ caml_tex.ml +# checkstack tool + +checkstack$(EXE): checkstack.$(O) + $(MKEXE) $(OUTPUTEXE)$@ $< + #Scan latex files, and run ocaml code examples caml_tex := caml-tex$(EXE) +# caml-tex uses str.cma and unix.cma and so must be compiled with +# $(ROOTDIR)/ocamlc not $(ROOTDIR)/boot/ocamlc since the boot +# compiler does not necessarily have the correct shared library +# configuration. $(caml_tex): INCLUDES += $(addprefix -I $(ROOTDIR)/otherlibs/,str $(UNIXLIB)) $(caml_tex): $(caml_tex_files) - $(ROOTDIR)/runtime/ocamlrun$(EXE) $(ROOTDIR)/ocamlc$(EXE) -nostdlib \ - -I $(ROOTDIR)/stdlib $(LINKFLAGS) -linkall \ - -o $@ -no-alias-deps $^ + $(OCAMLRUN) $(ROOTDIR)/ocamlc$(EXE) -nostdlib -I $(ROOTDIR)/stdlib \ + $(LINKFLAGS) -linkall -o $@ -no-alias-deps $^ # we need str and unix which depend on the bytecode version of other tools # thus we delay building caml-tex to the opt.opt stage @@ -346,9 +330,6 @@ clean:: # Common stuff -%.ml: %.mll - $(CAMLLEX) $(OCAMLLEX_FLAGS) $< - %.cmo: %.ml $(CAMLC) -c $(COMPFLAGS) - $< diff --git a/ocaml/tools/autogen b/ocaml/tools/autogen index 8c85c2cba8e..69cc9101806 100755 --- a/ocaml/tools/autogen +++ b/ocaml/tools/autogen @@ -16,7 +16,7 @@ # Remove the autom4te.cache directory to make sure we start in a clean state rm -rf autom4te.cache -autoconf --force --warnings=all,error +${1-autoconf} --force --warnings=all,error # Allow pre-processing of configure arguments for Git check-outs # The sed call removes dra27's copyright on the whole configure script... @@ -33,6 +33,8 @@ sed -e '/^runstatedir/d' \ -e '/-runstatedir /{N;N;N;N;N;N;N;N;d;}' \ -e '/--runstatedir=DIR/d' \ -e 's/ runstatedir//' \ + -e '/split(line, arg/s|" "|/[ \\r\\t]/|' \ + -e '/define|undef/s/|\\\$/|\\r?\\$/' \ -e '1d' \ configure >> configure.tmp diff --git a/ocaml/tools/caml_tex.ml b/ocaml/tools/caml_tex.ml index b2b6e2e27b7..9b6f92dba83 100644 --- a/ocaml/tools/caml_tex.ml +++ b/ocaml/tools/caml_tex.ml @@ -15,7 +15,7 @@ (* *) (**************************************************************************) -[@@@warning "a-40-6"] +[@@@warning "+a-4-6-40..42-44-48"] open StdLabels open Str @@ -119,7 +119,7 @@ module Toplevel = struct let buffer = Buffer.create 100 in let rec read_toplevel_stdout () = match Unix.select[stdout_out][][] 0. with - | [a], _, _ -> + | [_a], _, _ -> let n = Unix.read stdout_out b 0 size in Buffer.add_subbytes buffer b 0 n; if n = size then read_toplevel_stdout () @@ -442,36 +442,42 @@ module Text_transform = struct | Underline -> t.start, Some t.stop, camlbunderline :: out - (** Check that all ellipsis are strictly nested inside underline transform - and that otherwise no transform starts before the end of the previous - transform in a list of transforms *) - type partition = U of t * t list | E of t - let check_partition line file l = - let init = ellipsis 0 0 in - let rec partition = function - | [] -> [] - | {kind=Underline; _ } as t :: q -> underline t [] q - | {kind=Ellipsis; _ } as t :: q -> E t :: partition q - and underline u n = function - | [] -> end_underline u n [] - | {kind=Underline; _ } :: _ as q -> end_underline u n q - | {kind=Ellipsis; _ } as t :: q -> - if t.stop < u.stop then underline u (t::n) q - else end_underline u n (t::q) - and end_underline u n l = U(u,List.rev n) :: partition l in - let check_elt last t = - if t.start < last.stop then - raise (Intersection {line;file; left = last; right = t}) - else - t in - let check acc = function - | E t -> check_elt acc t - | U(u,n) -> - let _ = check_elt acc u in - let _ = List.fold_left ~f:check_elt ~init n in - u in - List.fold_left ~f:check ~init (partition l) - |> ignore + (** Merge consecutive transforms: + - drop nested underline transform + - raise an error with transforms nested under an ellipsis + - raise an error when consecutive transforms partially overlap + *) + let merge_transforms file line ts = + let rec merge (active, active_stack, acc) t = + if active.stop <= t.start then + (* no overlap, the next transform starts after the end of the current + active transform *) + match active_stack with + | [] -> + (* there were no other active transforms, the new transform becomes + the active one *) + t, [], t :: acc + | last :: active_stack -> + (* we check that [t] is still conflict-free with our parent + transforms *) + merge (last, active_stack,acc) t + else if active.stop < t.stop (* not nested *) then + raise (Intersection {line; file; left = active; right=t}) + else (* nested transforms *) + match active.kind, t.kind with + | Ellipsis, _ -> (* no nesting allowed under an ellipsis *) + raise (Intersection {line; file; left = active; right=t}) + | Underline, Ellipsis -> (* underlined ellipsis are allowed *) + (t , active :: active_stack, t :: acc) + | Underline, Underline -> + (* multiple underlining are flattened to one *) + (t, active :: active_stack, acc) + in + match ts with + | [] -> [] + | a :: q -> + let _, _, ts = List.fold_left ~f:merge ~init:(a,[],[a]) q in + List.rev ts let apply ts file line s = (* remove duplicated transforms that can appear due to @@ -481,7 +487,7 @@ module Text_transform = struct for the two ellipses. *) let ts = List.sort_uniq compare ts in let ts = List.sort (fun x y -> compare x.start y.start) ts in - check_partition line file ts; + let ts = merge_transforms file line ts in let last, underline, ls = List.fold_left ~f:(apply_transform s) ~init:(0,None,[]) ts in let last, ls = match underline with diff --git a/ocaml/tools/check-parser-uptodate-or-warn.sh b/ocaml/tools/check-parser-uptodate-or-warn.sh index 32c8e7456de..9d82a0a78cb 100755 --- a/ocaml/tools/check-parser-uptodate-or-warn.sh +++ b/ocaml/tools/check-parser-uptodate-or-warn.sh @@ -15,9 +15,6 @@ #* * #************************************************************************** -# stop early if we are not on a development version -grep -Fq '+dev' VERSION || exit 0 - # We try to warn if the user edits parsing/parser.mly but forgets to # rebuild the generated parser. Our heuristic is to use the file # modification timestamp, but just testing diff --git a/ocaml/tools/check-typo b/ocaml/tools/check-typo index 6bd5b3840d7..375bcdd8394 100755 --- a/ocaml/tools/check-typo +++ b/ocaml/tools/check-typo @@ -112,6 +112,9 @@ case "$1" in echo "INFO: pruned path $2 (.git)" >&2 exit 0;; esac + if git check-ignore -q "$2"; then + exit 0 + fi if test -n "$(check_prune "$2")"; then echo "INFO: pruned path $2 (typo.prune)" >&2 exit 0 @@ -198,6 +201,7 @@ EXIT_CODE=0 *$f*) is_cmd_line=true;; *) is_cmd_line=false;; esac + if $path_in_index || $is_cmd_line; then :; else continue; fi if [ -z "$OCAML_CT_PREFIX" ] ; then if [ -x "$f" ] ; then check_script "$f" @@ -207,7 +211,6 @@ EXIT_CODE=0 check_script "$f" fi fi - if $path_in_index || $is_cmd_line; then :; else continue; fi attr_rules='' if $path_in_index; then # Below is a git plumbing command to detect whether git regards a @@ -303,9 +306,48 @@ EXIT_CODE=0 } } - BEGIN { state = "(first line)"; } + BEGIN { state = "(first line)"; in_recipe = 0; in_continuation = 0; } + + # Makefile recipe automaton + + # in_continuation == 1 if the line ends with a backslash + # in_recipe is: + # 0 - not in a recipe + # 1 - target line scanned, but not yet seen first recipe line + # 2 - scanning recipe lines + + # Non-recipe line + match($0, /^[^\t#] *[^# ]/) { + if (!in_continuation) { + if (!match($0, /^(ifn?eq|else|endif)/)) { + in_recipe = 0; + } + } + } + + # target: or target:: line + match($0, /^[^#]*[^:#]::?($|[^=])/) { + if (!in_continuation) { + in_recipe = 1; + } + } + + match($0, /^\t[^\t]+$/) { + if (in_recipe == 0 \ + || in_recipe == 1 && in_continuation \ + || is_err("makefile-whitespace")) { + err("tab", "TAB character(s)"); + } else { + ++ counts["makefile-whitespace"]; + in_recipe = 2; + } + } + + match($0, /.$/) { + in_continuation = (substr($0, length($0)) == "\\"); + } - match($0, /\t/) { + match($0, /.\t/) { err("tab", "TAB character(s)"); t = utf8_decode($0); if (more_columns(t, 80)){ diff --git a/ocaml/tools/ci/actions/check-alldepend.sh b/ocaml/tools/ci/actions/check-alldepend.sh new file mode 100755 index 00000000000..b88d72b195f --- /dev/null +++ b/ocaml/tools/ci/actions/check-alldepend.sh @@ -0,0 +1,41 @@ +#!/usr/bin/env bash +#************************************************************************** +#* * +#* OCaml * +#* * +#* David Allsopp, OCaml Labs, Cambridge. * +#* * +#* Copyright 2021 David Allsopp Ltd. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +set -e + +# Hygiene Checks: Ensure that all the .depend files are up-to-date. + +MSG='make alldepend is a no-op' + +make alldepend + +# note: we cannot use $? as (set -e) may be set globally, +# and disabling it locally is not worth the hassle. +# note: we ignore the whitespace in case different C dependency +# detectors use different indentation styles. +if git diff --ignore-all-space --quiet --exit-code **.depend; then + echo -e "$MSG: \e[32mYES\e[0m" +else + echo -e "$MSG: \e[31mNO\e[0m" + echo "CheckDepend: failure with the following differences:" + git --no-pager diff --ignore-all-space **.depend + cat< /dev/null; then + echo -e "$MSG: \e[31mNO\e[0m" + cat <<"EOF" +------------------------------------------------------------------------ +Most contributions should come with a message in the Changes file, as +described in our contributor documentation: + + https://github.com/ocaml/ocaml/blob/trunk/CONTRIBUTING.md#changelog + +Some very minor changes (typo fixes for example) may not need +a Changes entry. In this case, you may explicitly disable this test by +using the "no-change-entry-needed" label on the github pull request. +------------------------------------------------------------------------ +EOF + exit 1 +else + echo -e "$MSG: \e[32mYES\e[0m" +fi diff --git a/ocaml/tools/ci/actions/check-configure.sh b/ocaml/tools/ci/actions/check-configure.sh new file mode 100755 index 00000000000..db8f4a6f942 --- /dev/null +++ b/ocaml/tools/ci/actions/check-configure.sh @@ -0,0 +1,102 @@ +#!/usr/bin/env bash +#************************************************************************** +#* * +#* OCaml * +#* * +#* David Allsopp, OCaml Labs, Cambridge. * +#* * +#* Copyright 2021 David Allsopp Ltd. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +# Hygiene Checks: ensure that configure.ac generates configure +# This tests both branches and PRs. Any commit which updates either files which +# affect configure (configure.ac, VERSION, aclocal.m4 and build-aux/*) and also +# which alter this script. +# The behaviour is slightly different for pushes vs pull requests: in a PR, all +# commits must be correct; in a push, it must be the case that the configure is +# correct at the tip of the branch. This allows you to push a correcting PR to +# trunk, for example, but rejects a PR which includes bad commits (for increased +# bisect safety). + +set -e + +if [[ $1 = 'pull_request' ]]; then + ALL_COMMITS_MUST_PASS=1 +else + ALL_COMMITS_MUST_PASS=0 +fi + +# We need all the commits in the PR to be available +. tools/ci/actions/deepen-fetch.sh + +# Display failing commits in red for PRs and yellow for branches (error/warning) +if ((ALL_COMMITS_MUST_PASS)); then + COLOR='31' +else + COLOR='33' +fi + +CI_SCRIPT='tools/ci/actions/check-configure.sh' +PATHS=\ +'configure\|configure\.ac\|VERSION\|aclocal\.m4\|build-aux/.*'\ +'\|tools/autogen\|tools/git-dev-options\.sh' + +# $1 - commit to checkout files from +# $2 - range of commits to diff +# When testing a single commit, $1 and $2 will be the same; when validating the +# tip of a branch, $1 will be HEAD and $2 will be the range of commits in the +# branch. +CheckTree () { + RET=0 + COMMIT="$1" + COMMITS_TO_SEARCH="$2" + if git diff-tree --diff-filter=d --no-commit-id --name-only -r \ + "$COMMITS_TO_SEARCH" | grep -qx "$PATHS\|$CI_SCRIPT"; then + git checkout -qB return + git checkout -q "$COMMIT" + mv configure configure.ref + make -s configure + if diff -q configure configure.ref >/dev/null ; then + echo -e "$COMMIT: \e[32mconfigure.ac generates configure\e[0m" + else + RET=1 + echo -e \ + "$COMMIT: \e[${COLOR}mconfigure.ac doesn't generate configure\e[0m" + fi + mv configure.ref configure + git checkout -q return + fi + return $RET +} + +# $RESULT is 1 for success and 0 for error +RESULT=1 +# We traverse the commits in commit order; if $ALL_COMMITS_MUST_PASS=0, the +# success of the most recent commit of the branch (traversed last) will +# override any previous failure. +for commit in $(git rev-list "$MERGE_BASE..$PR_HEAD" --reverse); do + if CheckTree "$commit" "$commit"; then + if ((!ALL_COMMITS_MUST_PASS)); then + # Commit passed, so reset any previous failure + RESULT=1 + fi + else + RESULT=0 + fi +done + +if ((!RESULT)); then + echo 'configure.ac no longer generates configure' + if ((ALL_COMMITS_MUST_PASS)); then + echo 'Please rebase the PR, editing the commits identified above and run:' + else + echo 'Please fix the branch by committing changes after running:' + fi + echo 'make -B configure' + exit 1 +fi diff --git a/ocaml/tools/ci/actions/check-labelled-interfaces.sh b/ocaml/tools/ci/actions/check-labelled-interfaces.sh new file mode 100755 index 00000000000..dac746b6164 --- /dev/null +++ b/ocaml/tools/ci/actions/check-labelled-interfaces.sh @@ -0,0 +1,38 @@ +#!/usr/bin/env bash +#************************************************************************** +#* * +#* OCaml * +#* * +#* David Allsopp, OCaml Labs, Cambridge. * +#* * +#* Copyright 2021 David Allsopp Ltd. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +set -e + +# Hygiene Checks: Ensure that *Labels module docs are in sync with the +# unlabelled version. + +MSG='CheckSyncStdlibDocs is a no-op' + +tools/sync_stdlib_docs +if git diff --quiet --exit-code; then + echo -e "$MSG: \e[32mYES\e[0m" +else + echo -e "$MSG: \e[31mNO\e[0m" + echo "CheckSyncStdlibDocs: failure with the following differences:" + git --no-pager diff + cat< /dev/null; then + result=false + else + result=true + fi +fi + +echo "::set-output name=changed::$result" diff --git a/ocaml/tools/ci/actions/check-typo.sh b/ocaml/tools/ci/actions/check-typo.sh new file mode 100755 index 00000000000..17fc1905332 --- /dev/null +++ b/ocaml/tools/ci/actions/check-typo.sh @@ -0,0 +1,93 @@ +#!/usr/bin/env bash +#************************************************************************** +#* * +#* OCaml * +#* * +#* David Allsopp, OCaml Labs, Cambridge. * +#* * +#* Copyright 2021 David Allsopp Ltd. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +# Hygiene Checks: ensure that check-typo passes for all files +# This tests both branches and PRs. It is capable of requiring that every commit +# in a PR satisfies check-typo, but at present it only requires that the HEAD +# of the branch satisfies it. + +set -e + +# Set to 1 to require all commits individually to pass check-typo +CHECK_ALL_COMMITS=0 + +# We need all the commits in the PR to be available +. tools/ci/actions/deepen-fetch.sh + +# Test to see if any part of the directory name has been marked prune +not_pruned () { + DIR=$(dirname "$1") + if [[ $DIR = '.' ]] ; then + return 0 + else + case ",$(git check-attr typo.prune "$DIR" | sed -e 's/.*: //')," in + ,set,) + return 1 + ;; + *) + + not_pruned "$DIR" + return $? + esac + fi +} + +# $1 - commit to checkout files from +# $2 - range of commits to diff +CheckTypoTree () { + COMMIT="$1" + COMMITS_TO_SEARCH="$2" + export OCAML_CT_HEAD="$COMMIT" + export OCAML_CT_LS_FILES="git diff-tree --no-commit-id --name-only -r \ +$COMMITS_TO_SEARCH --" + export OCAML_CT_CAT='git cat-file --textconv' + export OCAML_CT_PREFIX="$COMMIT:" + GIT_INDEX_FILE=tmp-index git read-tree --reset -i "$COMMIT" + git diff-tree --diff-filter=d --no-commit-id --name-only -r \ + "$COMMITS_TO_SEARCH" | (while IFS= read -r path + do + if not_pruned "$path" ; then + echo "Checking $COMMIT: $path" + if ! tools/check-typo "./$path" ; then + touch failed + fi + else + echo "NOT checking $COMMIT: $path (typo.prune)" + fi + done) + rm -f tmp-index +} + +# tmp-index is used to ensure that correct version of .gitattributes is used by +# check-typo +export OCAML_CT_GIT_INDEX='tmp-index' +export OCAML_CT_CA_FLAG='--cached' +rm -f failed + +COMMIT_RANGE="$MERGE_BASE..$PR_HEAD" +if ((CHECK_ALL_COMMITS)); then + # Check each commit in turn + for commit in $(git rev-list "$COMMIT_RANGE" --reverse); do + CheckTypoTree "$commit" "$commit" + done +else + # Use the range of commits just to get the list of files to check; only HEAD + # is scanned. + CheckTypoTree "$FETCH_HEAD" "$COMMIT_RANGE" +fi + +if [[ -e failed ]]; then + exit 1 +fi diff --git a/ocaml/tools/ci/actions/deepen-fetch.sh b/ocaml/tools/ci/actions/deepen-fetch.sh new file mode 100755 index 00000000000..273870f7db6 --- /dev/null +++ b/ocaml/tools/ci/actions/deepen-fetch.sh @@ -0,0 +1,90 @@ +#!/usr/bin/env bash +#************************************************************************** +#* * +#* OCaml * +#* * +#* David Allsopp, OCaml Labs, Cambridge. * +#* * +#* Copyright 2021 David Allsopp Ltd. * +#* * +#* All rights reserved. This file is distributed under the terms of * +#* the GNU Lesser General Public License version 2.1, with the * +#* special exception on linking described in the file LICENSE. * +#* * +#************************************************************************** + +# The aim of this script is to ensure that all the commits for a PR or branch +# push are fetched. Particularly for long-lived PRs, the relevant commits for +# the merge-base (i.e. the commit on trunk) will not be present by default. +# For force pushes, the same can be true for branches (e.g. a rebase) +# After running this script, 5 variables are available: +# - FETCH_HEAD - the merge commit for a PR or the tip of the branch of a push +# - UPSTREAM_BRANCH - the branch a PR is against or the full ref of the push +# - UPSTREAM_SHA - the tip of UPSTREAM_BRANCH (prior to push, if applicable) +# - PR_BRANCH - the PR's branch name; equal to $UPSTREAM_BRANCH for a push +# - PR_HEAD - the tip of PR_BRANCH (so, for a push, the new tip after pushing) + +# GitHub Actions doesn't support the ternary operator, so the dance is done here +# Each script has: +# $1 - ref to fetch when deepening +# $2 - event type ('pull_request' or 'push') +# $3 - upstream branch name +# $4 - upstream branch SHA +# $5 - PR branch name +# $6 - PR SHA +# $7 - full ref being pushed +# $8 - upstream SHA prior to push +# $9 - repeats $7 +# $10 - upstream SHA after the push +FETCH_REF="${1}" +if [[ $2 = 'pull_request' ]]; then + shift 2 +else + shift 6 +fi + +# Record FETCH_HEAD (if it hasn't been by a previous step) +git branch fetch_head FETCH_HEAD &> /dev/null || true + +FETCH_HEAD=$(git rev-parse fetch_head) +UPSTREAM_BRANCH="$1" +UPSTREAM_HEAD="$2" +PR_BRANCH="$3" +PR_HEAD="$4" + +# Ensure that enough has been fetched to have all the commits between the +# the two branches. + +NEW=0 +# Special case: new tags and new branches will have UPSTREAM_HEAD=0\{40} +if [[ -z ${UPSTREAM_HEAD//0/} ]]; then + echo "$UPSTREAM_BRANCH is new: only testing HEAD" + UPSTREAM_HEAD="$PR_HEAD~1" + NEW=1 +elif ! git log -1 "$UPSTREAM_HEAD" &> /dev/null ; then + echo "$UPSTREAM_BRANCH has been force-pushed" + git fetch origin "$UPSTREAM_HEAD" &> /dev/null +fi + +if ! git merge-base "$UPSTREAM_HEAD" "$PR_HEAD" &> /dev/null; then + echo "Determining merge-base of $UPSTREAM_HEAD..$PR_HEAD for $PR_BRANCH" + + DEEPEN=50 + MSG='Deepening' + + while ! git merge-base "$UPSTREAM_HEAD" "$PR_HEAD" &> /dev/null + do + echo " - $MSG by $DEEPEN commits from $FETCH_REF" + git fetch origin --deepen=$DEEPEN "$FETCH_REF" &> /dev/null + MSG='Further deepening' + ((DEEPEN*=2)) + done +fi + +MERGE_BASE=$(git merge-base "$UPSTREAM_HEAD" "$PR_HEAD") + +if [[ $UPSTREAM_BRANCH != $PR_BRANCH ]]; then + echo "$PR_BRANCH branched from $UPSTREAM_BRANCH at: $MERGE_BASE" +elif ((!NEW)); then + echo "$UPSTREAM_BRANCH branched at: $MERGE_BASE" +fi diff --git a/ocaml/tools/ci/actions/runner.sh b/ocaml/tools/ci/actions/runner.sh index 9fcc61691cf..d9114ac4a26 100755 --- a/ocaml/tools/ci/actions/runner.sh +++ b/ocaml/tools/ci/actions/runner.sh @@ -21,6 +21,8 @@ PREFIX=~/local MAKE="make $MAKE_ARG" SHELL=dash +MAKE_WARN="$MAKE --warn-undefined-variables" + export PATH=$PREFIX/bin:$PATH Configure () { @@ -49,7 +51,9 @@ EOF ;; i386) ./configure --build=x86_64-pc-linux-gnu --host=i386-linux \ - CC='gcc -m32' AS='as --32' ASPP='gcc -m32 -c' \ + CC='gcc -m32 -march=x86-64' \ + AS='as --32' \ + ASPP='gcc -m32 -march=x86-64 -c' \ PARTIALLD='ld -r -melf_i386' \ $configure_flags ;; @@ -61,8 +65,7 @@ EOF } Build () { - $MAKE world.opt - $MAKE ocamlnat + script --return --command "$MAKE_WARN world.opt" build.log echo Ensuring that all names are prefixed in the runtime ./tools/check-symbol-names runtime/*.a } @@ -78,7 +81,7 @@ Test () { API_Docs () { echo Ensuring that all library documentation compiles - $MAKE -C ocamldoc html_doc pdf_doc texi_doc + $MAKE -C api_docgen html pdf texi } Install () { @@ -86,6 +89,15 @@ Install () { } Checks () { + set +x + STATUS=0 + if grep -Fq ' warning: undefined variable ' build.log; then + echo -e '\e[31mERROR\e[0m Undefined Makefile variables detected!' + grep -F ' warning: undefined variable ' build.log | sort | uniq + STATUS=1 + fi + rm build.log + set -x if fgrep 'SUPPORTS_SHARED_LIBRARIES=true' Makefile.config &>/dev/null ; then echo Check the code examples in the manual $MAKE manual-pregen @@ -100,12 +112,14 @@ Checks () { # check that the 'clean' target also works $MAKE clean $MAKE -C manual clean + $MAKE -C manual distclean # check that the `distclean` target definitely cleans the tree $MAKE distclean # Check the working tree is clean test -z "$(git status --porcelain)" # Check that there are no ignored files test -z "$(git ls-files --others -i --exclude-standard)" + exit $STATUS } CheckManual () { @@ -121,13 +135,50 @@ EOF } +BuildManual () { + $MAKE -C manual/src/html_processing duniverse + $MAKE -C manual manual + $MAKE -C manual web +} + +# ReportBuildStatus accepts an exit code as a parameter (defaults to 1) and also +# instructs GitHub Actions to set build-status to 'failed' on non-zero exit or +# 'success' otherwise. +ReportBuildStatus () { + CODE=${1:-1} + if ((CODE)); then + STATUS='failed' + else + STATUS='success' + fi + echo "::set-output name=build-status::$STATUS" + exit $CODE +} + +BasicCompiler () { + trap ReportBuildStatus ERR + + ./configure --disable-dependency-generation \ + --disable-debug-runtime \ + --disable-instrumented-runtime + + # Need a runtime + make -j coldstart + # And generated files (ocamllex compiles ocamlyacc) + make -j ocamllex + + ReportBuildStatus 0 +} + case $1 in configure) Configure;; build) Build;; test) Test;; api-docs) API_Docs;; install) Install;; +manual) BuildManual;; other-checks) Checks;; +basic-compiler) BasicCompiler;; *) echo "Unknown CI instruction: $1" exit 1;; esac diff --git a/ocaml/tools/ci/appveyor/appveyor_build.cmd b/ocaml/tools/ci/appveyor/appveyor_build.cmd index 42870dea84d..2f1fab6afa3 100644 --- a/ocaml/tools/ci/appveyor/appveyor_build.cmd +++ b/ocaml/tools/ci/appveyor/appveyor_build.cmd @@ -20,6 +20,10 @@ @rem Do not call setlocal! @echo off +chcp 65001 > nul +set BUILD_PREFIX=🐫реализация +set OCAMLROOT=%PROGRAMFILES%\Бактріан🐫 + if "%1" neq "install" goto %1 setlocal enabledelayedexpansion echo AppVeyor Environment @@ -58,7 +62,7 @@ goto :EOF :UpgradeCygwin if "%CYGWIN_INSTALL_PACKAGES%" neq "" "%CYG_ROOT%\setup-x86_64.exe" --quiet-mode --no-shortcuts --no-startmenu --no-desktop --only-site --root "%CYG_ROOT%" --site "%CYG_MIRROR%" --local-package-dir "%CYG_CACHE%" --packages %CYGWIN_INSTALL_PACKAGES:~1% > nul -for %%P in (%CYGWIN_COMMANDS%) do "%CYG_ROOT%\bin\%%P.exe" --version > nul || set CYGWIN_UPGRADE_REQUIRED=1 +for %%P in (%CYGWIN_COMMANDS%) do "%CYG_ROOT%\bin\%%P.exe" --version 2> nul > nul || set CYGWIN_UPGRADE_REQUIRED=1 "%CYG_ROOT%\bin\bash.exe" -lc "cygcheck -dc %CYGWIN_PACKAGES%" if %CYGWIN_UPGRADE_REQUIRED% equ 1 ( echo Cygwin package upgrade required - please go and drink coffee @@ -68,16 +72,18 @@ if %CYGWIN_UPGRADE_REQUIRED% equ 1 ( goto :EOF :install -chcp 65001 > nul -rem This must be kept in sync with appveyor_build.sh -set BUILD_PREFIX=🐫реализация -git worktree add "..\%BUILD_PREFIX%-%PORT%" -b appveyor-build-%PORT% -if "%PORT%" equ "msvc64" ( - git worktree add "..\%BUILD_PREFIX%-msvc32" -b appveyor-build-%PORT%32 + +if defined SDK set SDK=call %SDK% +if not defined SDK ( + if "%PORT%" equ "msvc64" set SDK=call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\amd64\vcvars64.bat" + if "%PORT%" equ "msvc32" set SDK=call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\vcvars32.bat" ) +%SDK% + +git worktree add "..\%BUILD_PREFIX%-%PORT%" -b appveyor-build-%PORT% cd "..\%BUILD_PREFIX%-%PORT%" -if "%PORT%" equ "mingw32" ( +if "%BOOTSTRAP_FLEXDLL%" equ "true" ( git submodule update --init flexdll ) @@ -99,14 +105,27 @@ rem needs upgrading. set CYGWIN_PACKAGES=cygwin make diffutils set CYGWIN_COMMANDS=cygcheck make diff if "%PORT%" equ "mingw32" ( - rem mingw64-i686-runtime does not need explictly installing, but it's useful + rem mingw64-i686-runtime does not need explicitly installing, but it's useful rem to have the version reported. set CYGWIN_PACKAGES=%CYGWIN_PACKAGES% mingw64-i686-gcc-core mingw64-i686-runtime set CYGWIN_COMMANDS=%CYGWIN_COMMANDS% i686-w64-mingw32-gcc cygcheck ) +if "%PORT%" equ "mingw64" ( + set CYGWIN_PACKAGES=%CYGWIN_PACKAGES% mingw64-x86_64-gcc-core + set CYGWIN_COMMANDS=%CYGWIN_COMMANDS% x86_64-w64-mingw32-gcc +) +if "%PORT%" equ "cygwin32" ( + set CYGWIN_PACKAGES=%CYGWIN_PACKAGES% cygwin32-gcc-core flexdll + set CYGWIN_COMMANDS=%CYGWIN_COMMANDS% i686-pc-cygwin-gcc flexlink +) +if "%PORT%" equ "cygwin64" ( + set CYGWIN_PACKAGES=%CYGWIN_PACKAGES% gcc-core flexdll + set CYGWIN_COMMANDS=%CYGWIN_COMMANDS% x86_64-pc-cygwin-gcc flexlink +) +if "%PORT:~0,6%%BOOTSTRAP_FLEXDLL%" equ "cygwinfalse" set CYGWIN_PACKAGES=%CYGWIN_PACKAGES% flexdll set CYGWIN_INSTALL_PACKAGES= -set CYGWIN_UPGRADE_REQUIRED=0 +set CYGWIN_UPGRADE_REQUIRED=%FORCE_CYGWIN_UPGRADE% for %%P in (%CYGWIN_PACKAGES%) do call :CheckPackage %%P call :UpgradeCygwin @@ -116,23 +135,14 @@ call :UpgradeCygwin goto :EOF :build -if "%PORT%" equ "msvc64" ( - setlocal - call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\amd64\vcvars64.bat" -) -rem Do the main build (either msvc64 or mingw32) "%CYG_ROOT%\bin\bash.exe" -lc "$APPVEYOR_BUILD_FOLDER/tools/ci/appveyor/appveyor_build.sh" || exit /b 1 - -if "%PORT%" neq "msvc64" goto :EOF - -rem Reconfigure the environment and run the msvc32 partial build -endlocal -call "C:\Program Files\Microsoft SDKs\Windows\v7.1\Bin\SetEnv.cmd" /x86 -"%CYG_ROOT%\bin\bash.exe" -lc "$APPVEYOR_BUILD_FOLDER/tools/ci/appveyor/appveyor_build.sh msvc32-only" || exit /b 1 goto :EOF :test -rem Reconfigure the environment for the msvc64 build -call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\amd64\vcvars64.bat" +rem No tests run in the "C" build mode +if "%BUILD_MODE%" equ "C" goto :EOF +rem Add a C# compiler in PATH for the testsuite for mingw +if "%PORT%" equ "mingw64" call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\amd64\vcvars64.bat" +if "%PORT%" equ "mingw32" call "C:\Program Files (x86)\Microsoft Visual Studio 14.0\VC\bin\vcvars32.bat" "%CYG_ROOT%\bin\bash.exe" -lc "$APPVEYOR_BUILD_FOLDER/tools/ci/appveyor/appveyor_build.sh test" || exit /b 1 goto :EOF diff --git a/ocaml/tools/ci/appveyor/appveyor_build.sh b/ocaml/tools/ci/appveyor/appveyor_build.sh index 13c5b24014a..fa43cd3ae3c 100644 --- a/ocaml/tools/ci/appveyor/appveyor_build.sh +++ b/ocaml/tools/ci/appveyor/appveyor_build.sh @@ -21,7 +21,7 @@ BUILD_PID=0 CACHE_DIRECTORY=/cygdrive/c/projects/cache if [[ -z $APPVEYOR_PULL_REQUEST_HEAD_COMMIT ]] ; then - MAKE="make -j" + MAKE="make -j$NUMBER_OF_PROCESSORS" else MAKE=make fi @@ -51,18 +51,26 @@ function run { # $2: the prefix to use to install function set_configuration { case "$1" in - mingw) + cygwin*) + dep='--disable-dependency-generation' + ;; + mingw32) build='--build=i686-pc-cygwin' host='--host=i686-w64-mingw32' dep='--disable-dependency-generation' ;; - msvc) + mingw64) + build='--build=i686-pc-cygwin' + host='--host=x86_64-w64-mingw32' + dep='--disable-dependency-generation' + ;; + msvc32) build='--build=i686-pc-cygwin' host='--host=i686-pc-windows' dep='--disable-dependency-generation' ;; msvc64) - build='--build=x86_64-unknown-cygwin' + build='--build=x86_64-pc-cygwin' host='--host=x86_64-pc-windows' # Explicitly test dependency generation on msvc64 dep='--enable-dependency-generation' @@ -81,40 +89,32 @@ function set_configuration { } APPVEYOR_BUILD_FOLDER=$(echo "$APPVEYOR_BUILD_FOLDER" | cygpath -f -) -# These directory names are specified here, because getting UTF-8 correctly -# through appveyor.yml -> Command Script -> Bash is quite painful... -OCAMLROOT=$(echo "$PROGRAMFILES/Бактріан🐫" | cygpath -f - -m) - -# This must be kept in sync with appveyor_build.cmd -BUILD_PREFIX=🐫реализация - -PATH=$(echo "$OCAMLROOT" | cygpath -f -)/bin/flexdll:$PATH +FLEXDLLROOT="$PROGRAMFILES/flexdll" +OCAMLROOT=$(echo "$OCAMLROOT" | cygpath -f - -m) + +if [[ $BOOTSTRAP_FLEXDLL = 'false' ]] ; then + case "$PORT" in + cygwin*) ;; + *) export PATH="$FLEXDLLROOT:$PATH";; + esac +fi case "$1" in install) - mkdir -p "$OCAMLROOT/bin/flexdll" - cd "$APPVEYOR_BUILD_FOLDER/../flexdll" - # msvc64 objects need to be compiled with VS2015, so are copied later from - # a source build. - for f in flexdll.h flexlink.exe flexdll*_msvc.obj default*.manifest ; do - cp "$f" "$OCAMLROOT/bin/flexdll/" - done - if [[ $PORT = 'msvc64' ]] ; then - echo 'eval $($APPVEYOR_BUILD_FOLDER/tools/msvs-promote-path)' \ - >> ~/.bash_profile + if [[ $BOOTSTRAP_FLEXDLL = 'false' ]] ; then + mkdir -p "$FLEXDLLROOT" + cd "$APPVEYOR_BUILD_FOLDER/../flexdll" + # The objects are always built from the sources + for f in flexdll.h flexlink.exe default*.manifest ; do + cp "$f" "$FLEXDLLROOT/" + done fi - ;; - msvc32-only) - cd "$APPVEYOR_BUILD_FOLDER/../$BUILD_PREFIX-msvc32" - - set_configuration msvc "$OCAMLROOT-msvc32" - - run "$MAKE world" $MAKE world - run "$MAKE runtimeopt" $MAKE runtimeopt - run "$MAKE -C otherlibs/systhreads libthreadsnat.lib" \ - $MAKE -C otherlibs/systhreads libthreadsnat.lib - - exit 0 + case "$PORT" in + msvc*) + echo 'eval $($APPVEYOR_BUILD_FOLDER/tools/msvs-promote-path)' \ + >> ~/.bash_profile + ;; + esac ;; test) FULL_BUILD_PREFIX="$APPVEYOR_BUILD_FOLDER/../$BUILD_PREFIX" @@ -124,6 +124,11 @@ case "$1" in "$FULL_BUILD_PREFIX-$PORT/tools/check-symbol-names" \ $FULL_BUILD_PREFIX-$PORT/runtime/*.a fi + if [[ $PORT = 'mingw64' ]] ; then + export PATH="$PATH:/usr/x86_64-w64-mingw32/sys-root/mingw/bin" + elif [[ $PORT = 'mingw32' ]] ; then + export PATH="$PATH:/usr/i686-w64-mingw32/sys-root/mingw/bin" + fi run "test $PORT" $MAKE -C "$FULL_BUILD_PREFIX-$PORT" tests run "install $PORT" $MAKE -C "$FULL_BUILD_PREFIX-$PORT" install if [[ $PORT = 'msvc64' ]] ; then @@ -152,40 +157,59 @@ case "$1" in if [[ $PORT = 'msvc64' ]] ; then # Ensure that make distclean can be run from an empty tree run "$MAKE distclean" $MAKE distclean + fi + + if [[ $BOOTSTRAP_FLEXDLL = 'false' ]] ; then tar -xzf "$APPVEYOR_BUILD_FOLDER/flexdll.tar.gz" cd "flexdll-$FLEXDLL_VERSION" - $MAKE MSVC_DETECT=0 CHAINS=msvc64 support - cp flexdll*_msvc64.obj "$OCAMLROOT/bin/flexdll/" + $MAKE MSVC_DETECT=0 CHAINS=${PORT%32} support + cp -f *.obj "$FLEXDLLROOT/" 2>/dev/null || \ + cp -f *.o "$FLEXDLLROOT/" cd .. fi - if [[ $PORT = 'msvc64' ]] ; then - set_configuration msvc64 "$OCAMLROOT" - else - set_configuration mingw "$OCAMLROOT-mingw32" - fi - - cd "$APPVEYOR_BUILD_FOLDER/../$BUILD_PREFIX-$PORT" + set_configuration "$PORT" "$OCAMLROOT" export TERM=ansi - if [[ $PORT = 'mingw32' ]] ; then - set -o pipefail - # For an explanation of the sed command, see - # https://github.com/appveyor/ci/issues/1824 - script --quiet --return --command \ - "$MAKE -C ../$BUILD_PREFIX-mingw32 flexdll && "\ -"$MAKE -C ../$BUILD_PREFIX-mingw32 world.opt" \ - "../$BUILD_PREFIX-mingw32/build.log" | - sed -e 's/\d027\[K//g' \ - -e 's/\d027\[m/\d027[0m/g' \ - -e 's/\d027\[01\([m;]\)/\d027[1\1/g' - else + case "$BUILD_MODE" in + world.opt) + set -o pipefail + # For an explanation of the sed command, see + # https://github.com/appveyor/ci/issues/1824 + script --quiet --return --command \ + "$MAKE -C ../$BUILD_PREFIX-$PORT world.opt" \ + "../$BUILD_PREFIX-$PORT/build.log" | + sed -e 's/\d027\[K//g' \ + -e 's/\d027\[m/\d027[0m/g' \ + -e 's/\d027\[01\([m;]\)/\d027[1\1/g' + rm -f build.log;; + steps) + run "C deps: runtime" make -j64 -C runtime setup-depend + run "C deps: win32unix" make -j64 -C otherlibs/win32unix setup-depend run "$MAKE world" $MAKE world run "$MAKE bootstrap" $MAKE bootstrap run "$MAKE opt" $MAKE opt - run "$MAKE opt.opt" $MAKE opt.opt - fi + run "$MAKE opt.opt" $MAKE opt.opt;; + C) + run "$MAKE world" $MAKE world + run "$MAKE runtimeopt" $MAKE runtimeopt + run "$MAKE -C otherlibs/systhreads libthreadsnat.lib" \ + $MAKE -C otherlibs/systhreads libthreadsnat.lib;; + *) + echo "Unrecognised build: $BUILD_MODE" + exit 1 + esac + + echo DLL base addresses + case "$PORT" in + *32) + ARG='-4';; + *64) + ARG='-8';; + esac + find "../$BUILD_PREFIX-$PORT" -type f \( -name \*.dll -o -name \*.so \) | \ + xargs rebase -i "$ARG" ;; esac diff --git a/ocaml/tools/ci/inria/bootstrap/remove-sinh-primitive.patch b/ocaml/tools/ci/inria/bootstrap/remove-sinh-primitive.patch index db9dfe83b9f..ba02c242a84 100644 --- a/ocaml/tools/ci/inria/bootstrap/remove-sinh-primitive.patch +++ b/ocaml/tools/ci/inria/bootstrap/remove-sinh-primitive.patch @@ -4,10 +4,10 @@ and standard library. It is used on Inria's CI to make sure the bootstrap procedure works. diff --git a/runtime/floats.c b/runtime/floats.c -index b93f6a409..6edbed9c6 100644 +index 7561bfba8..db246978c 100644 --- a/runtime/floats.c +++ b/runtime/floats.c -@@ -536,11 +536,6 @@ CAMLprim value caml_sin_float(value f) +@@ -858,11 +858,6 @@ CAMLprim value caml_sin_float(value f) return caml_copy_double(sin(Double_val(f))); } @@ -20,10 +20,10 @@ index b93f6a409..6edbed9c6 100644 { return caml_copy_double(cos(Double_val(f))); diff --git a/stdlib/float.ml b/stdlib/float.ml -index 8d9c5cca6..3b3ca61bc 100644 +index ab5cd5c07..e09cbe215 100644 --- a/stdlib/float.ml +++ b/stdlib/float.ml -@@ -69,8 +69,6 @@ external hypot : float -> float -> float +@@ -85,8 +85,6 @@ external hypot : float -> float -> float = "caml_hypot_float" "caml_hypot" [@@unboxed] [@@noalloc] external cosh : float -> float = "caml_cosh_float" "cosh" [@@unboxed] [@@noalloc] @@ -31,12 +31,12 @@ index 8d9c5cca6..3b3ca61bc 100644 - [@@unboxed] [@@noalloc] external tanh : float -> float = "caml_tanh_float" "tanh" [@@unboxed] [@@noalloc] - external ceil : float -> float = "caml_ceil_float" "ceil" + external acosh : float -> float = "caml_acosh_float" "caml_acosh" diff --git a/stdlib/float.mli b/stdlib/float.mli -index 2cdd31608..904f4af0e 100644 +index ba84d9b0e..8132f93f7 100644 --- a/stdlib/float.mli +++ b/stdlib/float.mli -@@ -196,10 +196,6 @@ external cosh : float -> float = "caml_cosh_float" "cosh" +@@ -285,10 +285,6 @@ external cosh : float -> float = "caml_cosh_float" "cosh" [@@unboxed] [@@noalloc] (** Hyperbolic cosine. Argument is in radians. *) @@ -48,10 +48,10 @@ index 2cdd31608..904f4af0e 100644 [@@unboxed] [@@noalloc] (** Hyperbolic tangent. Argument is in radians. *) diff --git a/stdlib/pervasives.ml b/stdlib/pervasives.ml -index 945512716..55bc9e921 100644 +index e9b2e5cde..3a39cf754 100644 --- a/stdlib/pervasives.ml +++ b/stdlib/pervasives.ml -@@ -97,8 +97,6 @@ external hypot : float -> float -> float = "caml_hypot_float" "caml_hypot" +@@ -99,8 +99,6 @@ external hypot : float -> float -> float = "caml_hypot_float" "caml_hypot" [@@unboxed] [@@noalloc] external cosh : float -> float = "caml_cosh_float" "cosh" [@@unboxed] [@@noalloc] @@ -61,23 +61,23 @@ index 945512716..55bc9e921 100644 [@@unboxed] [@@noalloc] external ceil : float -> float = "caml_ceil_float" "ceil" diff --git a/stdlib/stdlib.ml b/stdlib/stdlib.ml -index 425728f64..4057dbc90 100644 +index aac8fcc17..663ce44f2 100644 --- a/stdlib/stdlib.ml +++ b/stdlib/stdlib.ml -@@ -148,8 +148,6 @@ external log10 : float -> float = "caml_log10_float" "log10" +@@ -146,8 +146,6 @@ external log10 : float -> float = "caml_log10_float" "log10" external log1p : float -> float = "caml_log1p_float" "caml_log1p" [@@unboxed] [@@noalloc] external sin : float -> float = "caml_sin_float" "sin" [@@unboxed] [@@noalloc] -external sinh : float -> float = "caml_sinh_float" "sinh" - [@@unboxed] [@@noalloc] - external sqrt : float -> float = "caml_sqrt_float" "sqrt" + external asinh : float -> float = "caml_asinh_float" "caml_asinh" [@@unboxed] [@@noalloc] - external tan : float -> float = "caml_tan_float" "tan" [@@unboxed] [@@noalloc] + external sqrt : float -> float = "caml_sqrt_float" "sqrt" diff --git a/stdlib/stdlib.mli b/stdlib/stdlib.mli -index d451bba9c..990a41467 100644 +index e2e898266..2e18f16d3 100644 --- a/stdlib/stdlib.mli +++ b/stdlib/stdlib.mli -@@ -461,10 +461,6 @@ external cosh : float -> float = "caml_cosh_float" "cosh" +@@ -556,10 +556,6 @@ external cosh : float -> float = "caml_cosh_float" "cosh" [@@unboxed] [@@noalloc] (** Hyperbolic cosine. Argument is in radians. *) diff --git a/ocaml/tools/ci/inria/bootstrap/script b/ocaml/tools/ci/inria/bootstrap/script index 8233ab7b716..abf2356da72 100755 --- a/ocaml/tools/ci/inria/bootstrap/script +++ b/ocaml/tools/ci/inria/bootstrap/script @@ -64,11 +64,13 @@ change_exe_magic_number() { new="$1" echo Changing executable magic number from ${old} to ${new} # Change magic number in runtime/caml/exec.h - sed -i 's/\x23define \+EXEC_MAGIC \+\x22'${old}\ + sed -i.tmp 's/\x23define \+EXEC_MAGIC \+\x22'${old}\ '\x22/#define EXEC_MAGIC "'${new}'"/' runtime/caml/exec.h + rm -f runtime/caml/exec.h.tmp # Change magic number in utils/config.mlp - sed -i 's/let \+exec_magic_number \+= \+\x22'${old}\ + sed -i.tmp 's/let \+exec_magic_number \+= \+\x22'${old}\ '\x22/let exec_magic_number = "'${new}'"/' utils/config.mlp + rm -f utils/config.mlp.tmp } remove_primitive() @@ -158,7 +160,7 @@ case "${OCAML_ARCH}" in check_make_alldepend=true ;; mingw64) - build='--build=x86_64-unknown-cygwin' + build='--build=x86_64-pc-cygwin' host='--host=x86_64-w64-mingw32' instdir='C:/ocamlmgw64' cleanup=true @@ -172,7 +174,7 @@ case "${OCAML_ARCH}" in cleanup=true ;; msvc64) - build='--build=x86_64-unknown-cygwin' + build='--build=x86_64-pc-cygwin' host='--host=x86_64-pc-windows' instdir='C:/ocamlms64' configure=nt diff --git a/ocaml/tools/ci/inria/main b/ocaml/tools/ci/inria/main index 5c38792267b..d4c2ea27356 100755 --- a/ocaml/tools/ci/inria/main +++ b/ocaml/tools/ci/inria/main @@ -57,6 +57,20 @@ quote1 () { printf "'%s'" "`printf %s "$1" | sed -e "s/'/'\\\\\\\\''/g"`"; } +######################################################################### +# Display environment information +uname -a +for i in issue redhat-release ; do + if test -e /etc/$i ; then + echo "/etc/$i content:" + cat /etc/$i | sed -e 's/^/| /' + fi +done +if command -v gcc >/dev/null ; then + echo "gcc info:" + gcc --version --verbose 2>&1 | sed -e 's/^/| /' +fi + ######################################################################### # be verbose set -x @@ -128,9 +142,9 @@ ${OCAML_CONFIGURE_OPTIONS}" make_native=true cleanup=false check_make_alldepend=false -dorebase=false jobs='' bootstrap=false +init_submodule=false case "${OCAML_ARCH}" in bsd|solaris) @@ -149,8 +163,6 @@ case "${OCAML_ARCH}" in cygwin64) cleanup=true check_make_alldepend=true - dorebase=false - confoptions="$confoptions --disable-shared " ;; mingw) build='--build=i686-pc-cygwin' @@ -160,7 +172,7 @@ case "${OCAML_ARCH}" in check_make_alldepend=true ;; mingw64) - build='--build=x86_64-unknown-cygwin' + build='--build=x86_64-pc-cygwin' host='--host=x86_64-w64-mingw32' instdir='C:/ocamlmgw64' cleanup=true @@ -173,7 +185,7 @@ case "${OCAML_ARCH}" in cleanup=true ;; msvc64) - build='--build=x86_64-unknown-cygwin' + build='--build=x86_64-pc-cygwin' host='--host=x86_64-pc-windows' instdir='C:/ocamlms64' cleanup=true @@ -202,6 +214,12 @@ fi pwd cd "$jenkinsdir" +if $init_submodule; then + git submodule update --init flexdll +elif [ -f flexdll/Makefile ]; then + git submodule deinit --force flexdll +fi + ######################################################################### # parse optional command-line arguments (has to be done after the "cd") @@ -249,13 +267,6 @@ if $make_native && $check_make_alldepend; then $make --warn-undefined-variables alldepend fi -if $dorebase; then - # temporary solution to the cygwin fork problem - # see https://github.com/alainfrisch/flexdll/issues/50 - rebase -b 0x7cd20000 otherlibs/unix/dllunix.so - rebase -b 0x7cdc0000 otherlibs/systhreads/dllthreads.so -fi - $make --warn-undefined-variables install rm -rf "$instdir" diff --git a/ocaml/tools/ci/inria/other-configs/script b/ocaml/tools/ci/inria/other-configs/script index c3279f63cfa..7ce82f40bee 100755 --- a/ocaml/tools/ci/inria/other-configs/script +++ b/ocaml/tools/ci/inria/other-configs/script @@ -36,7 +36,6 @@ ${main} -conf --disable-native-compiler \ -conf --disable-unix-lib \ -conf --disable-bigarray-lib \ -conf --disable-ocamldoc \ - -conf --disable-native-compiler \ -conf --disable-dependency-generation \ -no-native ${main} -conf --disable-naked-pointers @@ -44,3 +43,4 @@ ${main} -with-bootstrap -conf --disable-flat-float-array ${main} -conf --enable-flambda -conf --disable-naked-pointers ${main} -conf --enable-reserved-header-bits=27 OCAMLRUNPARAM="c=1" ${main} +${main} -conf --with-pic diff --git a/ocaml/tools/ci/inria/step-by-step-build/script b/ocaml/tools/ci/inria/step-by-step-build/script index 8397e68365b..b7ca927fe4a 100755 --- a/ocaml/tools/ci/inria/step-by-step-build/script +++ b/ocaml/tools/ci/inria/step-by-step-build/script @@ -14,8 +14,15 @@ #* * #************************************************************************** +# Be verbose and stop on errors +set -ex + jobs=-j8 instdir="$HOME/ocaml-tmp-install-$$" + +# Make sure the repository is clean +git clean -q -f -d -x + ./configure --prefix "$instdir" --disable-dependency-generation make $jobs world make $jobs opt diff --git a/ocaml/tools/ci/travis/travis-ci.sh b/ocaml/tools/ci/travis/travis-ci.sh deleted file mode 100755 index 81774562c0f..00000000000 --- a/ocaml/tools/ci/travis/travis-ci.sh +++ /dev/null @@ -1,426 +0,0 @@ -#!/usr/bin/env bash -#************************************************************************** -#* * -#* OCaml * -#* * -#* Anil Madhavapeddy, OCaml Labs * -#* * -#* Copyright 2014 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. This file is distributed under the terms of * -#* the GNU Lesser General Public License version 2.1, with the * -#* special exception on linking described in the file LICENSE. * -#* * -#************************************************************************** - -set -e - -# TRAVIS_COMMIT_RANGE has the form ... -# TRAVIS_CUR_HEAD is -# TRAVIS_PR_HEAD is -# -# The following diagram illustrates the relationship between -# the commits: -# -# (trunk) (pr branch) -# TRAVIS_CUR_HEAD TRAVIS_PR_HEAD -# | / -# ... ... -# | / -# TRAVIS_MERGE_BASE -# -echo "TRAVIS_COMMIT_RANGE=$TRAVIS_COMMIT_RANGE" -echo "TRAVIS_COMMIT=$TRAVIS_COMMIT" -if [[ $TRAVIS_EVENT_TYPE = 'pull_request' ]] ; then - FETCH_HEAD=$(git rev-parse FETCH_HEAD) - echo "FETCH_HEAD=$FETCH_HEAD" -else - FETCH_HEAD=$TRAVIS_COMMIT -fi - -if [[ $TRAVIS_EVENT_TYPE = 'push' ]] ; then - if ! git cat-file -e "$TRAVIS_COMMIT" 2> /dev/null ; then - echo 'TRAVIS_COMMIT does not exist - CI failure' - exit 1 - fi -else - if [[ $TRAVIS_COMMIT != $(git rev-parse FETCH_HEAD) ]] ; then - echo 'WARNING! Travis TRAVIS_COMMIT and FETCH_HEAD do not agree!' - if git cat-file -e "$TRAVIS_COMMIT" 2> /dev/null ; then - echo 'TRAVIS_COMMIT exists, so going with it' - else - echo 'TRAVIS_COMMIT does not exist; setting to FETCH_HEAD' - TRAVIS_COMMIT=$FETCH_HEAD - fi - fi -fi - -set -x - -PREFIX=~/local - -MAKE="make $MAKE_ARG" -SHELL=dash - -TRAVIS_CUR_HEAD=${TRAVIS_COMMIT_RANGE%%...*} -TRAVIS_PR_HEAD=${TRAVIS_COMMIT_RANGE##*...} -case $TRAVIS_EVENT_TYPE in - # If this is not a pull request then TRAVIS_COMMIT_RANGE may be empty. - pull_request) - DEEPEN=50 - while ! git merge-base "$TRAVIS_CUR_HEAD" "$TRAVIS_PR_HEAD" >& /dev/null - do - echo "Deepening $TRAVIS_BRANCH by $DEEPEN commits" - git fetch origin --deepen=$DEEPEN "$TRAVIS_BRANCH" - ((DEEPEN*=2)) - done - TRAVIS_MERGE_BASE=$(git merge-base "$TRAVIS_CUR_HEAD" "$TRAVIS_PR_HEAD");; -esac - -CheckSyncStdlibDocs () { - cat</dev/null ; then - echo Ensuring that all library documentation compiles - $MAKE -C ocamldoc html_doc pdf_doc texi_doc - fi - $MAKE install - if command -v hevea &>/dev/null ; then - echo Ensuring that the manual compiles - # These steps rely on the compiler being installed and in PATH - $MAKE -C manual/manual/html_processing duniverse - $MAKE -C manual web - fi - if fgrep 'SUPPORTS_SHARED_LIBRARIES=true' Makefile.config &>/dev/null ; then - echo Check the code examples in the manual - $MAKE manual-pregen - fi - # check_all_arches checks tries to compile all backends in place, - # we would need to redo (small parts of) world.opt afterwards to - # use the compiler again - $MAKE check_all_arches - # Ensure that .gitignore is up-to-date - this will fail if any untreacked or - # altered files exist. - test -z "$(git status --porcelain)" - # check that the 'clean' target also works - $MAKE clean - $MAKE -C manual clean - # check that the `distclean` target definitely cleans the tree - $MAKE distclean - $MAKE -C manual distclean - # Check the working tree is clean - test -z "$(git status --porcelain)" - # Check that there are no ignored files - test -z "$(git ls-files --others -i --exclude-standard)" -} - -CheckChangesModified () { - cat< /dev/null && CheckNoChangesMessage || echo pass -} - -CheckNoChangesMessage () { - API_URL=https://api.github.com/repos/$TRAVIS_REPO_SLUG/issues/$TRAVIS_PULL_REQUEST/labels - if [[ -n $(git log --grep='[Nn]o [Cc]hange.* needed' --max-count=1 \ - "$TRAVIS_MERGE_BASE..$TRAVIS_PR_HEAD") ]] - then echo pass - elif [[ -n $(curl "$API_URL" | grep 'no-change-entry-needed') ]] - then echo pass - else exit 1 - fi -} - -CheckManual () { - cat< /dev/null && exit 1 || echo pass -} - -# Test to see if any part of the directory name has been marked prune -not_pruned () { - DIR=$(dirname "$1") - if [[ $DIR = '.' ]] ; then - return 0 - else - case ",$(git check-attr typo.prune "$DIR" | sed -e 's/.*: //')," in - ,set,) - return 1 - ;; - *) - - not_pruned "$DIR" - return $? - esac - fi -} - -CheckTypoTree () { - export OCAML_CT_HEAD=$1 - export OCAML_CT_LS_FILES="git diff-tree --no-commit-id --name-only -r $2 --" - export OCAML_CT_CAT='git cat-file --textconv' - export OCAML_CT_PREFIX="$1:" - GIT_INDEX_FILE=tmp-index git read-tree --reset -i "$1" - git diff-tree --diff-filter=d --no-commit-id --name-only -r "$2" \ - | (while IFS= read -r path - do - if not_pruned "$path" ; then - echo "Checking $1: $path" - if ! tools/check-typo "./$path" ; then - touch check-typo-failed - fi - else - echo "NOT checking $1: $path (typo.prune)" - fi - case "$path" in - configure|configure.ac|VERSION|tools/ci/travis/travis-ci.sh) - touch CHECK_CONFIGURE;; - esac - done) - rm -f tmp-index - if [[ -e CHECK_CONFIGURE ]] ; then - rm -f CHECK_CONFIGURE - echo "configure generation altered in $1" - echo 'Verifying that configure.ac generates configure' - git checkout "$1" - mv configure configure.ref - make configure - if ! diff -q configure configure.ref >/dev/null ; then - echo "configure.ac no longer generates configure, \ -please run rm configure ; make configure and commit" - exit 1 - fi - fi -} - -CHECK_ALL_COMMITS=0 - -CheckTypo () { - export OCAML_CT_GIT_INDEX='tmp-index' - export OCAML_CT_CA_FLAG='--cached' - # Work around an apparent bug in Ubuntu 12.4.5 - # See https://bugs.launchpad.net/ubuntu/+source/gawk/+bug/1647879 - rm -f check-typo-failed - if [[ -z $TRAVIS_COMMIT_RANGE ]] - then CheckTypoTree "$TRAVIS_COMMIT" "$TRAVIS_COMMIT" - else - if [[ $TRAVIS_EVENT_TYPE = 'pull_request' ]] - then TRAVIS_COMMIT_RANGE=$TRAVIS_MERGE_BASE..$TRAVIS_PULL_REQUEST_SHA - fi - if [[ $CHECK_ALL_COMMITS -eq 1 ]] - then - for commit in $(git rev-list "$TRAVIS_COMMIT_RANGE" --reverse) - do - CheckTypoTree "$commit" "$commit" - done - else - if [[ -z $TRAVIS_PULL_REQUEST_SHA ]] - then CheckTypoTree "$TRAVIS_COMMIT" "$TRAVIS_COMMIT" - else CheckTypoTree "$TRAVIS_COMMIT" "$TRAVIS_COMMIT_RANGE" - fi - fi - fi - echo complete - if [[ -e check-typo-failed ]] - then exit 1 - fi -} - - -case $CI_KIND in -build) BuildAndTest;; -changes) - case $TRAVIS_EVENT_TYPE in - pull_request) CheckChangesModified;; - esac;; -manual) - CheckManual;; -tests) - case $TRAVIS_EVENT_TYPE in - pull_request) CheckTestsuiteModified;; - esac;; -check-typo) - set +x - CheckTypo;; -check-depend) - CheckSyncStdlibDocs - CheckDepend;; -*) echo unknown CI kind - exit 1 - ;; -esac diff --git a/ocaml/tools/debug_printers b/ocaml/tools/debug_printers new file mode 100644 index 00000000000..83b4d86c9e4 --- /dev/null +++ b/ocaml/tools/debug_printers @@ -0,0 +1,5 @@ +load_printer "tools/debug_printers.cmo" +install_printer Debug_printers.type_expr +install_printer Debug_printers.row_field +install_printer Debug_printers.ident +install_printer Debug_printers.path diff --git a/ocaml/tools/debug_printers.ml b/ocaml/tools/debug_printers.ml new file mode 100644 index 00000000000..9271de0c049 --- /dev/null +++ b/ocaml/tools/debug_printers.ml @@ -0,0 +1,6 @@ + +let type_expr = Printtyp.raw_type_expr +let row_field = Printtyp.raw_field +let ident = Ident.print_with_scope +let path = Path.print + diff --git a/ocaml/tools/dune b/ocaml/tools/dune index b78cd5c6cf8..878c3b6836e 100644 --- a/ocaml/tools/dune +++ b/ocaml/tools/dune @@ -50,28 +50,11 @@ (modules cmpbyt) (libraries ocamlcommon ocamlbytecomp)) -(library - (name ocamlmklib_common) - (modes byte native) - (wrapped false) - (modules ocamlmklibconfig) - (libraries ocamlcommon ocamlbytecomp)) - -; We should fix this so it doesn't need "make". -(rule - (targets ocamlmklibconfig.ml) - (deps - ../Makefile.config - ../Makefile - Makefile - .depend) - (action (run make -s %{targets}))) - (executable (name ocamlmklib) (modes byte native) (modules ocamlmklib) - (libraries ocamlcommon ocamlbytecomp ocamlmklib_common)) + (libraries ocamlcommon ocamlbytecomp)) (install (files diff --git a/ocaml/tools/eventlog_metadata.in b/ocaml/tools/eventlog_metadata.in index f39364ed1ea..2a2b50726ed 100644 --- a/ocaml/tools/eventlog_metadata.in +++ b/ocaml/tools/eventlog_metadata.in @@ -203,7 +203,7 @@ event { /* Flush events are used to track the time spent by the tracing runtime flushing - data to disk, useful to remove flushing overhead for other runtime mesurements + data to disk, useful to remove flushing overhead for other runtime measurements in the trace. */ event { diff --git a/ocaml/tools/make-version-header.sh b/ocaml/tools/make-version-header.sh deleted file mode 100755 index b91fba6c2d4..00000000000 --- a/ocaml/tools/make-version-header.sh +++ /dev/null @@ -1,55 +0,0 @@ -#!/bin/sh - -#************************************************************************** -#* * -#* OCaml * -#* * -#* Damien Doligez, projet Gallium, INRIA Rocquencourt * -#* * -#* Copyright 2003 Institut National de Recherche en Informatique et * -#* en Automatique. * -#* * -#* All rights reserved. As an exception to the licensing rules of * -#* OCaml, this file is freely redistributable, modified or not, * -#* without constraints. * -#* * -#************************************************************************** - -# This script extracts the components from an OCaml version number -# and provides them as C defines: -# OCAML_VERSION_MAJOR: the major version number -# OCAML_VERSION_MAJOR: the minor version number -# OCAML_VERSION_PATCHLEVEL: the patchlevel number if present, or 0 if absent -# OCAML_VERSION_ADDITIONAL: this is defined only if the additional-info -# field is present, and is a string that contains that field. -# Note that additional-info is always absent in officially-released -# versions of OCaml. - -# usage: -# make-version-header.sh [version-file] -# The argument is the VERSION file from the OCaml sources. -# If the argument is not given, the version number from "ocamlc -v" will -# be used. - -case $# in - 0) version="`ocamlc -v | tr -d '\r' | sed -n -e 's/.*version //p'`";; - 1) version="`sed -e 1q "$1" | tr -d '\r'`";; - *) echo "usage: make-version-header.sh [version-file]" >&2 - exit 2;; -esac - -major="`echo "$version" | sed -n -e '1s/^\([0-9]*\)\..*/\1/p'`" -minor="`echo "$version" | sed -n -e '1s/^[0-9]*\.0*\([0-9]*\).*/\1/p'`" -patchlvl="`echo "$version" | sed -n -e '1s/^[0-9]*\.[0-9]*\.\([0-9]*\).*/\1/p'`" -suffix="`echo "$version" | sed -n -e '1s/^[^+~]*[+~]\(.*\)/\1/p'`" - -echo "#define OCAML_VERSION_MAJOR $major" -printf '#define OCAML_VERSION_MINOR %d\n' "$minor" -case $patchlvl in "") patchlvl=0;; esac -echo "#define OCAML_VERSION_PATCHLEVEL $patchlvl" -case "$suffix" in - "") echo "#undef OCAML_VERSION_ADDITIONAL";; - *) echo "#define OCAML_VERSION_ADDITIONAL \"$suffix\"";; -esac -printf '#define OCAML_VERSION %d%02d%02d\n' "$major" "$minor" "$patchlvl" -echo "#define OCAML_VERSION_STRING \"$version\"" diff --git a/ocaml/tools/objinfo.ml b/ocaml/tools/objinfo.ml index 0f285b70491..c9e9a8e4762 100644 --- a/ocaml/tools/objinfo.ml +++ b/ocaml/tools/objinfo.ml @@ -28,6 +28,7 @@ open Cmo_format let no_approx = ref false let no_code = ref false let no_crc = ref false +let shape = ref false module Magic_number = Misc.Magic_number @@ -49,13 +50,25 @@ let null_crc = String.make 32 '0' let string_of_crc crc = if !no_crc then null_crc else Digest.to_hex crc -let print_name_crc (name, crco) = +let print_name_crc name crco = let crc = match crco with None -> dummy_crc | Some crc -> string_of_crc crc in - printf "\t%s\t%s\n" crc name + printf "\t%s\t%a\n" crc Compilation_unit.Name.output name + +(* CR-someday mshinwell: consider moving to [Import_info.print] *) + +let print_intf_import import = + let name = Import_info.name import in + let crco = Import_info.crc import in + print_name_crc name crco + +let print_impl_import import = + let unit = Import_info.cu import in + let crco = Import_info.crc import in + print_name_crc (Compilation_unit.name unit) crco let print_line name = printf "\t%s\n" name @@ -64,12 +77,12 @@ let print_name_line cu = printf "\t%a\n" Compilation_unit.Name.output (Compilation_unit.name cu) let print_required_global id = - printf "\t%s\n" (Ident.name id) + printf "\t%a\n" Compilation_unit.output id let print_cmo_infos cu = - printf "Unit name: %a\n" Compilation_unit.Name.output cu.cu_name; + printf "Unit name: %a\n" Compilation_unit.output cu.cu_name; print_string "Interfaces imported:\n"; - List.iter print_name_crc cu.cu_imports; + Array.iter print_intf_import cu.cu_imports; print_string "Required globals:\n"; List.iter print_required_global cu.cu_required_globals; printf "Uses unsafe features: "; @@ -98,15 +111,15 @@ let print_cma_infos (lib : Cmo_format.library) = List.iter print_cmo_infos lib.lib_units let print_cmi_infos name crcs = - printf "Unit name: %s\n" name; + printf "Unit name: %a\n" Compilation_unit.output name; printf "Interfaces imported:\n"; - List.iter print_name_crc crcs + Array.iter print_intf_import crcs let print_cmt_infos cmt = let open Cmt_format in - printf "Cmt unit name: %s\n" cmt.cmt_modname; + printf "Cmt unit name: %a\n" Compilation_unit.output cmt.cmt_modname; print_string "Cmt interfaces imported:\n"; - List.iter print_name_crc cmt.cmt_imports; + Array.iter print_intf_import cmt.cmt_imports; printf "Source file: %s\n" (match cmt.cmt_sourcefile with None -> "(none)" | Some f -> f); printf "Compilation flags:"; @@ -117,7 +130,13 @@ let print_cmt_infos cmt = printf "cmt interface digest: %s\n" (match cmt.cmt_interface_digest with | None -> "" - | Some crc -> string_of_crc crc) + | Some crc -> string_of_crc crc); + if !shape then begin + printf "Implementation shape: "; + (match cmt.cmt_impl_shape with + | None -> printf "(none)\n" + | Some shape -> Format.printf "\n%a" Shape.print shape) + end let linkage_name comp_unit = Symbol.for_compilation_unit comp_unit @@ -129,9 +148,9 @@ let print_general_infos name crc defines cmi cmx = printf "Globals defined:\n"; List.iter print_line (List.map linkage_name defines); printf "Interfaces imported:\n"; - List.iter print_name_crc cmi; + Array.iter print_intf_import cmi; printf "Implementations imported:\n"; - List.iter print_name_crc cmx + Array.iter print_impl_import cmx let print_global_table table = printf "Globals defined:\n"; @@ -165,7 +184,7 @@ let print_cmx_infos (ui, crc) = else printf "Flambda unit\n"; if not !no_approx then begin - Compilation_unit.set_current ui.ui_unit; + Compilation_unit.set_current (Some ui.ui_unit); let root_symbols = List.map Symbol.for_compilation_unit ui.ui_defines in Format.printf "approximations@ %a@.@." Export_info.print_approx (export, root_symbols) @@ -198,7 +217,7 @@ let print_cmxs_infos header = List.iter (fun ui -> print_general_infos - (ui.dynu_name |> Compilation_unit.Name.to_string) + (ui.dynu_name |> Compilation_unit.full_path_as_string) ui.dynu_crc ui.dynu_defines ui.dynu_imports_cmi @@ -207,12 +226,6 @@ let print_cmxs_infos header = let p_title title = printf "%s:\n" title -let p_section title = function - | [] -> () - | l -> - p_title title; - List.iter print_name_crc l - let p_list title print = function | [] -> () | l -> @@ -229,9 +242,10 @@ let dump_byte ic = let len = Bytesections.seek_section ic section in if len > 0 then match section with | "CRCS" -> - p_section + p_list "Imported units" - (input_value ic : (string * Digest.t option) list) + print_intf_import + ((input_value ic : Import_info.t array) |> Array.to_list) | "DLLS" -> p_list "Used DLLs" @@ -394,6 +408,8 @@ let arg_list = [ " Do not print module approximation information"; "-no-code", Arg.Set no_code, " Do not print code from exported flambda functions"; + "-shape", Arg.Set shape, + " Print the shape of the module"; "-null-crc", Arg.Set no_crc, " Print a null CRC for imported interfaces"; "-args", Arg.Expand Arg.read_arg, " Read additional newline separated command line arguments \n\ diff --git a/ocaml/tools/ocamlcmt.ml b/ocaml/tools/ocamlcmt.ml index 73057bd3fa4..727fcef2df4 100644 --- a/ocaml/tools/ocamlcmt.ml +++ b/ocaml/tools/ocamlcmt.ml @@ -51,7 +51,7 @@ let print_info cmt = | Some filename -> open_out filename in let open Cmt_format in - Printf.fprintf oc "module name: %s\n" cmt.cmt_modname; + Printf.fprintf oc "module name: %a\n" Compilation_unit.output cmt.cmt_modname; begin match cmt.cmt_annots with Packed (_, list) -> Printf.fprintf oc "pack: %s\n" (String.concat " " list) @@ -82,14 +82,26 @@ let print_info cmt = | Some digest -> Printf.fprintf oc "interface digest: %s\n" (Digest.to_hex digest); end; + let compare_imports (name1, _crco1) (name2, _crco2) = + Compilation_unit.Name.compare name1 name2 + in + let imports = + let imports = + Array.map (fun import -> + Import_info.name import, Import_info.crc_with_unit import) + cmt.cmt_imports + in + Array.sort compare_imports imports; + Array.to_list imports + in List.iter (fun (name, crco) -> let crc = match crco with None -> dummy_crc - | Some crc -> Digest.to_hex crc + | Some (_unit, crc) -> Digest.to_hex crc in - Printf.fprintf oc "import: %s %s\n" name crc; - ) (List.sort compare cmt.cmt_imports); + Printf.fprintf oc "import: %a %s\n" Compilation_unit.Name.output name crc; + ) imports; Printf.fprintf oc "%!"; begin match !target_filename with | None -> () diff --git a/ocaml/tools/ocamlmklib.ml b/ocaml/tools/ocamlmklib.ml index d5bb84cac82..1cf8ef919f4 100644 --- a/ocaml/tools/ocamlmklib.ml +++ b/ocaml/tools/ocamlmklib.ml @@ -14,7 +14,6 @@ (**************************************************************************) open Printf -open Ocamlmklibconfig let syslib x = if Config.ccomp_type = "msvc" then x ^ ".lib" else "-l" ^ x @@ -26,15 +25,13 @@ let mklib out files opts = then "-machine:AMD64 " else "" in - Printf.sprintf "link -lib -nologo %s-out:%s %s %s" - machine out opts files - else Printf.sprintf "%s rcs %s %s %s && %s %s" - Config.ar out opts files Config.ranlib out + Printf.sprintf "link -lib -nologo %s-out:%s %s %s" machine out opts files + else Printf.sprintf "%s rcs %s %s %s" Config.ar out opts files (* PR#4783: under Windows, don't use absolute paths because we do not know where the binary distribution will be installed. *) let compiler_path name = - if Sys.os_type = "Win32" then name else Filename.concat bindir name + if Sys.os_type = "Win32" then name else Filename.concat Config.bindir name let bytecode_objs = ref [] (* .cmo,.cma,.ml,.mli files to pass to ocamlc *) and native_objs = ref [] (* .cmx,.ml,.mli files to pass to ocamlopt *) @@ -42,7 +39,7 @@ and c_objs = ref [] (* .o, .a, .obj, .lib, .dll, .dylib, .so files to pass to mksharedlib and ar *) and caml_libs = ref [] (* -cclib to pass to ocamlc, ocamlopt *) and caml_opts = ref [] (* -ccopt to pass to ocamlc, ocamlopt *) -and dynlink = ref supports_shared_libraries +and dynlink = ref Config.supports_shared_libraries and failsafe = ref false (* whether to fall back on static build only *) and c_libs = ref [] (* libs to pass to mksharedlib and ocamlc -cclib *) and c_Lopts = ref [] (* options to pass to mksharedlib and ocamlc -cclib *) @@ -304,7 +301,7 @@ let build_libs () = (String.concat " " !c_objs) (String.concat " " !c_opts) (String.concat " " !ld_opts) - (make_rpath mksharedlibrpath) + (make_rpath Config.mksharedlibrpath) (String.concat " " !c_libs) (String.concat " " flexdll_dirs) ) @@ -330,7 +327,7 @@ let build_libs () = (Filename.basename !output_c) (Filename.basename !output_c) (String.concat " " (prefix_list "-ccopt " !c_opts)) - (make_rpath_ccopt default_rpath) + (make_rpath_ccopt Config.default_rpath) (String.concat " " (prefix_list "-cclib " !c_libs)) (String.concat " " !caml_libs)); if !native_objs <> [] then @@ -344,7 +341,7 @@ let build_libs () = (String.concat " " !native_objs) (Filename.basename !output_c) (String.concat " " (prefix_list "-ccopt " !c_opts)) - (make_rpath_ccopt default_rpath) + (make_rpath_ccopt Config.default_rpath) (String.concat " " (prefix_list "-cclib " !c_libs)) (String.concat " " !caml_libs)) diff --git a/ocaml/tools/ocamlprof.ml b/ocaml/tools/ocamlprof.ml index 0eed5442541..08026a738a4 100644 --- a/ocaml/tools/ocamlprof.ml +++ b/ocaml/tools/ocamlprof.ml @@ -43,7 +43,7 @@ let copy_buffer = Bytes.create 256 let copy_chars_unix nchars = let n = ref nchars in while !n > 0 do - let m = input !inchan copy_buffer 0 (min !n 256) in + let m = input !inchan copy_buffer 0 (Int.min !n 256) in if m = 0 then raise End_of_file; output !outchan copy_buffer 0 m; n := !n - m @@ -494,7 +494,7 @@ let print_version_num () = let main () = try - Warnings.parse_options false "a"; + Option.iter Location.(prerr_alert none) @@ Warnings.parse_options false "a"; Arg.parse_expand [ "-f", Arg.String (fun s -> dumpfile := s), " Use as dump file (default ocamlprof.dump)"; diff --git a/ocaml/tools/pre-commit-githook b/ocaml/tools/pre-commit-githook index dcb6f90f816..5b044373fc7 100755 --- a/ocaml/tools/pre-commit-githook +++ b/ocaml/tools/pre-commit-githook @@ -15,7 +15,7 @@ # Bump this on any changes. It's vital that HOOK_VERSION followed by equals # appears nowhere else in these sources! -HOOK_VERSION=4 +HOOK_VERSION=6 # For what it's worth, allow for empty trees! if git rev-parse --verify HEAD >/dev/null 2>&1 @@ -73,13 +73,122 @@ not_pruned () { } # Now run check-typo over all the files in the index -ERRORS=0 +STATUS=0 export OCAML_CT_PREFIX=: export OCAML_CT_CAT="git cat-file --textconv" export OCAML_CT_CA_FLAG=--cached -git diff --diff-filter=d --staged --name-only | (while IFS= read -r path +while IFS= read -r path do if not_pruned "$path" && ! tools/check-typo "./$path" ; then - ERRORS=1 + STATUS=1 fi -done; exit $ERRORS) +done < <(git diff --diff-filter=d --staged --name-only) + +# If any files affecting the generation of configure have been updated, test +# whether the index includes an up-to-date configure script. +# See also tools/ci/actions/check-configure.sh + +AUTOCONF_FILES=\ +'configure configure.ac aclocal.m4 build-aux/* '\ +'tools/autogen tools/git-dev-options.sh' + +# Convert $AUTOCONF_FILES to a BRE +PATHS="${AUTOCONF_FILES//./\\.}" +PATHS="${PATHS//\*/.*}" +PATHS="${PATHS// /\\|}" + +OVERRIDE_MESSAGE='(you can override githooks with git-commit --no-verify)' +WRONG_AUTOCONF=0 + +if git diff --diff-filter=d --staged --name-only | grep -qx "$PATHS" ; then + # Get the AC_PREREQ line in configure.ac for the required autoconf version + PREREQ="$(git cat-file --textconv :configure.ac \ + | sed -ne 's/^AC_PREREQ(\[\(.*\)\])/\1/p')" + if [[ -z $PREREQ ]]; then + echo 'Unable to find/parse the AC_PREREQ macro in configure.ac' + echo 'This line should be of the form AC_PREREQ([2.69])' + echo '(with no whitespace or comment)' + STATUS=1 + else + # Check for autoconf and its version + AUTOCONF_TOOL='autoconf' + # Check version of autoconf + set -o pipefail + AUTOCONF_VERSION="$($AUTOCONF_TOOL --version 2>/dev/null | head -n 1)" + if [[ $? -ne 0 ]]; then + echo 'Files affecting configure updated, but autoconf not found' + echo 'Unable to verify that configure is up-to-date' + echo "$OVERRIDE_MESSAGE" + STATUS=1 + else + AUTOCONF_VERSION="${AUTOCONF_VERSION##* }" + if [[ $AUTOCONF_VERSION != $PREREQ ]]; then + # Found autoconf, but it's the wrong version. If it's older, + # tools/autogen will fail. If it's newer, it may succeed, but CI may + # fail. autoconf is frequently available at an exact version, so try + # the two known names for it. + for tool in $AUTOCONF_TOOL-$PREREQ $AUTOCONF_TOOL$PREREQ; do + VERSION="$($tool --version 2>/dev/null | head -n 1)" + if [[ $? -eq 0 ]]; then + VERSION="${VERSION##* }" + if [[ $VERSION != $PREREQ ]]; then + continue + fi + else + continue + fi + echo "autoconf has version $AUTOCONF_VERSION; using $tool instead" + AUTOCONF_TOOL="$tool" + AUTOCONF_VERSION="$VERSION" + break + done + fi + + if [[ $AUTOCONF_VERSION != $PREREQ ]]; then + # We're using the wrong version of autoconf: if all other tests succeed, + # display a warning that CI may complain (CI uses the version specified + # by AC_PREREQ). + WRONG_AUTOCONF=1 + fi + + # Checkout the relevant files from the index to a temporary directory to + # test them. + BUILD_DIR="$(mktemp -d)" + BUILD_DIR="${BUILD_DIR%%/}/" + if [[ -z $BUILD_DIR ]]; then + echo 'Unable to create a temporary directory to test configure.ac' + STATUS=1 + else + git checkout-index --prefix "$BUILD_DIR" -- $AUTOCONF_FILES + pushd "$BUILD_DIR" > /dev/null + mkdir -p a b + mv configure a/ + echo 'Regenerating configure...' + if tools/autogen "$AUTOCONF_TOOL"; then + mv configure b/ + if diff a/configure b/configure > /dev/null; then + if ((WRONG_AUTOCONF)); then + echo '*** Warning! configure.ac generates the configure script' + echo "*** However, this is using autoconf $AUTOCONF_VERSION" + echo "*** configure.ac requires autoconf $PREREQ; the CI check on" + echo '*** GitHub may fail.' + fi + else + echo 'configure.ac does not appear to generate configure' + echo 'Try running make -B configure and stage the changes' + echo "$OVERRIDE_MESSAGE" + git diff --text --no-index a b + STATUS=1 + fi + else + echo 'tools/autogen failed' + STATUS=1 + fi + popd > /dev/null + rm -rf "$BUILD_DIR" + fi + fi + fi +fi + +exit $STATUS diff --git a/ocaml/tools/sync_stdlib_docs b/ocaml/tools/sync_stdlib_docs index edf50a2aed7..083c6f0fb7d 100755 --- a/ocaml/tools/sync_stdlib_docs +++ b/ocaml/tools/sync_stdlib_docs @@ -32,7 +32,7 @@ LABLABREGEX="s/\([a-z_]+:([a-z\('])/\(\1/g" #Remove a tilde if it is followed by a label name and a space or closing #OCamldoc code section with ] -TILDEREGEX="s/~([a-z_]+[ \]])/\1/g" +TILDEREGEX="s/ ~([a-z_]+(?=[ \]]))/ \1/g" #Indent a non-blank line by two characters, for moreLabels templates INDENTREGEX="s/^(.+)$/ \1/m" diff --git a/ocaml/toplevel/byte/dune b/ocaml/toplevel/byte/dune new file mode 100644 index 00000000000..74081308086 --- /dev/null +++ b/ocaml/toplevel/byte/dune @@ -0,0 +1,128 @@ +;************************************************************************** +;* * +;* OCaml * +;* * +;* Thomas Refis, Jane Street Europe * +;* * +;* Copyright 2018 Jane Street Group LLC * +;* * +;* All rights reserved. This file is distributed under the terms of * +;* the GNU Lesser General Public License version 2.1, with the * +;* special exception on linking described in the file LICENSE. * +;* * +;************************************************************************** + +(copy_files# ../*.ml*) + +(library + (name ocamltoplevel) + (wrapped false) + (modes byte) + (flags (:standard -principal)) + (libraries ocamlcommon ocamlbytecomp) + (modules :standard \ topstart expunge)) + +(rule + (targets bytetop) + ; This should be generated from the stdlib modules files + (action (run %{ocaml_where}/../../bin/ocamlrun %{exe:../expunge.bc} %{dep:../topstart.bc} %{targets} + stdlib__Arg + stdlib__Array + stdlib__ArrayLabels + stdlib__Bigarray + stdlib__Bool + stdlib__Buffer + stdlib__Bytes + stdlib__BytesLabels + stdlib__Callback + camlinternalFormat + camlinternalFormatBasics + camlinternalLazy + camlinternalMod + camlinternalComprehension + camlinternalOO + camlinternalAtomic + stdlib__Char + stdlib__Complex + stdlib__Digest + stdlib__Either + stdlib__Ephemeron + stdlib__Filename + stdlib__Float + stdlib__Format + stdlib__Fun + stdlib__Gc + stdlib__Genlex + stdlib__Hashtbl + stdlib__Int + stdlib__Int32 + stdlib__Int64 + stdlib__Lazy + stdlib__Lexing + stdlib__List + stdlib__ListLabels + stdlib__Map + stdlib__Marshal + stdlib__MoreLabels + stdlib__Nativeint + stdlib__Obj + stdlib__Oo + stdlib__Option + stdlib__Parsing + stdlib__Pervasives + stdlib__Printexc + stdlib__Printf + stdlib__Queue + stdlib__Random + stdlib__Result + stdlib__Scanf + stdlib__Seq + stdlib__Set + stdlib__Stack + stdlib__StdLabels + stdlib + stdlib__Stream + stdlib__String + stdlib__StringLabels + stdlib__Sys + stdlib__Uchar + stdlib__Unit + stdlib__Weak + ; the rest + outcometree topdirs topeval toploop topmain topcommon + ))) + +(install + (files + (bytetop as ocaml) + ) + (section bin) + (package ocaml)) + + +(install + (files + (ocamltoplevel.cma as compiler-libs/ocamltoplevel.cma) + (genprintval.mli as compiler-libs/genprintval.mli) + (trace.mli as compiler-libs/trace.mli) + (topdirs.mli as compiler-libs/topdirs.mli) + (toploop.mli as compiler-libs/toploop.mli) + (topmain.mli as compiler-libs/topmain.mli) + (.ocamltoplevel.objs/byte/genprintval.cmi as compiler-libs/genprintval.cmi) + (.ocamltoplevel.objs/byte/genprintval.cmt as compiler-libs/genprintval.cmt) + (.ocamltoplevel.objs/byte/genprintval.cmti as compiler-libs/genprintval.cmti) + (.ocamltoplevel.objs/byte/trace.cmi as compiler-libs/trace.cmi) + (.ocamltoplevel.objs/byte/trace.cmt as compiler-libs/trace.cmt) + (.ocamltoplevel.objs/byte/trace.cmti as compiler-libs/trace.cmti) + (.ocamltoplevel.objs/byte/topdirs.cmi as compiler-libs/topdirs.cmi) + (.ocamltoplevel.objs/byte/topdirs.cmt as compiler-libs/topdirs.cmt) + (.ocamltoplevel.objs/byte/topdirs.cmti as compiler-libs/topdirs.cmti) + (.ocamltoplevel.objs/byte/toploop.cmi as compiler-libs/toploop.cmi) + (.ocamltoplevel.objs/byte/toploop.cmt as compiler-libs/toploop.cmt) + (.ocamltoplevel.objs/byte/toploop.cmti as compiler-libs/toploop.cmti) + (.ocamltoplevel.objs/byte/topmain.cmi as compiler-libs/topmain.cmi) + (.ocamltoplevel.objs/byte/topmain.cmt as compiler-libs/topmain.cmt) + (.ocamltoplevel.objs/byte/topmain.cmti as compiler-libs/topmain.cmti) + ) + (section lib) + (package ocaml)) diff --git a/ocaml/toplevel/byte/topeval.ml b/ocaml/toplevel/byte/topeval.ml new file mode 100644 index 00000000000..73ea933a6ba --- /dev/null +++ b/ocaml/toplevel/byte/topeval.ml @@ -0,0 +1,302 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* The interactive toplevel loop *) + +#18 "ocaml/toplevel/byte/topeval.ml" + +open Format +open Misc +open Parsetree +open Types +open Typedtree +open Outcometree +open Topcommon +module String = Misc.Stdlib.String + +(* The table of toplevel value bindings and its accessors *) + +let toplevel_value_bindings : Obj.t String.Map.t ref = ref String.Map.empty + +let getvalue name = + try + String.Map.find name !toplevel_value_bindings + with Not_found -> + fatal_error (name ^ " unbound at toplevel") + +let setvalue name v = + toplevel_value_bindings := String.Map.add name v !toplevel_value_bindings + +let implementation_label = "" + +(* To print values *) + +module EvalBase = struct + + let eval_compilation_unit cu = + try + Symtable.get_global_value + (cu |> Compilation_unit.to_global_ident_for_bytecode) + with Symtable.Error (Undefined_global name) -> + raise (Undefined_global name) + + let eval_ident id = + let name = Translmod.toplevel_name id in + try + String.Map.find name !toplevel_value_bindings + with Not_found -> + raise (Undefined_global name) + +end + +include Topcommon.MakeEvalPrinter(EvalBase) + +(* Load in-core and execute a lambda term *) + +let may_trace = ref false (* Global lock on tracing *) + +let load_lambda ppf lam = + if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam; + let slam = Simplif.simplify_lambda lam in + if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam; + let (init_code, fun_code) = Bytegen.compile_phrase slam in + if !Clflags.dump_instr then + fprintf ppf "%a%a@." + Printinstr.instrlist init_code + Printinstr.instrlist fun_code; + let (code, reloc, events) = + Emitcode.to_memory init_code fun_code + in + let can_free = (fun_code = []) in + let initial_symtable = Symtable.current_state() in + Symtable.patch_object code reloc; + Symtable.check_global_initialized reloc; + Symtable.update_global_table(); + let initial_bindings = !toplevel_value_bindings in + let bytecode, closure = Meta.reify_bytecode code [| events |] None in + match + may_trace := true; + Fun.protect + ~finally:(fun () -> may_trace := false; + if can_free then Meta.release_bytecode bytecode) + closure + with + | retval -> Result retval + | exception x -> + record_backtrace (); + toplevel_value_bindings := initial_bindings; (* PR#6211 *) + Symtable.restore_state initial_symtable; + Exception x + +(* Print the outcome of an evaluation *) + +let pr_item = + Printtyp.print_items + (fun env -> function + | Sig_value(id, {val_kind = Val_reg; val_type}, _) -> + Some (outval_of_value env (getvalue (Translmod.toplevel_name id)) + val_type) + | _ -> None + ) + +(* Execute a toplevel phrase *) + +let execute_phrase print_outcome ppf phr = + match phr with + | Ptop_def sstr -> + let oldenv = !toplevel_env in + let oldsig = !toplevel_sig in + Typecore.reset_delayed_checks (); + let (str, sg, sn, shape, newenv) = + Typemod.type_toplevel_phrase oldenv oldsig sstr + in + if !Clflags.dump_typedtree then Printtyped.implementation ppf str; + let sg' = Typemod.Signature_names.simplify newenv sn sg in + ignore (Includemod.signatures ~mark:Mark_positive oldenv sg sg'); + Typecore.force_delayed_checks (); + let shape = Shape.local_reduce shape in + if !Clflags.dump_shape then Shape.print ppf shape; + let lam = Translmod.transl_toplevel_definition str in + Warnings.check_fatal (); + begin try + toplevel_env := newenv; + toplevel_sig := List.rev_append sg' oldsig; + let res = load_lambda ppf lam in + let out_phr = + match res with + | Result v -> + if print_outcome then + Printtyp.wrap_printing_env ~error:false oldenv (fun () -> + match str.str_items with + | [] -> Ophr_signature [] + | _ -> + match find_eval_phrase str with + | Some (exp, _, _) -> + let outv = outval_of_value newenv v exp.exp_type in + let ty = Printtyp.tree_of_type_scheme exp.exp_type in + Ophr_eval (outv, ty) + | None -> Ophr_signature (pr_item oldenv sg')) + else Ophr_signature [] + | Exception exn -> + toplevel_env := oldenv; + toplevel_sig := oldsig; + if exn = Out_of_memory then Gc.full_major(); + let outv = + outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn + in + Ophr_exception (exn, outv) + in + !print_out_phrase ppf out_phr; + if Printexc.backtrace_status () + then begin + match !backtrace with + | None -> () + | Some b -> + pp_print_string ppf b; + pp_print_flush ppf (); + backtrace := None; + end; + begin match out_phr with + | Ophr_eval (_, _) | Ophr_signature _ -> true + | Ophr_exception _ -> false + end + with x -> + toplevel_env := oldenv; toplevel_sig := oldsig; raise x + end + | Ptop_dir {pdir_name = {Location.txt = dir_name}; pdir_arg } -> + try_run_directive ppf dir_name pdir_arg + +let execute_phrase print_outcome ppf phr = + try execute_phrase print_outcome ppf phr + with exn -> + Warnings.reset_fatal (); + raise exn + + +(* Additional directives for the bytecode toplevel only *) + +open Cmo_format + +(* Loading files *) + +exception Load_failed + +let check_consistency ppf filename cu = + try Env.import_crcs ~source:filename cu.cu_imports + with Persistent_env.Consistbl.Inconsistency { + unit_name = name; + inconsistent_source = user; + original_source = auth; + } -> + fprintf ppf "@[The files %s@ and %s@ \ + disagree over interface %a@]@." + user auth Compilation_unit.Name.print name; + raise Load_failed + +(* This is basically Dynlink.Bytecode.run with no digest *) +let load_compunit ic filename ppf compunit = + check_consistency ppf filename compunit; + seek_in ic compunit.cu_pos; + let code_size = compunit.cu_codesize + 8 in + let code = LongString.create code_size in + LongString.input_bytes_into code ic compunit.cu_codesize; + LongString.set code compunit.cu_codesize (Char.chr Opcodes.opRETURN); + LongString.blit_string "\000\000\000\001\000\000\000" 0 + code (compunit.cu_codesize + 1) 7; + let initial_symtable = Symtable.current_state() in + Symtable.patch_object code compunit.cu_reloc; + Symtable.update_global_table(); + let events = + if compunit.cu_debug = 0 then [| |] + else begin + seek_in ic compunit.cu_debug; + [| input_value ic |] + end in + begin try + may_trace := true; + let _bytecode, closure = Meta.reify_bytecode code events None in + ignore (closure ()); + may_trace := false; + with exn -> + record_backtrace (); + may_trace := false; + Symtable.restore_state initial_symtable; + print_exception_outcome ppf exn; + raise Load_failed + end + +let rec load_file recursive ppf name = + let filename = + try Some (Load_path.find name) with Not_found -> None + in + match filename with + | None -> fprintf ppf "Cannot find file %s.@." name; false + | Some filename -> + let ic = open_in_bin filename in + Misc.try_finally + ~always:(fun () -> close_in ic) + (fun () -> really_load_file recursive ppf name filename ic) + +and really_load_file recursive ppf name filename ic = + let buffer = really_input_string ic (String.length Config.cmo_magic_number) in + try + if buffer = Config.cmo_magic_number then begin + let compunit_pos = input_binary_int ic in (* Go to descriptor *) + seek_in ic compunit_pos; + let cu : compilation_unit_descr = input_value ic in + if recursive then + List.iter + (function + | (Reloc_getglobal id, _) + when not (Symtable.is_global_defined id) -> + let file = Ident.name id ^ ".cmo" in + begin match Load_path.find_uncap file with + | exception Not_found -> () + | file -> + if not (load_file recursive ppf file) then raise Load_failed + end + | _ -> () + ) + cu.cu_reloc; + load_compunit ic filename ppf cu; + true + end else + if buffer = Config.cma_magic_number then begin + let toc_pos = input_binary_int ic in (* Go to table of contents *) + seek_in ic toc_pos; + let lib = (input_value ic : library) in + List.iter + (fun dllib -> + let name = Dll.extract_dll_name dllib in + try Dll.open_dlls Dll.For_execution [name] + with Failure reason -> + fprintf ppf + "Cannot load required shared library %s.@.Reason: %s.@." + name reason; + raise Load_failed) + lib.lib_dllibs; + List.iter (load_compunit ic filename ppf) lib.lib_units; + true + end else begin + fprintf ppf "File %s is not a bytecode object file.@." name; + false + end + with Load_failed -> false + +let init () = + let crc_intfs = Symtable.init_toplevel() in + Compmisc.init_path (); + Env.import_crcs ~source:Sys.executable_name crc_intfs; + () diff --git a/ocaml/toplevel/byte/topmain.ml b/ocaml/toplevel/byte/topmain.ml new file mode 100644 index 00000000000..15a4000f98d --- /dev/null +++ b/ocaml/toplevel/byte/topmain.ml @@ -0,0 +1,226 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + +(* The trace *) + +open Trace + +external current_environment: unit -> Obj.t = "caml_get_current_environment" + +let tracing_function_ptr = + get_code_pointer + (Obj.repr (fun arg -> Trace.print_trace (current_environment()) arg)) + +let dir_trace ppf lid = + match Env.find_value_by_name lid !Topcommon.toplevel_env with + | (path, desc) -> begin + (* Check if this is a primitive *) + match desc.val_kind with + | Val_prim _ -> + Format.fprintf ppf + "%a is an external function and cannot be traced.@." + Printtyp.longident lid + | _ -> + let clos = Toploop.eval_value_path !Topcommon.toplevel_env path in + (* Nothing to do if it's not a closure *) + if Obj.is_block clos + && (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag) + && (match + Types.get_desc + (Ctype.expand_head !Topcommon.toplevel_env desc.val_type) + with Tarrow _ -> true | _ -> false) + then begin + match is_traced clos with + | Some opath -> + Format.fprintf ppf "%a is already traced (under the name %a).@." + Printtyp.path path + Printtyp.path opath + | None -> + (* Instrument the old closure *) + traced_functions := + { path = path; + closure = clos; + actual_code = get_code_pointer clos; + instrumented_fun = + instrument_closure + !Topcommon.toplevel_env lid ppf desc.val_type } + :: !traced_functions; + (* Redirect the code field of the closure to point + to the instrumentation function *) + set_code_pointer clos tracing_function_ptr; + Format.fprintf ppf "%a is now traced.@." Printtyp.longident lid + end else + Format.fprintf ppf "%a is not a function.@." Printtyp.longident lid + end + | exception Not_found -> + Format.fprintf ppf "Unbound value %a.@." Printtyp.longident lid + +let dir_untrace ppf lid = + match Env.find_value_by_name lid !Topcommon.toplevel_env with + | (path, _desc) -> + let rec remove = function + | [] -> + Format.fprintf ppf "%a was not traced.@." Printtyp.longident lid; + [] + | f :: rem -> + if Path.same f.path path then begin + set_code_pointer f.closure f.actual_code; + Format.fprintf ppf "%a is no longer traced.@." + Printtyp.longident lid; + rem + end else f :: remove rem in + traced_functions := remove !traced_functions + | exception Not_found -> + Format.fprintf ppf "Unbound value %a.@." Printtyp.longident lid + +let dir_untrace_all ppf () = + List.iter + (fun f -> + set_code_pointer f.closure f.actual_code; + Format.fprintf ppf "%a is no longer traced.@." Printtyp.path f.path) + !traced_functions; + traced_functions := [] + +let _ = Topcommon.add_directive "trace" + (Directive_ident (dir_trace Format.std_formatter)) + { + section = Topdirs.section_trace; + doc = "All calls to the function \ + named function-name will be traced."; + } + +let _ = Topcommon.add_directive "untrace" + (Directive_ident (dir_untrace Format.std_formatter)) + { + section = Topdirs.section_trace; + doc = "Stop tracing the given function."; + } + +let _ = Topcommon.add_directive "untrace_all" + (Directive_none (dir_untrace_all Format.std_formatter)) + { + section = Topdirs.section_trace; + doc = "Stop tracing all functions traced so far."; + } + + +(* --- *) + + +let preload_objects = ref [] + +(* Position of the first non expanded argument *) +let first_nonexpanded_pos = ref 0 + +let current = ref (!Arg.current) + +let argv = ref Sys.argv + +(* Test whether the option is part of a responsefile *) +let is_expanded pos = pos < !first_nonexpanded_pos + +let expand_position pos len = + if pos < !first_nonexpanded_pos then + (* Shift the position *) + first_nonexpanded_pos := !first_nonexpanded_pos + len + else + (* New last position *) + first_nonexpanded_pos := pos + len + 2 + +let prepare ppf = + Topcommon.set_paths (); + try + let res = + let objects = + List.rev (!preload_objects @ !Compenv.first_objfiles) + in + List.for_all (Topeval.load_file false ppf) objects + in + Topcommon.run_hooks Topcommon.Startup; + res + with x -> + try Location.report_exception ppf x; false + with x -> + Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x); + false + +let input_argument name = + let filename = Toploop.filename_of_input name in + let ppf = Format.err_formatter in + if Filename.check_suffix filename ".cmo" + || Filename.check_suffix filename ".cma" + then preload_objects := filename :: !preload_objects + else if is_expanded !current then begin + (* Script files are not allowed in expand options because otherwise the + check in override arguments may fail since the new argv can be larger + than the original argv. + *) + Printf.eprintf "For implementation reasons, the toplevel does not support\ + \ having script files (here %S) inside expanded arguments passed through the\ + \ -args{,0} command-line option.\n" filename; + raise (Compenv.Exit_with_status 2) + end else begin + let newargs = Array.sub !argv !current + (Array.length !argv - !current) + in + Compenv.readenv ppf Before_link; + Compmisc.read_clflags_from_env (); + if prepare ppf && Toploop.run_script ppf name newargs + then raise (Compenv.Exit_with_status 0) + else raise (Compenv.Exit_with_status 2) + end + +let file_argument x = input_argument (Toploop.File x) + +let wrap_expand f s = + let start = !current in + let arr = f s in + expand_position start (Array.length arr); + arr + +module Options = Main_args.Make_bytetop_options (struct + include Main_args.Default.Topmain + let _stdin () = input_argument Toploop.Stdin + let _args = wrap_expand Arg.read_arg + let _args0 = wrap_expand Arg.read_arg0 + let anonymous s = file_argument s + let _eval s = input_argument (Toploop.String s) +end) + +let () = + let extra_paths = + match Sys.getenv "OCAMLTOP_INCLUDE_PATH" with + | exception Not_found -> [] + | s -> Misc.split_path_contents s + in + Clflags.include_dirs := List.rev_append extra_paths !Clflags.include_dirs + +let main () = + let ppf = Format.err_formatter in + let program = "ocaml" in + Compenv.readenv ppf Before_args; + Clflags.add_arguments __LOC__ Options.list; + Compenv.parse_arguments ~current argv file_argument program; + Compenv.readenv ppf Before_link; + Compmisc.read_clflags_from_env (); + if not (prepare ppf) then raise (Compenv.Exit_with_status 2); + Compmisc.init_path (); + Toploop.loop Format.std_formatter + +let main () = + match main () with + | exception Compenv.Exit_with_status n -> n + | () -> 0 diff --git a/ocaml/toplevel/trace.ml b/ocaml/toplevel/byte/trace.ml similarity index 97% rename from ocaml/toplevel/trace.ml rename to ocaml/toplevel/byte/trace.ml index 335d64f2a19..ec8bbb6b0d0 100644 --- a/ocaml/toplevel/trace.ml +++ b/ocaml/toplevel/byte/trace.ml @@ -19,7 +19,8 @@ open Format open Misc open Longident open Types -open Toploop +open Topeval +open Topcommon type codeptr = Obj.raw_data @@ -65,7 +66,7 @@ let print_label ppf l = (* If a function returns a functional value, wrap it into a trace code *) let rec instrument_result env name ppf clos_typ = - match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with + match get_desc (Ctype.expand_head env clos_typ) with | Tarrow((l,_,_), t1, t2, _) -> let starred_name = match name with @@ -108,7 +109,7 @@ exception Dummy let _ = Dummy let instrument_closure env name ppf clos_typ = - match (Ctype.repr(Ctype.expand_head env clos_typ)).desc with + match get_desc (Ctype.expand_head env clos_typ) with | Tarrow((l,_,_), t1, t2, _) -> let trace_res = instrument_result env name ppf t2 in (fun actual_code closure arg -> diff --git a/ocaml/toplevel/dune b/ocaml/toplevel/dune index 5eeb5b8f74e..3d6ba57ef16 100644 --- a/ocaml/toplevel/dune +++ b/ocaml/toplevel/dune @@ -12,14 +12,6 @@ ;* * ;************************************************************************** -(library - (name ocamltoplevel) - (wrapped false) - (modes byte) - (flags (:standard -principal)) - (libraries ocamlcommon ocamlbytecomp) - (modules genprintval toploop trace topdirs topmain)) - (executable (name topstart) (modes byte) @@ -34,109 +26,11 @@ (libraries ocamlbytecomp ocamlcommon) (modules expunge)) -(rule - (targets byte) - ; This should be generated from the stdlib modules files - (action (run %{ocaml_where}/../../bin/ocamlrun %{exe:expunge.bc} %{dep:topstart.bc} %{targets} - stdlib__Arg - stdlib__Array - stdlib__ArrayLabels - stdlib__Bigarray - stdlib__Bool - stdlib__Buffer - stdlib__Bytes - stdlib__BytesLabels - stdlib__Callback - camlinternalFormat - camlinternalFormatBasics - camlinternalLazy - camlinternalMod - camlinternalComprehension - camlinternalOO - camlinternalAtomic - stdlib__Char - stdlib__Complex - stdlib__Digest - stdlib__Either - stdlib__Ephemeron - stdlib__Filename - stdlib__Float - stdlib__Format - stdlib__Fun - stdlib__Gc - stdlib__Genlex - stdlib__Hashtbl - stdlib__Int - stdlib__Int32 - stdlib__Int64 - stdlib__Lazy - stdlib__Lexing - stdlib__List - stdlib__ListLabels - stdlib__Map - stdlib__Marshal - stdlib__MoreLabels - stdlib__Nativeint - stdlib__Obj - stdlib__Oo - stdlib__Option - stdlib__Parsing - stdlib__Pervasives - stdlib__Printexc - stdlib__Printf - stdlib__Queue - stdlib__Random - stdlib__Result - stdlib__Scanf - stdlib__Seq - stdlib__Set - stdlib__Stack - stdlib__StdLabels - stdlib - stdlib__Stream - stdlib__String - stdlib__StringLabels - stdlib__Sys - stdlib__Uchar - stdlib__Unit - stdlib__Weak - ; the rest - outcometree topdirs toploop - ))) - -(install - (files - (byte as ocaml) - ) - (section bin) - (package ocaml)) - (install (files (expunge.bc as expunge) (.expunge.eobjs/byte/expunge.cmi as compiler-libs/expunge.cmi) (.expunge.eobjs/byte/expunge.cmt as compiler-libs/expunge.cmt) - (ocamltoplevel.cma as compiler-libs/ocamltoplevel.cma) - (genprintval.mli as compiler-libs/genprintval.mli) - (trace.mli as compiler-libs/trace.mli) - (topdirs.mli as compiler-libs/topdirs.mli) - (toploop.mli as compiler-libs/toploop.mli) - (topmain.mli as compiler-libs/topmain.mli) - (.ocamltoplevel.objs/byte/genprintval.cmi as compiler-libs/genprintval.cmi) - (.ocamltoplevel.objs/byte/genprintval.cmt as compiler-libs/genprintval.cmt) - (.ocamltoplevel.objs/byte/genprintval.cmti as compiler-libs/genprintval.cmti) - (.ocamltoplevel.objs/byte/trace.cmi as compiler-libs/trace.cmi) - (.ocamltoplevel.objs/byte/trace.cmt as compiler-libs/trace.cmt) - (.ocamltoplevel.objs/byte/trace.cmti as compiler-libs/trace.cmti) - (.ocamltoplevel.objs/byte/topdirs.cmi as compiler-libs/topdirs.cmi) - (.ocamltoplevel.objs/byte/topdirs.cmt as compiler-libs/topdirs.cmt) - (.ocamltoplevel.objs/byte/topdirs.cmti as compiler-libs/topdirs.cmti) - (.ocamltoplevel.objs/byte/toploop.cmi as compiler-libs/toploop.cmi) - (.ocamltoplevel.objs/byte/toploop.cmt as compiler-libs/toploop.cmt) - (.ocamltoplevel.objs/byte/toploop.cmti as compiler-libs/toploop.cmti) - (.ocamltoplevel.objs/byte/topmain.cmi as compiler-libs/topmain.cmi) - (.ocamltoplevel.objs/byte/topmain.cmt as compiler-libs/topmain.cmt) - (.ocamltoplevel.objs/byte/topmain.cmti as compiler-libs/topmain.cmti) (.topstart.eobjs/byte/topstart.cmi as compiler-libs/topstart.cmi) (.topstart.eobjs/byte/topstart.cmo as compiler-libs/topstart.cmo) (.topstart.eobjs/byte/topstart.cmt as compiler-libs/topstart.cmt) diff --git a/ocaml/toplevel/expunge.ml b/ocaml/toplevel/expunge.ml index 22eb46f6737..56ba0ae57ba 100644 --- a/ocaml/toplevel/expunge.ml +++ b/ocaml/toplevel/expunge.ml @@ -36,7 +36,11 @@ let expunge_map tbl = Symtable.filter_global_map (fun id -> keep (Ident.name id)) tbl let expunge_crcs tbl = - List.filter (fun (unit, _crc) -> keep unit) tbl + Array.to_list tbl + |> List.filter + (fun import -> + keep (Import_info.name import |> Compilation_unit.Name.to_string)) + |> Array.of_list let main () = let input_name = Sys.argv.(1) in @@ -63,7 +67,7 @@ let main () = let global_map = (input_value ic : Symtable.global_map) in output_value oc (expunge_map global_map) | "CRCS" -> - let crcs = (input_value ic : (string * Digest.t option) list) in + let crcs = (input_value ic : Import_info.t array) in output_value oc (expunge_crcs crcs) | _ -> copy_file_chunk ic oc len diff --git a/ocaml/toplevel/genprintval.ml b/ocaml/toplevel/genprintval.ml index 29b8f48d2ca..548f1fd0b78 100644 --- a/ocaml/toplevel/genprintval.ml +++ b/ocaml/toplevel/genprintval.ml @@ -203,7 +203,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct Oide_ident name | Pdot(p, _s) -> if - match (find (Lident (Out_name.print name)) env).desc with + match get_desc (find (Lident (Out_name.print name)) env) with | Tconstr(ty_path', _, _) -> Path.same ty_path ty_path' | _ -> false | exception Not_found -> false @@ -215,12 +215,12 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct let tree_of_constr = tree_of_qualified (fun lid env -> - (Env.find_constructor_by_name lid env).cstr_res) + (Env.find_constructor_by_name lid env).cstr_res) and tree_of_label = tree_of_qualified (fun lid env -> - (Env.find_label_by_name lid env).lbl_res) + (Env.find_label_by_name lid env).lbl_res) (* An abstract type *) @@ -260,7 +260,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct try find_printer depth env ty obj with Not_found -> - match (Ctype.repr ty).desc with + match get_desc ty with | Tvar _ | Tunivar _ -> Oval_stuff "" | Tarrow _ -> @@ -385,8 +385,8 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct | {type_kind = Type_abstract; type_manifest = Some body} -> tree_of_val depth obj (instantiate_type env decl.type_params ty_list body) - | {type_kind = Type_variant constr_list; type_unboxed} -> - let unbx = type_unboxed.unboxed in + | {type_kind = Type_variant (constr_list,rep)} -> + let unbx = (rep = Variant_unboxed) in let tag = if unbx then Cstr_unboxed else if O.is_block obj @@ -397,7 +397,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct let type_params = match cd_res with Some t -> - begin match (Ctype.repr t).desc with + begin match get_desc t with Tconstr (_,params,_) -> params | _ -> assert false end @@ -446,14 +446,13 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct Oval_stuff "" end | Tvariant row -> - let row = Btype.row_repr row in if O.is_block obj then let tag : int = O.obj (O.field obj 0) in let rec find = function | (l, f) :: fields -> if Btype.hash_variant l = tag then - match Btype.row_field_repr f with - | Rpresent(Some ty) | Reither(_,[ty],_,_) -> + match row_field_repr f with + | Rpresent(Some ty) | Reither(_,[ty],_) -> let args = nest tree_of_val (depth - 1) (O.field obj 1) ty in @@ -461,7 +460,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct | _ -> find fields else find fields | [] -> Oval_stuff "" in - find row.row_fields + find (row_fields row) else let tag : int = O.obj obj in let rec find = function @@ -470,12 +469,10 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct Oval_variant (l, None) else find fields | [] -> Oval_stuff "" in - find row.row_fields + find (row_fields row) | Tobject (_, _) -> Oval_stuff "" - | Tsubst ty -> - tree_of_val (depth - 1) obj ty - | Tfield(_, _, _, _) | Tnil | Tlink _ -> + | Tsubst _ | Tfield(_, _, _, _) | Tnil | Tlink _ -> fatal_error "Printval.outval_of_value" | Tpoly (ty, _) -> tree_of_val (depth - 1) obj ty @@ -561,7 +558,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct if not (EVP.same_value slot (EVP.eval_address addr)) then raise Not_found; let type_params = - match (Ctype.repr cstr.cstr_res).desc with + match get_desc cstr.cstr_res with Tconstr (_,params,_) -> params | _ -> assert false @@ -584,17 +581,17 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct with Ctype.Cannot_apply -> abstract_type and instantiate_types env type_params ty_list args = - List.map (instantiate_type env type_params ty_list) args + List.map (fun (ty, _) -> instantiate_type env type_params ty_list ty) args and find_printer depth env ty = let rec find = function | [] -> raise Not_found | (_name, Simple (sch, printer)) :: remainder -> - if Ctype.moregeneral env false sch ty + if Ctype.is_moregeneral env false sch ty then printer else find remainder | (_name, Generic (path, fn)) :: remainder -> - begin match (Ctype.expand_head env ty).desc with + begin match get_desc (Ctype.expand_head env ty) with | Tconstr (p, args, _) when Path.same p path -> begin try apply_generic_printer path (fn depth) args with exn -> (fun _obj -> out_exn path exn) end diff --git a/ocaml/toplevel/native/dune b/ocaml/toplevel/native/dune new file mode 100644 index 00000000000..40e6dea42d4 --- /dev/null +++ b/ocaml/toplevel/native/dune @@ -0,0 +1,66 @@ +;************************************************************************** +;* * +;* OCaml * +;* * +;* Thomas Refis, Jane Street Europe * +;* * +;* Copyright 2018 Jane Street Group LLC * +;* * +;* All rights reserved. This file is distributed under the terms of * +;* the GNU Lesser General Public License version 2.1, with the * +;* special exception on linking described in the file LICENSE. * +;* * +;************************************************************************** + +; (copy_files# ../*.ml*) +; +; (library +; (name ocamltoplevel_native) +; (wrapped false) +; (modes native) +; (flags (:standard -principal)) +; (libraries ocamlcommon ocamloptcomp dynlink_internal) +; (modules :standard \ topstart expunge)) +; +; (executable +; (name topstart) +; (modes native) +; (flags (:standard -principal)) +; (modules topstart) +; (libraries ocamltoplevel_native)) +; +; (install +; (files +; (topstart.exe as ocamlnat) +; ) +; (section bin) +; (package ocaml)) +; +; +; (install +; (files +; (ocamltoplevel.cma as compiler-libs/ocamltoplevel.cma) +; (genprintval.mli as compiler-libs/genprintval.mli) +; (trace.mli as compiler-libs/trace.mli) +; (topdirs.mli as compiler-libs/topdirs.mli) +; (toploop.mli as compiler-libs/toploop.mli) +; (topmain.mli as compiler-libs/topmain.mli) +; (.ocamltoplevel.objs/byte/genprintval.cmi as compiler-libs/genprintval.cmi) +; (.ocamltoplevel.objs/byte/genprintval.cmt as compiler-libs/genprintval.cmt) +; (.ocamltoplevel.objs/byte/genprintval.cmti as compiler-libs/genprintval.cmti) +; (.ocamltoplevel.objs/byte/trace.cmi as compiler-libs/trace.cmi) +; (.ocamltoplevel.objs/byte/trace.cmt as compiler-libs/trace.cmt) +; (.ocamltoplevel.objs/byte/trace.cmti as compiler-libs/trace.cmti) +; (.ocamltoplevel.objs/byte/topdirs.cmi as compiler-libs/topdirs.cmi) +; (.ocamltoplevel.objs/byte/topdirs.cmt as compiler-libs/topdirs.cmt) +; (.ocamltoplevel.objs/byte/topdirs.cmti as compiler-libs/topdirs.cmti) +; (.ocamltoplevel.objs/byte/toploop.cmi as compiler-libs/toploop.cmi) +; (.ocamltoplevel.objs/byte/toploop.cmt as compiler-libs/toploop.cmt) +; (.ocamltoplevel.objs/byte/toploop.cmti as compiler-libs/toploop.cmti) +; (.ocamltoplevel.objs/byte/topmain.cmi as compiler-libs/topmain.cmi) +; (.ocamltoplevel.objs/byte/topmain.cmt as compiler-libs/topmain.cmt) +; (.ocamltoplevel.objs/byte/topmain.cmti as compiler-libs/topmain.cmti) +; ) +; (section lib) +; (package ocaml)) +; diff --git a/ocaml/toplevel/native/topeval.ml b/ocaml/toplevel/native/topeval.ml new file mode 100644 index 00000000000..56071bd004f --- /dev/null +++ b/ocaml/toplevel/native/topeval.ml @@ -0,0 +1,320 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* The interactive toplevel loop *) + +open Format +open Misc +open Parsetree +open Types +open Typedtree +open Outcometree +open Topcommon + +let implementation_label = "native toplevel" + +let global_symbol comp_unit = + let sym = + Symbol.for_compilation_unit comp_unit + |> Symbol.linkage_name + |> Linkage_name.to_string + in + match Tophooks.lookup sym with + | None -> + fatal_error ("Toploop.global_symbol " ^ + (Compilation_unit.full_path_as_string comp_unit)) + | Some obj -> obj + +let remembered = ref Ident.empty + +let rec remember phrase_name i = function + | [] -> () + | Sig_value (id, _, _) :: rest + | Sig_module (id, _, _, _, _) :: rest + | Sig_typext (id, _, _, _) :: rest + | Sig_class (id, _, _, _) :: rest -> + remembered := Ident.add id (phrase_name, i) !remembered; + remember phrase_name (succ i) rest + | _ :: rest -> remember phrase_name i rest + +let toplevel_value id = + try Ident.find_same id !remembered + with _ -> Misc.fatal_error @@ "Unknown ident: " ^ Ident.unique_name id + +let close_phrase lam = + let open Lambda in + Ident.Set.fold (fun id l -> + let glb, pos = toplevel_value id in + let glob = + Lprim (Pfield (pos, Reads_agree), + [Lprim (Pgetglobal glb, [], Loc_unknown)], + Loc_unknown) + in + Llet(Strict, Pgenval, id, glob, l) + ) (free_variables lam) lam + +let toplevel_value id = + let glob, pos = + if Config.flambda then toplevel_value id else Translmod.nat_toplevel_name id + in + (Obj.magic (global_symbol glob)).(pos) + +(* Return the value referred to by a path *) + +module EvalBase = struct + + let eval_compilation_unit cu = + try global_symbol cu + with _ -> + raise (Undefined_global (cu |> Compilation_unit.full_path_as_string)) + + let eval_ident id = + try toplevel_value id + with _ -> + raise (Undefined_global (Ident.name id)) + +end + +include Topcommon.MakeEvalPrinter(EvalBase) + +(* Load in-core and execute a lambda term *) + +let may_trace = ref false (* Global lock on tracing *) + +let load_lambda ppf ~compilation_unit ~required_globals phrase_name lam size = + if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam; + let slam = Simplif.simplify_lambda lam in + if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam; + + let program = + { Lambda. + code = slam; + main_module_block_size = size; + compilation_unit; + required_globals; + } + in + Tophooks.load ppf phrase_name program + +(* Print the outcome of an evaluation *) + +let pr_item = + Printtyp.print_items + (fun env -> function + | Sig_value(id, {val_kind = Val_reg; val_type}, _) -> + Some (outval_of_value env (toplevel_value id) val_type) + | _ -> None + ) + +(* Execute a toplevel phrase *) + +let phrase_seqid = ref 0 + +let name_expression ~loc ~attrs exp = + let name = "_$" in + let id = Ident.create_local name in + let vd = + { val_type = exp.exp_type; + val_kind = Val_reg; + val_loc = loc; + val_attributes = attrs; + val_uid = Uid.internal_not_actually_unique; } + in + let sg = [Sig_value(id, vd, Exported)] in + let pat = + { pat_desc = Tpat_var(id, mknoloc name); + pat_loc = loc; + pat_extra = []; + pat_type = exp.exp_type; + pat_env = exp.exp_env; + pat_mode = Value_mode.global; + pat_attributes = []; } + in + let vb = + { vb_pat = pat; + vb_expr = exp; + vb_attributes = attrs; + vb_loc = loc; } + in + let item = + { str_desc = Tstr_value(Nonrecursive, [vb]); + str_loc = loc; + str_env = exp.exp_env; } + in + let final_env = Env.add_value id vd exp.exp_env in + let str = + { str_items = [item]; + str_type = sg; + str_final_env = final_env } + in + str, sg + +let execute_phrase print_outcome ppf phr = + match phr with + | Ptop_def sstr -> + let oldenv = !toplevel_env in + let oldsig = !toplevel_sig in + incr phrase_seqid; + let phrase_name = "TOP" ^ string_of_int !phrase_seqid in + let phrase_comp_unit = + Compilation_unit.create Compilation_unit.Prefix.empty + (Compilation_unit.Name.of_string phrase_name) + in + Compilenv.reset phrase_comp_unit; + Typecore.reset_delayed_checks (); + let (str, sg, names, shape, newenv) = + Typemod.type_toplevel_phrase oldenv oldsig sstr + in + if !Clflags.dump_typedtree then Printtyped.implementation ppf str; + let sg' = Typemod.Signature_names.simplify newenv names sg in + ignore (Includemod.signatures oldenv ~mark:Mark_positive sg sg'); + Typecore.force_delayed_checks (); + let shape = Shape.local_reduce shape in + if !Clflags.dump_shape then Shape.print ppf shape; + (* `let _ = ` or even just `` require special + handling in toplevels, or nothing is displayed. In bytecode, the + lambda for is directly executed and the result _is_ the + value. In native, the lambda for is compiled and loaded + from a DLL, and the result of loading that DLL is _not_ the value + itself. In native, must therefore be named so that it can + be looked up after the DLL has been dlopen'd. + + The expression is "named" after typing in order to ensure that both + bytecode and native toplevels always type-check _exactly_ the same + expression. Adding the binding at the parsetree level (before typing) + can create observable differences (e.g. in type variable names, see + tool-toplevel/topeval.ml in the testsuite) *) + let str, sg', rewritten = + match find_eval_phrase str with + | Some (e, attrs, loc) -> + let str, sg' = name_expression ~loc ~attrs e in + str, sg', true + | None -> str, sg', false + in + let compilation_unit, res, required_globals, size = + if Config.flambda then + let { Lambda.compilation_unit; main_module_block_size = size; + required_globals; code = res } = + Translmod.transl_implementation_flambda phrase_comp_unit + (str, Tcoerce_none) + in + remember compilation_unit 0 sg'; + compilation_unit, close_phrase res, required_globals, size + else + let size, res = Translmod.transl_store_phrases phrase_comp_unit str in + phrase_comp_unit, res, Compilation_unit.Set.empty, size + in + Warnings.check_fatal (); + begin try + toplevel_env := newenv; + toplevel_sig := List.rev_append sg' oldsig; + let res = + load_lambda ppf ~required_globals ~compilation_unit phrase_name res size + in + let out_phr = + match res with + | Result _ -> + if Config.flambda then + (* CR-someday trefis: *) + Env.register_import_as_opaque + (Compilation_unit.name compilation_unit) + else + Compilenv.record_global_approx_toplevel (); + if print_outcome then + Printtyp.wrap_printing_env ~error:false oldenv (fun () -> + match str.str_items with + | [] -> Ophr_signature [] + | _ -> + if rewritten then + match sg' with + | [ Sig_value (id, vd, _) ] -> + let outv = + outval_of_value newenv (toplevel_value id) + vd.val_type + in + let ty = Printtyp.tree_of_type_scheme vd.val_type in + Ophr_eval (outv, ty) + | _ -> assert false + else + Ophr_signature (pr_item oldenv sg')) + else Ophr_signature [] + | Exception exn -> + toplevel_env := oldenv; + toplevel_sig := oldsig; + if exn = Out_of_memory then Gc.full_major(); + let outv = + outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn + in + Ophr_exception (exn, outv) + in + !print_out_phrase ppf out_phr; + begin match out_phr with + | Ophr_eval (_, _) | Ophr_signature _ -> true + | Ophr_exception _ -> false + end + with x -> + toplevel_env := oldenv; toplevel_sig := oldsig; raise x + end + | Ptop_dir {pdir_name = {Location.txt = dir_name}; pdir_arg } -> + try_run_directive ppf dir_name pdir_arg + + +(* API compat *) + +let getvalue _ = assert false +let setvalue _ _ = assert false + +(* Loading files *) + +(* Load in-core a .cmxs file *) + +let load_file _ (* fixme *) ppf name0 = + let name = + try Some (Load_path.find name0) + with Not_found -> None + in + match name with + | None -> fprintf ppf "File not found: %s@." name0; false + | Some name -> + let fn,tmp = + if Filename.check_suffix name ".cmx" || Filename.check_suffix name ".cmxa" + then + let cmxs = Filename.temp_file "caml" ".cmxs" in + Asmlink.link_shared ~ppf_dump:ppf [name] cmxs; + cmxs,true + else + name,false + in + let success = + (* The Dynlink interface does not allow us to distinguish between + a Dynlink.Error exceptions raised in the loaded modules + or a genuine error during dynlink... *) + try Dynlink.loadfile fn; true + with + | Dynlink.Error err -> + fprintf ppf "Error while loading %s: %s.@." + name (Dynlink.error_message err); + false + | exn -> + print_exception_outcome ppf exn; + false + in + if tmp then (try Sys.remove fn with Sys_error _ -> ()); + success + +let init () = + Compmisc.init_path (); + Clflags.dlcode := true; + () diff --git a/ocaml/toplevel/native/tophooks.ml b/ocaml/toplevel/native/tophooks.ml new file mode 100644 index 00000000000..fcfcbef1acc --- /dev/null +++ b/ocaml/toplevel/native/tophooks.ml @@ -0,0 +1,113 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Native toplevel dynamic loading interface *) + +open Config +open Misc +open Topcommon + +type[@warning "-37"] res = Ok of Obj.t | Err of string + +external ndl_run_toplevel: string -> string -> res + = "caml_natdynlink_run_toplevel" + +let lookup sym = + Dynlink.unsafe_get_global_value ~bytecode_or_asm_symbol:sym + +let need_symbol sym = + Option.is_none (Dynlink.unsafe_get_global_value ~bytecode_or_asm_symbol:sym) + +let dll_run dll entry = + match (try Result (Obj.magic (ndl_run_toplevel dll entry)) + with exn -> Exception exn) + with + | Exception _ as r -> r + | Result r -> + match Obj.magic r with + | Ok x -> Result x + | Err s -> fatal_error ("Toploop.dll_run " ^ s) + +(* CR-soon trefis for mshinwell: copy/pasted from Optmain. Should it be shared + or? + mshinwell: It should be shared, but after 4.03. *) +module Backend = struct + (* See backend_intf.mli. *) + + let really_import_approx = Import_approx.really_import_approx + let import_symbol = Import_approx.import_symbol + + let size_int = Arch.size_int + let big_endian = Arch.big_endian + + let max_sensible_number_of_arguments = + (* The "-1" is to allow for a potential closure environment parameter. *) + Proc.max_arguments_for_tailcalls - 1 +end +let backend = (module Backend : Backend_intf.S) + +let load ppf phrase_name program = + let dll = + if !Clflags.keep_asm_file then phrase_name ^ ext_dll + else Filename.temp_file ("caml" ^ phrase_name) ext_dll + in + let filename = Filename.chop_extension dll in + let middle_end = + if Config.flambda then Flambda_middle_end.lambda_to_clambda + else Closure_middle_end.lambda_to_clambda + in + Asmgen.compile_implementation ~toplevel:need_symbol + ~backend ~prefixname:filename + ~middle_end ~ppf_dump:ppf program; + Asmlink.call_linker_shared [filename ^ ext_obj] dll; + Sys.remove (filename ^ ext_obj); + + let dll = + if Filename.is_implicit dll + then Filename.concat (Sys.getcwd ()) dll + else dll in + match + Fun.protect + ~finally:(fun () -> + (try Sys.remove dll with Sys_error _ -> ())) + (* note: under windows, cannot remove a loaded dll + (should remember the handles, close them in at_exit, and then + remove files) *) + (fun () -> + (* CR-someday lmaurer: The manual prefixing here feels wrong. Probably + [phrase_name] should be a [Compilation_unit.t] (from which we can extract + a linkage name like civilized folk). That will be easier to do once we have + better types in, say, the [Translmod] API. *) + dll_run dll ("caml" ^ phrase_name)) + with + | res -> res + | exception x -> + record_backtrace (); + Exception x + +type lookup_fn = string -> Obj.t option +type load_fn = + Format.formatter -> string -> Lambda.program -> Topcommon.evaluation_outcome +type assembler = {mutable lookup: lookup_fn; mutable load: load_fn} + +let fns = {lookup; load} + +let load ppf = fns.load ppf + +let lookup sym = fns.lookup sym + +let register_loader ~lookup ~load = + fns.lookup <- lookup; + fns.load <- load diff --git a/ocaml/toplevel/native/tophooks.mli b/ocaml/toplevel/native/tophooks.mli new file mode 100644 index 00000000000..5294995ec0f --- /dev/null +++ b/ocaml/toplevel/native/tophooks.mli @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** This module contains sections of Topeval in native code which can be + overridden, for example to change the linker. +*) + +type lookup_fn = string -> Obj.t option +type load_fn = + Format.formatter -> string -> Lambda.program -> Topcommon.evaluation_outcome + +val lookup : lookup_fn +(** Find a global symbol by name. Default implementation may be overridden + with {!register_assembler}. *) + +val load : load_fn +(** [load ppf phrase_name lambda] compiles and evaluates [lambda]. [phrase_name] + may be used for temporary files and is unique. [ppf] may be used for + debugging output. Default implementation may be overridden with + {!register_loader}. *) + +val register_loader : lookup:lookup_fn -> load:load_fn -> unit +(** Sets the functions used for {!lookup} and {!load}. *) diff --git a/ocaml/toplevel/opttopmain.ml b/ocaml/toplevel/native/topmain.ml similarity index 71% rename from ocaml/toplevel/opttopmain.ml rename to ocaml/toplevel/native/topmain.ml index 182e52fda47..b7e22691f88 100644 --- a/ocaml/toplevel/opttopmain.ml +++ b/ocaml/toplevel/native/topmain.ml @@ -13,11 +13,6 @@ (* *) (**************************************************************************) -open Compenv - -let usage = - "Usage: ocamlnat [script-file]\noptions are:" - let preload_objects = ref [] (* Position of the first non expanded argument *) @@ -40,12 +35,12 @@ let expand_position pos len = let prepare ppf = - Opttoploop.set_paths (); + Topcommon.set_paths (); try let res = - List.for_all (Opttopdirs.load_file ppf) (List.rev !preload_objects) + List.for_all (Topeval.load_file false ppf) (List.rev !preload_objects) in - Opttoploop.run_hooks Opttoploop.Startup; + Topcommon.run_hooks Topcommon.Startup; res with x -> try Location.report_exception ppf x; false @@ -53,12 +48,13 @@ let prepare ppf = Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x); false -let file_argument name = +let input_argument name = + let filename = Toploop.filename_of_input name in let ppf = Format.err_formatter in - if Filename.check_suffix name ".cmxs" - || Filename.check_suffix name ".cmx" - || Filename.check_suffix name ".cmxa" - then preload_objects := name :: !preload_objects + if Filename.check_suffix filename ".cmxs" + || Filename.check_suffix filename ".cmx" + || Filename.check_suffix filename ".cmxa" + then preload_objects := filename :: !preload_objects else if is_expanded !current then begin (* Script files are not allowed in expand options because otherwise the check in override arguments may fail since the new argv can be larger @@ -66,18 +62,20 @@ let file_argument name = *) Printf.eprintf "For implementation reasons, the toplevel does not support\ \ having script files (here %S) inside expanded arguments passed through\ - \ the -args{,0} command-line option.\n" name; - raise (Exit_with_status 2) + \ the -args{,0} command-line option.\n" filename; + raise (Compenv.Exit_with_status 2) end else begin let newargs = Array.sub !argv !Arg.current (Array.length !argv - !Arg.current) in Compmisc.read_clflags_from_env (); - if prepare ppf && Opttoploop.run_script ppf name newargs - then raise (Exit_with_status 0) - else raise (Exit_with_status 2) + if prepare ppf && Toploop.run_script ppf name newargs + then raise (Compenv.Exit_with_status 0) + else raise (Compenv.Exit_with_status 2) end +let file_argument x = input_argument (Toploop.File x) + let wrap_expand f s = let start = !current in let arr = f s in @@ -86,10 +84,12 @@ let wrap_expand f s = module Options = Main_args.Make_opttop_options (struct include Main_args.Default.Opttopmain - let _stdin () = file_argument "" + let _stdin () = input_argument Toploop.Stdin let _args = wrap_expand Arg.read_arg let _args0 = wrap_expand Arg.read_arg0 let anonymous s = file_argument s + let _eval s = input_argument (Toploop.String s) + end);; let () = @@ -101,23 +101,18 @@ let () = Clflags.include_dirs := List.rev_append extra_paths !Clflags.include_dirs let main () = + let ppf = Format.err_formatter in Clflags.native_code := true; - let list = ref Options.list in - begin - try - Arg.parse_and_expand_argv_dynamic current argv list file_argument usage; - with - | Arg.Bad msg -> Format.fprintf Format.err_formatter "%s%!" msg; - raise (Exit_with_status 2) - | Arg.Help msg -> Format.fprintf Format.std_formatter "%s%!" msg; - raise (Exit_with_status 0) - end; + let program = "ocamlnat" in + Compenv.readenv ppf Before_args; + Clflags.add_arguments __LOC__ Options.list; + Compenv.parse_arguments ~current argv file_argument program; Compmisc.read_clflags_from_env (); - if not (prepare Format.err_formatter) then raise (Exit_with_status 2); + if not (prepare Format.err_formatter) then raise (Compenv.Exit_with_status 2); Compmisc.init_path (); - Opttoploop.loop Format.std_formatter + Toploop.loop Format.std_formatter let main () = match main () with - | exception Exit_with_status n -> n + | exception Compenv.Exit_with_status n -> n | () -> 0 diff --git a/ocaml/toplevel/native/trace.ml b/ocaml/toplevel/native/trace.ml new file mode 100644 index 00000000000..1bb1a212836 --- /dev/null +++ b/ocaml/toplevel/native/trace.ml @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Dummy implementation, [Trace] is not supported in native code *) + +let unavailable () = + invalid_arg "'Trace' is not available in the native toplevel." + +type codeptr + +type traced_function = + { path: Path.t; (* Name under which it is traced *) + closure: Obj.t; (* Its function closure (patched) *) + actual_code: codeptr; (* Its original code pointer *) + instrumented_fun: codeptr -> Obj.t -> Obj.t -> Obj.t } + (* Printing function *) + +let traced_functions = ref [] +let is_traced _ = None +let get_code_pointer _ = unavailable () +let set_code_pointer _ _ = unavailable () +let instrument_closure _ _ _ _ _ _ _ = unavailable () +let print_trace _ _ = unavailable () diff --git a/ocaml/toplevel/opttopdirs.ml b/ocaml/toplevel/opttopdirs.ml deleted file mode 100644 index c5effee1de5..00000000000 --- a/ocaml/toplevel/opttopdirs.ml +++ /dev/null @@ -1,218 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* Toplevel directives *) - -open Format -open Misc -open Longident -open Types -open Opttoploop - -(* The standard output formatter *) -let std_out = std_formatter - -(* To quit *) - -let dir_quit () = raise (Compenv.Exit_with_status 0) - -let _ = Hashtbl.add directive_table "quit" (Directive_none dir_quit) - -(* To add a directory to the load path *) - -let dir_directory s = - let d = expand_directory Config.standard_library s in - let dir = Load_path.Dir.create d in - Load_path.add dir; - toplevel_env := - Stdlib.String.Set.fold - (fun name env -> - Env.add_persistent_structure (Ident.create_persistent name) env) - (Env.persistent_structures_of_dir dir) - !toplevel_env - -let _ = Hashtbl.add directive_table "directory" (Directive_string dir_directory) -(* To remove a directory from the load path *) -let dir_remove_directory s = - let d = expand_directory Config.standard_library s in - let keep id = - match Load_path.find_uncap (Ident.name id ^ ".cmi") with - | exception Not_found -> true - | fn -> Filename.dirname fn <> d - in - toplevel_env := Env.filter_non_loaded_persistent keep !toplevel_env; - Load_path.remove_dir s - -let _ = - Hashtbl.add directive_table "remove_directory" - (Directive_string dir_remove_directory) - -let _ = Hashtbl.add directive_table "show_dirs" - (Directive_none - (fun () -> - List.iter print_endline (Load_path.get_paths ()) - )) - -(* To change the current directory *) - -let dir_cd s = Sys.chdir s - -let _ = Hashtbl.add directive_table "cd" (Directive_string dir_cd) - -(* Load in-core a .cmxs file *) - -let load_file ppf name0 = - let name = - try Some (Load_path.find name0) - with Not_found -> None - in - match name with - | None -> fprintf ppf "File not found: %s@." name0; false - | Some name -> - let fn,tmp = - if Filename.check_suffix name ".cmx" || Filename.check_suffix name ".cmxa" - then - let cmxs = Filename.temp_file "caml" ".cmxs" in - Asmlink.link_shared ~ppf_dump:ppf [name] cmxs; - cmxs,true - else - name,false - in - let success = - (* The Dynlink interface does not allow us to distinguish between - a Dynlink.Error exceptions raised in the loaded modules - or a genuine error during dynlink... *) - try Dynlink.loadfile fn; true - with - | Dynlink.Error err -> - fprintf ppf "Error while loading %s: %s.@." - name (Dynlink.error_message err); - false - | exn -> - print_exception_outcome ppf exn; - false - in - if tmp then (try Sys.remove fn with Sys_error _ -> ()); - success - - -let dir_load ppf name = ignore (load_file ppf name) - -let _ = Hashtbl.add directive_table "load" (Directive_string (dir_load std_out)) - -(* Load commands from a file *) - -let dir_use ppf name = ignore(Opttoploop.use_file ppf name) -let dir_use_output ppf name = ignore(Opttoploop.use_output ppf name) - -let _ = Hashtbl.add directive_table "use" (Directive_string (dir_use std_out)) -let _ = Hashtbl.add directive_table "use_output" - (Directive_string (dir_use_output std_out)) - -(* Install, remove a printer *) - -type 'a printer_type_new = Format.formatter -> 'a -> unit -type 'a printer_type_old = 'a -> unit - -let match_printer_type ppf desc typename = - let printer_type = - match - Env.find_type_by_name - (Ldot(Lident "Opttopdirs", typename)) !toplevel_env - with - | (path, _) -> path - | exception Not_found -> - fprintf ppf "Cannot find type Topdirs.%s.@." typename; - raise Exit - in - Ctype.begin_def(); - let ty_arg = Ctype.newvar() in - Ctype.unify !toplevel_env - (Ctype.newconstr printer_type [ty_arg]) - (Ctype.instance desc.val_type); - Ctype.end_def(); - Ctype.generalize ty_arg; - ty_arg - -let find_printer_type ppf lid = - match Env.find_value_by_name lid !toplevel_env with - | (path, desc) -> begin - match match_printer_type ppf desc "printer_type_new" with - | ty_arg -> (ty_arg, path, false) - | exception Ctype.Unify _ -> begin - match match_printer_type ppf desc "printer_type_old" with - | ty_arg -> (ty_arg, path, true) - | exception Ctype.Unify _ -> - fprintf ppf "%a has a wrong type for a printing function.@." - Printtyp.longident lid; - raise Exit - end - end - | exception Not_found -> - fprintf ppf "Unbound value %a.@." Printtyp.longident lid; - raise Exit - -let dir_install_printer ppf lid = - try - let (ty_arg, path, is_old_style) = find_printer_type ppf lid in - let v = eval_value_path !toplevel_env path in - let print_function = - if is_old_style then - (fun _formatter repr -> Obj.obj v (Obj.obj repr)) - else - (fun formatter repr -> Obj.obj v formatter (Obj.obj repr)) in - install_printer path ty_arg print_function - with Exit -> () - -let dir_remove_printer ppf lid = - try - let (_ty_arg, path, _is_old_style) = find_printer_type ppf lid in - begin try - remove_printer path - with Not_found -> - fprintf ppf "No printer named %a.@." Printtyp.longident lid - end - with Exit -> () - -let _ = Hashtbl.add directive_table "install_printer" - (Directive_ident (dir_install_printer std_out)) -let _ = Hashtbl.add directive_table "remove_printer" - (Directive_ident (dir_remove_printer std_out)) - -let parse_warnings ppf iserr s = - try Warnings.parse_options iserr s - with Arg.Bad err -> fprintf ppf "%s.@." err - -let _ = -(* Control the printing of values *) - - Hashtbl.add directive_table "print_depth" - (Directive_int(fun n -> max_printer_depth := n)); - Hashtbl.add directive_table "print_length" - (Directive_int(fun n -> max_printer_steps := n)); - -(* Set various compiler flags *) - - Hashtbl.add directive_table "labels" - (Directive_bool(fun b -> Clflags.classic := not b)); - - Hashtbl.add directive_table "principal" - (Directive_bool(fun b -> Clflags.principal := b)); - - Hashtbl.add directive_table "warnings" - (Directive_string (parse_warnings std_out false)); - - Hashtbl.add directive_table "warn_error" - (Directive_string (parse_warnings std_out true)) diff --git a/ocaml/toplevel/opttoploop.ml b/ocaml/toplevel/opttoploop.ml deleted file mode 100644 index 2ac70d1a36d..00000000000 --- a/ocaml/toplevel/opttoploop.ml +++ /dev/null @@ -1,698 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -(* The interactive toplevel loop *) - -open Format -open Config -open Misc -open Parsetree -open Types -open Typedtree -open Outcometree -open Ast_helper - -type res = Ok of Obj.t | Err of string -type evaluation_outcome = Result of Obj.t | Exception of exn - -let _dummy = (Ok (Obj.magic 0), Err "") - -external ndl_run_toplevel: string -> string -> res - = "caml_natdynlink_run_toplevel" - -let global_symbol id = - let sym = Compilenv.symbol_for_global id |> Linkage_name.to_string in - match Dynlink.unsafe_get_global_value ~bytecode_or_asm_symbol:sym with - | None -> - fatal_error ("Opttoploop.global_symbol " ^ (Ident.unique_name id)) - | Some obj -> obj - -let need_symbol sym = - Option.is_none (Dynlink.unsafe_get_global_value ~bytecode_or_asm_symbol:sym) - -let dll_run dll entry = - match (try Result (Obj.magic (ndl_run_toplevel dll entry)) - with exn -> Exception exn) - with - | Exception _ as r -> r - | Result r -> - match Obj.magic r with - | Ok x -> Result x - | Err s -> fatal_error ("Opttoploop.dll_run " ^ s) - - -type directive_fun = - | Directive_none of (unit -> unit) - | Directive_string of (string -> unit) - | Directive_int of (int -> unit) - | Directive_ident of (Longident.t -> unit) - | Directive_bool of (bool -> unit) - - -let remembered = ref Ident.empty - -let rec remember phrase_name i = function - | [] -> () - | Sig_value (id, _, _) :: rest - | Sig_module (id, _, _, _, _) :: rest - | Sig_typext (id, _, _, _) :: rest - | Sig_class (id, _, _, _) :: rest -> - remembered := Ident.add id (phrase_name, i) !remembered; - remember phrase_name (succ i) rest - | _ :: rest -> remember phrase_name i rest - -let toplevel_value id = - try Ident.find_same id !remembered - with _ -> Misc.fatal_error @@ "Unknown ident: " ^ Ident.unique_name id - -let close_phrase lam = - let open Lambda in - Ident.Set.fold (fun id l -> - let glb, pos = toplevel_value id in - let glob = - Lprim (mod_field pos, - [Lprim (Pgetglobal glb, [], Loc_unknown)], - Loc_unknown) - in - Llet(Strict, Pgenval, id, glob, l) - ) (free_variables lam) lam - -let toplevel_value id = - let glob, pos = - if Config.flambda then toplevel_value id else Translmod.nat_toplevel_name id - in - (Obj.magic (global_symbol glob)).(pos) - -(* Return the value referred to by a path *) - -let rec eval_address = function - | Env.Aident id -> - if Ident.is_global_or_predef id - then global_symbol id - else toplevel_value id - | Env.Adot(a, pos) -> - Obj.field (eval_address a) pos - -let eval_path find env path = - match find path env with - | addr -> eval_address addr - | exception Not_found -> - fatal_error ("Cannot find address for: " ^ (Path.name path)) - -let eval_module_path env path = - eval_path Env.find_module_address env path - -let eval_value_path env path = - eval_path Env.find_value_address env path - -let eval_extension_path env path = - eval_path Env.find_constructor_address env path - -let eval_class_path env path = - eval_path Env.find_class_address env path - -(* To print values *) - -module EvalPath = struct - type valu = Obj.t - exception Error - let eval_address addr = - try eval_address addr with _ -> raise Error - let same_value v1 v2 = (v1 == v2) -end - -module Printer = Genprintval.Make(Obj)(EvalPath) - -let max_printer_depth = ref 100 -let max_printer_steps = ref 300 - -let print_out_value = Oprint.out_value -let print_out_type = Oprint.out_type -let print_out_class_type = Oprint.out_class_type -let print_out_module_type = Oprint.out_module_type -let print_out_type_extension = Oprint.out_type_extension -let print_out_sig_item = Oprint.out_sig_item -let print_out_signature = Oprint.out_signature -let print_out_phrase = Oprint.out_phrase - -let print_untyped_exception ppf obj = - !print_out_value ppf (Printer.outval_of_untyped_exception obj) -let outval_of_value env obj ty = - Printer.outval_of_value !max_printer_steps !max_printer_depth - (fun _ _ _ -> None) env obj ty -let print_value env obj ppf ty = - !print_out_value ppf (outval_of_value env obj ty) - -type ('a, 'b) gen_printer = ('a, 'b) Genprintval.gen_printer = - | Zero of 'b - | Succ of ('a -> ('a, 'b) gen_printer) - -let install_printer = Printer.install_printer -let install_generic_printer = Printer.install_generic_printer -let install_generic_printer' = Printer.install_generic_printer' -let remove_printer = Printer.remove_printer - -(* Hooks for parsing functions *) - -let parse_toplevel_phrase = ref Parse.toplevel_phrase -let parse_use_file = ref Parse.use_file -let print_location = Location.print_loc -let print_error = Location.print_report -let print_warning = Location.print_warning -let input_name = Location.input_name - -let parse_mod_use_file name lb = - let modname = - String.capitalize_ascii - (Filename.remove_extension (Filename.basename name)) - in - let items = - List.concat - (List.map - (function Ptop_def s -> s | Ptop_dir _ -> []) - (!parse_use_file lb)) - in - [ Ptop_def - [ Str.module_ - (Mb.mk - (Location.mknoloc (Some modname)) - (Mod.structure items) - ) - ] - ] - -(* Hook for initialization *) - -let toplevel_startup_hook = ref (fun () -> ()) - -type event = .. -type event += - | Startup - | After_setup - -let hooks = ref [] - -let add_hook f = hooks := f :: !hooks - -let () = - add_hook (function - | Startup -> !toplevel_startup_hook () - | _ -> ()) - -let run_hooks hook = List.iter (fun f -> f hook) !hooks - -(* Load in-core and execute a lambda term *) - -let phrase_seqid = ref 0 -let phrase_name = ref "TOP" - -(* CR-soon trefis for mshinwell: copy/pasted from Optmain. Should it be shared - or? - mshinwell: It should be shared, but after 4.03. *) -module Backend = struct - (* See backend_intf.mli. *) - - let pack_prefix_for_global_ident = Compilenv.pack_prefix_for_global_ident - - let really_import_approx = Import_approx.really_import_approx - let import_symbol = Import_approx.import_symbol - - let size_int = Arch.size_int - let big_endian = Arch.big_endian - - let max_sensible_number_of_arguments = - (* The "-1" is to allow for a potential closure environment parameter. *) - Proc.max_arguments_for_tailcalls - 1 -end -let backend = (module Backend : Backend_intf.S) - -let load_lambda ppf ~module_ident ~required_globals lam size = - if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam; - let slam = Simplif.simplify_lambda lam in - if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam; - - let dll = - if !Clflags.keep_asm_file then !phrase_name ^ ext_dll - else Filename.temp_file ("caml" ^ !phrase_name) ext_dll - in - let filename = Filename.chop_extension dll in - let program = - { Lambda. - code = slam; - main_module_block_size = size; - module_ident; - required_globals; - } - in - let middle_end = - if Config.flambda then Flambda_middle_end.lambda_to_clambda - else Closure_middle_end.lambda_to_clambda - in - Asmgen.compile_implementation ~toplevel:need_symbol - ~backend ~filename ~prefixname:filename - ~middle_end ~ppf_dump:ppf program; - Asmlink.call_linker_shared [filename ^ ext_obj] dll; - Sys.remove (filename ^ ext_obj); - - let dll = - if Filename.is_implicit dll - then Filename.concat (Sys.getcwd ()) dll - else dll in - (* CR-someday lmaurer: The manual prefixing here feels wrong. Probably - [!phrase_name] should be a [Compilation_unit.t] (from which we can extract - a linkage name like civilized folk). That will be easier to do once we have - better types in, say, the [Translmod] API. *) - let res = dll_run dll ("caml" ^ !phrase_name) in - (try Sys.remove dll with Sys_error _ -> ()); - (* note: under windows, cannot remove a loaded dll - (should remember the handles, close them in at_exit, and then remove - files) *) - res - -(* Print the outcome of an evaluation *) - -let pr_item = - Printtyp.print_items - (fun env -> function - | Sig_value(id, {val_kind = Val_reg; val_type}, _) -> - Some (outval_of_value env (toplevel_value id) val_type) - | _ -> None - ) - -(* The current typing environment for the toplevel *) - -let toplevel_env = ref Env.empty -let toplevel_sig = ref [] - -(* Print an exception produced by an evaluation *) - -let print_out_exception ppf exn outv = - !print_out_phrase ppf (Ophr_exception (exn, outv)) - -let print_exception_outcome ppf exn = - if exn = Out_of_memory then Gc.full_major (); - let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in - print_out_exception ppf exn outv - -(* The table of toplevel directives. - Filled by functions from module topdirs. *) - -let directive_table = (Hashtbl.create 13 : (string, directive_fun) Hashtbl.t) - -(* Execute a toplevel phrase *) - -let execute_phrase print_outcome ppf phr = - match phr with - | Ptop_def sstr -> - let oldenv = !toplevel_env in - let oldsig = !toplevel_sig in - incr phrase_seqid; - phrase_name := Printf.sprintf "TOP%i" !phrase_seqid; - let phrase_comp_unit = - Compilation_unit.create Compilation_unit.Prefix.empty - (Compilation_unit.Name.of_string !phrase_name) - in - Compilenv.reset phrase_comp_unit; - Typecore.reset_delayed_checks (); - let sstr, rewritten = - match sstr with - | [ { pstr_desc = Pstr_eval (e, attrs) ; pstr_loc = loc } ] - | [ { pstr_desc = Pstr_value (Asttypes.Nonrecursive, - [{ pvb_expr = e - ; pvb_pat = { ppat_desc = Ppat_any ; _ } - ; pvb_attributes = attrs - ; _ }]) - ; pstr_loc = loc } - ] -> - let pat = Ast_helper.Pat.var (Location.mknoloc "_$") in - let vb = Ast_helper.Vb.mk ~loc ~attrs pat e in - [ Ast_helper.Str.value ~loc Asttypes.Nonrecursive [vb] ], true - | _ -> sstr, false - in - let (str, sg, names, newenv) = - Typemod.type_toplevel_phrase oldenv oldsig sstr - in - if !Clflags.dump_typedtree then Printtyped.implementation ppf str; - let sg' = Typemod.Signature_names.simplify newenv names sg in - ignore (Includemod.signatures oldenv ~mark:Mark_positive sg sg'); - Typecore.force_delayed_checks (); - let module_ident, res, required_globals, size = - if Config.flambda then - let { Lambda.module_ident; main_module_block_size = size; - required_globals; code = res } = - Translmod.transl_implementation_flambda !phrase_name - (str, Tcoerce_none) - in - remember module_ident 0 sg'; - module_ident, close_phrase res, required_globals, size - else - let size, res = Translmod.transl_store_phrases !phrase_name str in - Ident.create_persistent !phrase_name, res, Ident.Set.empty, size - in - Warnings.check_fatal (); - begin try - toplevel_env := newenv; - toplevel_sig := List.rev_append sg' oldsig; - let res = load_lambda ppf ~required_globals ~module_ident res size in - let out_phr = - match res with - | Result _ -> - if Config.flambda then - (* CR-someday trefis: *) - Env.register_import_as_opaque (Ident.name module_ident) - else - Compilenv.record_global_approx_toplevel (); - if print_outcome then - Printtyp.wrap_printing_env ~error:false oldenv (fun () -> - match str.str_items with - | [] -> Ophr_signature [] - | _ -> - if rewritten then - match sg' with - | [ Sig_value (id, vd, _) ] -> - let outv = - outval_of_value newenv (toplevel_value id) - vd.val_type - in - let ty = Printtyp.tree_of_type_scheme vd.val_type in - Ophr_eval (outv, ty) - | _ -> assert false - else - Ophr_signature (pr_item oldenv sg')) - else Ophr_signature [] - | Exception exn -> - toplevel_env := oldenv; - toplevel_sig := oldsig; - if exn = Out_of_memory then Gc.full_major(); - let outv = - outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn - in - Ophr_exception (exn, outv) - in - !print_out_phrase ppf out_phr; - begin match out_phr with - | Ophr_eval (_, _) | Ophr_signature _ -> true - | Ophr_exception _ -> false - end - with x -> - toplevel_env := oldenv; toplevel_sig := oldsig; raise x - end - | Ptop_dir {pdir_name = {Location.txt = dir_name}; pdir_arg } -> - let d = - try Some (Hashtbl.find directive_table dir_name) - with Not_found -> None - in - begin match d with - | None -> - fprintf ppf "Unknown directive `%s'.@." dir_name; - false - | Some d -> - match d, pdir_arg with - | Directive_none f, None -> f (); true - | Directive_string f, Some {pdira_desc = Pdir_string s} -> f s; true - | Directive_int f, Some {pdira_desc = Pdir_int (n,None)} -> - begin match Int_literal_converter.int n with - | n -> f n; true - | exception _ -> - fprintf ppf "Integer literal exceeds the range of \ - representable integers for directive `%s'.@." - dir_name; - false - end - | Directive_int _, Some {pdira_desc = Pdir_int (_, Some _)} -> - fprintf ppf "Wrong integer literal for directive `%s'.@." - dir_name; - false - | Directive_ident f, Some {pdira_desc = Pdir_ident lid} -> f lid; true - | Directive_bool f, Some {pdira_desc = Pdir_bool b} -> f b; true - | _ -> - fprintf ppf "Wrong type of argument for directive `%s'.@." - dir_name; - false - end - -(* Read and execute commands from a file, or from stdin if [name] is "". *) - -let use_print_results = ref true - -let preprocess_phrase ppf phr = - let phr = - match phr with - | Ptop_def str -> - let str = - Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str - in - Ptop_def str - | phr -> phr - in - if !Clflags.dump_parsetree then Printast.top_phrase ppf phr; - if !Clflags.dump_source then Pprintast.top_phrase ppf phr; - phr - -let use_channel ppf ~wrap_in_module ic name filename = - let lb = Lexing.from_channel ic in - Location.init lb filename; - (* Skip initial #! line if any *) - Lexer.skip_hash_bang lb; - let success = - protect_refs [ R (Location.input_name, filename) ] (fun () -> - try - List.iter - (fun ph -> - let ph = preprocess_phrase ppf ph in - if not (execute_phrase !use_print_results ppf ph) then raise Exit) - (if wrap_in_module then - parse_mod_use_file name lb - else - !parse_use_file lb); - true - with - | Exit -> false - | Sys.Break -> fprintf ppf "Interrupted.@."; false - | x -> Location.report_exception ppf x; false) in - success - -let use_output ppf command = - let fn = Filename.temp_file "ocaml" "_toploop.ml" in - Misc.try_finally ~always:(fun () -> - try Sys.remove fn with Sys_error _ -> ()) - (fun () -> - match - Printf.ksprintf Sys.command "%s > %s" - command - (Filename.quote fn) - with - | 0 -> - let ic = open_in_bin fn in - Misc.try_finally ~always:(fun () -> close_in ic) - (fun () -> - use_channel ppf ~wrap_in_module:false ic "" "(command-output)") - | n -> - fprintf ppf "Command exited with code %d.@." n; - false) - -let use_file ppf ~wrap_in_module name = - match name with - | "" -> - use_channel ppf ~wrap_in_module stdin name "(stdin)" - | _ -> - match Load_path.find name with - | filename -> - let ic = open_in_bin filename in - Misc.try_finally ~always:(fun () -> close_in ic) - (fun () -> use_channel ppf ~wrap_in_module ic name filename) - | exception Not_found -> - fprintf ppf "Cannot find file %s.@." name; - false - -let mod_use_file ppf name = - use_file ppf ~wrap_in_module:true name -let use_file ppf name = - use_file ppf ~wrap_in_module:false name - -let use_silently ppf name = - protect_refs [ R (use_print_results, false) ] (fun () -> use_file ppf name) - -(* Reading function for interactive use *) - -let first_line = ref true -let got_eof = ref false;; - -let read_input_default prompt buffer len = - output_string stdout prompt; flush stdout; - let i = ref 0 in - try - while true do - if !i >= len then raise Exit; - let c = input_char stdin in - Bytes.set buffer !i c; - incr i; - if c = '\n' then raise Exit; - done; - (!i, false) - with - | End_of_file -> - (!i, true) - | Exit -> - (!i, false) - -let read_interactive_input = ref read_input_default - -let refill_lexbuf buffer len = - if !got_eof then (got_eof := false; 0) else begin - let prompt = - if !Clflags.noprompt then "" - else if !first_line then "# " - else if !Clflags.nopromptcont then "" - else if Lexer.in_comment () then "* " - else " " - in - first_line := false; - let (len, eof) = !read_interactive_input prompt buffer len in - if eof then begin - Location.echo_eof (); - if len > 0 then got_eof := true; - len - end else - len - end - -(* Toplevel initialization. Performed here instead of at the - beginning of loop() so that user code linked in with ocamlmktop - can call directives from Topdirs. *) - -let _ = - Sys.interactive := true; - Compmisc.init_path (); - Clflags.dlcode := true; - () - -let find_ocamlinit () = - let ocamlinit = ".ocamlinit" in - if Sys.file_exists ocamlinit then Some ocamlinit else - let getenv var = match Sys.getenv var with - | exception Not_found -> None | "" -> None | v -> Some v - in - let exists_in_dir dir file = match dir with - | None -> None - | Some dir -> - let file = Filename.concat dir file in - if Sys.file_exists file then Some file else None - in - let home_dir () = getenv "HOME" in - let config_dir () = - if Sys.win32 then None else - match getenv "XDG_CONFIG_HOME" with - | Some _ as v -> v - | None -> - match home_dir () with - | None -> None - | Some dir -> Some (Filename.concat dir ".config") - in - let init_ml = Filename.concat "ocaml" "init.ml" in - match exists_in_dir (config_dir ()) init_ml with - | Some _ as v -> v - | None -> exists_in_dir (home_dir ()) ocamlinit - -let load_ocamlinit ppf = - if !Clflags.noinit then () - else match !Clflags.init_file with - | Some f -> if Sys.file_exists f then ignore (use_silently ppf f) - else fprintf ppf "Init file not found: \"%s\".@." f - | None -> - match find_ocamlinit () with - | None -> () - | Some file -> ignore (use_silently ppf file) -;; - -let set_paths () = - (* Add whatever -I options have been specified on the command line, - but keep the directories that user code linked in with ocamlmktop - may have added to load_path. *) - let expand = Misc.expand_directory Config.standard_library in - let current_load_path = Load_path.get_paths () in - let load_path = List.concat [ - [ "" ]; - List.map expand (List.rev !Compenv.first_include_dirs); - List.map expand (List.rev !Clflags.include_dirs); - List.map expand (List.rev !Compenv.last_include_dirs); - current_load_path; - [expand "+camlp4"]; - ] - in - Load_path.init load_path - -let initialize_toplevel_env () = - toplevel_env := Compmisc.initial_env(); - toplevel_sig := [] - -(* The interactive loop *) - -exception PPerror - -let loop ppf = - Location.formatter_for_warnings := ppf; - if not !Clflags.noversion then - fprintf ppf " OCaml version %s - native toplevel@.@." Config.version; - initialize_toplevel_env (); - let lb = Lexing.from_function refill_lexbuf in - Location.init lb "//toplevel//"; - Location.input_name := "//toplevel//"; - Location.input_lexbuf := Some lb; - Sys.catch_break true; - run_hooks After_setup; - load_ocamlinit ppf; - while true do - let snap = Btype.snapshot () in - try - Lexing.flush_input lb; - Location.reset(); - first_line := true; - let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in - let phr = preprocess_phrase ppf phr in - Env.reset_cache_toplevel (); - if !Clflags.dump_parsetree then Printast.top_phrase ppf phr; - if !Clflags.dump_source then Pprintast.top_phrase ppf phr; - ignore(execute_phrase true ppf phr) - with - | End_of_file -> raise (Compenv.Exit_with_status 0) - | Sys.Break -> fprintf ppf "Interrupted.@."; Btype.backtrack snap - | PPerror -> () - | x -> Location.report_exception ppf x; Btype.backtrack snap - done - -external caml_sys_modify_argv : string array -> unit = - "caml_sys_modify_argv" - -let override_sys_argv new_argv = - caml_sys_modify_argv new_argv; - Arg.current := 0 - -(* Execute a script. If [name] is "", read the script from stdin. *) - -let run_script ppf name args = - override_sys_argv args; - Compmisc.init_path ~dir:(Filename.dirname name) (); - (* Note: would use [Filename.abspath] here, if we had it. *) - initialize_toplevel_env (); - Sys.interactive := false; - run_hooks After_setup; - let explicit_name = - (* Prevent use_silently from searching in the path. *) - if Filename.is_implicit name - then Filename.concat Filename.current_dir_name name - else name - in - use_silently ppf explicit_name diff --git a/ocaml/toplevel/topcommon.ml b/ocaml/toplevel/topcommon.ml new file mode 100644 index 00000000000..2df93f81ff2 --- /dev/null +++ b/ocaml/toplevel/topcommon.ml @@ -0,0 +1,374 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(* Definitions for the interactive toplevel loop that are common between + bytecode and native *) + +open Format +open Parsetree +open Outcometree +open Ast_helper + +(* Hooks for parsing functions *) + +let parse_toplevel_phrase = ref Parse.toplevel_phrase +let parse_use_file = ref Parse.use_file +let print_location = Location.print_loc +let print_error = Location.print_report +let print_warning = Location.print_warning +let input_name = Location.input_name + +let parse_mod_use_file name lb = + let modname = + String.capitalize_ascii + (Filename.remove_extension (Filename.basename name)) + in + let items = + List.concat + (List.map + (function Ptop_def s -> s | Ptop_dir _ -> []) + (!parse_use_file lb)) + in + [ Ptop_def + [ Str.module_ + (Mb.mk + (Location.mknoloc (Some modname)) + (Mod.structure items) + ) + ] + ] + +(* Hooks for printing *) + +let max_printer_depth = ref 100 +let max_printer_steps = ref 300 + +let print_out_value = Oprint.out_value +let print_out_type = Oprint.out_type +let print_out_class_type = Oprint.out_class_type +let print_out_module_type = Oprint.out_module_type +let print_out_type_extension = Oprint.out_type_extension +let print_out_sig_item = Oprint.out_sig_item +let print_out_signature = Oprint.out_signature +let print_out_phrase = Oprint.out_phrase + +let find_eval_phrase str = + let open Typedtree in + match str.str_items with + | [ { str_desc = Tstr_eval (e, attrs) ; str_loc = loc } ] + | [ { str_desc = Tstr_value (Asttypes.Nonrecursive, + [{ vb_expr = e + ; vb_pat = { pat_desc = Tpat_any; _ } + ; vb_attributes = attrs }]) + ; str_loc = loc } + ] -> + Some (e, attrs, loc) + | _ -> None + +(* The current typing environment for the toplevel *) + +let toplevel_env = ref Env.empty +let toplevel_sig = ref [] + +let backtrace = ref None + +(* Generic evaluator and printer *) + +exception Undefined_global of string + +module type EVAL_BASE = sig + + val eval_compilation_unit: Compilation_unit.t -> Obj.t + + (* Return the value referred to by a base ident. + @raise [Undefined_global] if not found *) + val eval_ident: Ident.t -> Obj.t +end + +module MakeEvalPrinter (E: EVAL_BASE) = struct + + let rec eval_address = function + | Env.Aunit cu -> E.eval_compilation_unit cu + | Env.Alocal id -> E.eval_ident id + | Env.Adot(p, pos) -> Obj.field (eval_address p) pos + + let eval_path find env path = + match find path env with + | addr -> eval_address addr + | exception Not_found -> + Misc.fatal_error ("Cannot find address for: " ^ (Path.name path)) + + let eval_module_path env path = + eval_path Env.find_module_address env path + + let eval_value_path env path = + eval_path Env.find_value_address env path + + let eval_extension_path env path = + eval_path Env.find_constructor_address env path + + let eval_class_path env path = + eval_path Env.find_class_address env path + + + module Printer = Genprintval.Make(Obj)(struct + type valu = Obj.t + exception Error + let eval_address addr = + try eval_address addr + with Undefined_global _ -> + raise Error + let same_value v1 v2 = (v1 == v2) + end) + + let print_untyped_exception ppf obj = + !print_out_value ppf (Printer.outval_of_untyped_exception obj) + let outval_of_value env obj ty = + Printer.outval_of_value !max_printer_steps !max_printer_depth + (fun _ _ _ -> None) env obj ty + let print_value env obj ppf ty = + !print_out_value ppf (outval_of_value env obj ty) + + (* Print an exception produced by an evaluation *) + + let print_out_exception ppf exn outv = + !print_out_phrase ppf (Ophr_exception (exn, outv)) + + let print_exception_outcome ppf exn = + if exn = Out_of_memory then Gc.full_major (); + let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in + print_out_exception ppf exn outv; + if Printexc.backtrace_status () + then + match !backtrace with + | None -> () + | Some b -> + print_string b; + backtrace := None + + type ('a, 'b) gen_printer = ('a, 'b) Genprintval.gen_printer = + | Zero of 'b + | Succ of ('a -> ('a, 'b) gen_printer) + + let install_printer = Printer.install_printer + let install_generic_printer = Printer.install_generic_printer + let install_generic_printer' = Printer.install_generic_printer' + let remove_printer = Printer.remove_printer + +end + + +(* Hook for initialization *) + +let toplevel_startup_hook = ref (fun () -> ()) + +type event = .. +type event += + | Startup + | After_setup + +let hooks = ref [] + +let add_hook f = hooks := f :: !hooks + +let () = + add_hook (function + | Startup -> !toplevel_startup_hook () + | _ -> ()) + +let run_hooks hook = List.iter (fun f -> f hook) !hooks + +(* Helpers for execution *) + +type evaluation_outcome = Result of Obj.t | Exception of exn + +let record_backtrace () = + if Printexc.backtrace_status () + then backtrace := Some (Printexc.get_backtrace ()) + +let preprocess_phrase ppf phr = + let phr = + match phr with + | Ptop_def str -> + let str = + Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str + in + Ptop_def str + | phr -> phr + in + if !Clflags.dump_parsetree then Printast.top_phrase ppf phr; + if !Clflags.dump_source then Pprintast.top_phrase ppf phr; + phr + +(* Phrase buffer that stores the last toplevel phrase (see + [Location.input_phrase_buffer]). *) +let phrase_buffer = Buffer.create 1024 + +(* Reading function for interactive use *) + +let first_line = ref true +let got_eof = ref false + +let read_input_default prompt buffer len = + output_string stdout prompt; flush stdout; + let i = ref 0 in + try + while true do + if !i >= len then raise Exit; + let c = input_char stdin in + Bytes.set buffer !i c; + (* Also populate the phrase buffer as new characters are added. *) + Buffer.add_char phrase_buffer c; + incr i; + if c = '\n' then raise Exit; + done; + (!i, false) + with + | End_of_file -> + (!i, true) + | Exit -> + (!i, false) + +let read_interactive_input = ref read_input_default + +let refill_lexbuf buffer len = + if !got_eof then (got_eof := false; 0) else begin + let prompt = + if !Clflags.noprompt then "" + else if !first_line then "# " + else if !Clflags.nopromptcont then "" + else if Lexer.in_comment () then "* " + else " " + in + first_line := false; + let (len, eof) = !read_interactive_input prompt buffer len in + if eof then begin + Location.echo_eof (); + if len > 0 then got_eof := true; + len + end else + len + end + +let set_paths () = + (* Add whatever -I options have been specified on the command line, + but keep the directories that user code linked in with ocamlmktop + may have added to load_path. *) + let expand = Misc.expand_directory Config.standard_library in + let current_load_path = Load_path.get_paths () in + let load_path = List.concat [ + [ "" ]; + List.map expand (List.rev !Compenv.first_include_dirs); + List.map expand (List.rev !Clflags.include_dirs); + List.map expand (List.rev !Compenv.last_include_dirs); + current_load_path; + [expand "+camlp4"]; + ] + in + Load_path.init ~auto_include:Compmisc.auto_include load_path; + Dll.add_path load_path + +let initialize_toplevel_env () = + toplevel_env := Compmisc.initial_env(); + toplevel_sig := [] + +external caml_sys_modify_argv : string array -> unit = + "caml_sys_modify_argv" + +let override_sys_argv new_argv = + caml_sys_modify_argv new_argv; + Arg.current := 0 + + +(* The table of toplevel directives. + Filled by functions from module topdirs. *) + +type directive_fun = + | Directive_none of (unit -> unit) + | Directive_string of (string -> unit) + | Directive_int of (int -> unit) + | Directive_ident of (Longident.t -> unit) + | Directive_bool of (bool -> unit) + +type directive_info = { + section: string; + doc: string; +} + +let directive_table = (Hashtbl.create 23 : (string, directive_fun) Hashtbl.t) + +let directive_info_table = + (Hashtbl.create 23 : (string, directive_info) Hashtbl.t) + +let add_directive name dir_fun dir_info = + Hashtbl.add directive_table name dir_fun; + Hashtbl.add directive_info_table name dir_info + +let get_directive name = + Hashtbl.find_opt directive_table name + +let get_directive_info name = + Hashtbl.find_opt directive_info_table name + +let all_directive_names () = + Hashtbl.fold (fun dir _ acc -> dir::acc) directive_table [] + +let try_run_directive ppf dir_name pdir_arg = + begin match get_directive dir_name with + | None -> + fprintf ppf "Unknown directive `%s'." dir_name; + let directives = all_directive_names () in + Misc.did_you_mean ppf + (fun () -> Misc.spellcheck directives dir_name); + fprintf ppf "@."; + false + | Some d -> + match d, pdir_arg with + | Directive_none f, None -> f (); true + | Directive_string f, Some {pdira_desc = Pdir_string s} -> f s; true + | Directive_int f, Some {pdira_desc = Pdir_int (n,None) } -> + begin match Misc.Int_literal_converter.int n with + | n -> f n; true + | exception _ -> + fprintf ppf "Integer literal exceeds the range of \ + representable integers for directive `%s'.@." + dir_name; + false + end + | Directive_int _, Some {pdira_desc = Pdir_int (_, Some _)} -> + fprintf ppf "Wrong integer literal for directive `%s'.@." + dir_name; + false + | Directive_ident f, Some {pdira_desc = Pdir_ident lid} -> f lid; true + | Directive_bool f, Some {pdira_desc = Pdir_bool b} -> f b; true + | _ -> + let dir_type = match d with + | Directive_none _ -> "no argument" + | Directive_string _ -> "a `string' literal" + | Directive_int _ -> "an `int' literal" + | Directive_ident _ -> "an identifier" + | Directive_bool _ -> "a `bool' literal" + in + let arg_type = match pdir_arg with + | None -> "no argument" + | Some {pdira_desc = Pdir_string _} -> "a `string' literal" + | Some {pdira_desc = Pdir_int _} -> "an `int' literal" + | Some {pdira_desc = Pdir_ident _} -> "an identifier" + | Some {pdira_desc = Pdir_bool _} -> "a `bool' literal" + in + fprintf ppf "Directive `%s' expects %s, got %s.@." + dir_name dir_type arg_type; + false + end diff --git a/ocaml/toplevel/opttoploop.mli b/ocaml/toplevel/topcommon.mli similarity index 50% rename from ocaml/toplevel/opttoploop.mli rename to ocaml/toplevel/topcommon.mli index 8345ec29b9b..257a20cf6ab 100644 --- a/ocaml/toplevel/opttoploop.mli +++ b/ocaml/toplevel/topcommon.mli @@ -13,93 +13,47 @@ (* *) (**************************************************************************) -open Format +(** This module provides common implementations for internals of [Toploop], for + bytecode and native code (see [Topeval] for the diverging parts of the + implementation). -(* Set the load paths, before running anything *) + You should not use it directly, refer to the functions in [Toploop] instead. +*) -val set_paths : unit -> unit +(**/**) -(* The interactive toplevel loop *) +(* Definitions for the interactive toplevel loop that are common between + bytecode and native *) -val loop : formatter -> unit +open Format -(* Read and execute a script from the given file *) +(* Set the load paths, before running anything *) -val run_script : formatter -> string -> string array -> bool - (* true if successful, false if error *) +val set_paths : unit -> unit -(* Interface with toplevel directives *) +(* Management and helpers for the execution *) -type directive_fun = - | Directive_none of (unit -> unit) - | Directive_string of (string -> unit) - | Directive_int of (int -> unit) - | Directive_ident of (Longident.t -> unit) - | Directive_bool of (bool -> unit) - -val directive_table : (string, directive_fun) Hashtbl.t - (* Table of known directives, with their execution function *) val toplevel_env : Env.t ref (* Typing environment for the toplevel *) +val toplevel_sig : Types.signature ref val initialize_toplevel_env : unit -> unit (* Initialize the typing environment for the toplevel *) -val print_exception_outcome : formatter -> exn -> unit - (* Print an exception resulting from the evaluation of user code. *) -val execute_phrase : bool -> formatter -> Parsetree.toplevel_phrase -> bool - (* Execute the given toplevel phrase. Return [true] if the - phrase executed with no errors and [false] otherwise. - First bool says whether the values and types of the results - should be printed. Uncaught exceptions are always printed. *) val preprocess_phrase : formatter -> Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase (* Preprocess the given toplevel phrase using regular and ppx preprocessors. Return the updated phrase. *) -val use_file : formatter -> string -> bool -val use_output : formatter -> string -> bool -val use_silently : formatter -> string -> bool -val mod_use_file : formatter -> string -> bool - (* Read and execute commands from a file. - [use_file] prints the types and values of the results. - [use_silently] does not print them. - [mod_use_file] wrap the file contents into a module. *) -val eval_module_path: Env.t -> Path.t -> Obj.t -val eval_value_path: Env.t -> Path.t -> Obj.t -val eval_extension_path: Env.t -> Path.t -> Obj.t -val eval_class_path: Env.t -> Path.t -> Obj.t - (* Return the toplevel object referred to by the given path *) - -(* Printing of values *) +val record_backtrace : unit -> unit -val print_value: Env.t -> Obj.t -> formatter -> Types.type_expr -> unit -val print_untyped_exception: formatter -> Obj.t -> unit -type ('a, 'b) gen_printer = - | Zero of 'b - | Succ of ('a -> ('a, 'b) gen_printer) +(* Printing of values *) -val install_printer : - Path.t -> Types.type_expr -> (formatter -> Obj.t -> unit) -> unit -val install_generic_printer : - Path.t -> Path.t -> - (int -> (int -> Obj.t -> Outcometree.out_value, - Obj.t -> Outcometree.out_value) gen_printer) -> unit -val install_generic_printer' : - Path.t -> Path.t -> (formatter -> Obj.t -> unit, - formatter -> Obj.t -> unit) gen_printer -> unit -val remove_printer : Path.t -> unit +val find_eval_phrase : + Typedtree.structure -> + (Typedtree.expression * Typedtree.attributes * Location.t) option val max_printer_depth: int ref val max_printer_steps: int ref -(* Hooks for external parsers and printers *) - -val parse_toplevel_phrase : (Lexing.lexbuf -> Parsetree.toplevel_phrase) ref -val parse_use_file : (Lexing.lexbuf -> Parsetree.toplevel_phrase list) ref -val print_location : formatter -> Location.t -> unit -val print_error : formatter -> Location.error -> unit -val print_warning : Location.t -> formatter -> Warnings.t -> unit -val input_name : string ref - val print_out_value : (formatter -> Outcometree.out_value -> unit) ref val print_out_type : @@ -117,8 +71,115 @@ val print_out_signature : val print_out_phrase : (formatter -> Outcometree.out_phrase -> unit) ref + +exception Undefined_global of string + +module type EVAL_BASE = sig + + val eval_compilation_unit: Compilation_unit.t -> Obj.t + + (* Return the value referred to by a base ident + @raise [Undefined_global] if not found *) + val eval_ident: Ident.t -> Obj.t + +end + + +module MakeEvalPrinter (_ : EVAL_BASE) : sig + + val eval_address: Env.address -> Obj.t + (* Used for printers *) + + val eval_module_path: Env.t -> Path.t -> Obj.t + val eval_value_path: Env.t -> Path.t -> Obj.t + val eval_extension_path: Env.t -> Path.t -> Obj.t + val eval_class_path: Env.t -> Path.t -> Obj.t + (* Return the toplevel object referred to by the given path *) + + module Printer: Genprintval.S with type t = Obj.t + + val print_value: Env.t -> Printer.t -> formatter -> Types.type_expr -> unit + + val print_untyped_exception: formatter -> Printer.t -> unit + + val print_exception_outcome : formatter -> exn -> unit + (* Print an exception resulting from the evaluation of user code. *) + + val outval_of_value: + Env.t -> Printer.t -> Types.type_expr -> Outcometree.out_value + + type ('a, 'b) gen_printer = + | Zero of 'b + | Succ of ('a -> ('a, 'b) gen_printer) + + val install_printer : + Path.t -> Types.type_expr -> (formatter -> Printer.t -> unit) -> unit + val install_generic_printer : + Path.t -> Path.t -> + (int -> (int -> Printer.t -> Outcometree.out_value, + Printer.t-> Outcometree.out_value) gen_printer) -> unit + val install_generic_printer' : + Path.t -> Path.t -> (formatter -> Printer.t -> unit, + formatter -> Printer.t -> unit) gen_printer -> unit + val remove_printer : Path.t -> unit + +end + + +(* Interface with toplevel directives *) + +type directive_fun = + | Directive_none of (unit -> unit) + | Directive_string of (string -> unit) + | Directive_int of (int -> unit) + | Directive_ident of (Longident.t -> unit) + | Directive_bool of (bool -> unit) + +type directive_info = { + section: string; + doc: string; +} + +(* Add toplevel directive and its documentation. + @since 4.03 *) +val add_directive : string -> directive_fun -> directive_info -> unit + +val get_directive : string -> directive_fun option + +val get_directive_info : string -> directive_info option + +val all_directive_names : unit -> string list + +val try_run_directive : + formatter -> string -> Parsetree.directive_argument option -> bool + +val[@deprecated] directive_table : (string, directive_fun) Hashtbl.t + (* @deprecated please use [add_directive] instead of inserting + in this table directly. *) + +val[@deprecated] directive_info_table : (string, directive_info) Hashtbl.t + (* @deprecated please use [add_directive] instead of inserting + in this table directly. *) + +(* Hooks for external parsers and printers *) + +val parse_toplevel_phrase : (Lexing.lexbuf -> Parsetree.toplevel_phrase) ref +val parse_use_file : (Lexing.lexbuf -> Parsetree.toplevel_phrase list) ref +val print_location : formatter -> Location.t -> unit +val print_error : formatter -> Location.error -> unit +val print_warning : Location.t -> formatter -> Warnings.t -> unit +val input_name : string ref + (* Hooks for external line editor *) +(* Phrase buffer that stores the last toplevel phrase (see + [Location.input_phrase_buffer]). *) +val phrase_buffer : Buffer.t + +val first_line : bool ref + +val got_eof : bool ref + val read_interactive_input : (string -> bytes -> int -> int * bool) ref (* Hooks *) @@ -141,7 +202,6 @@ val add_hook : (event -> unit) -> unit val run_hooks : event -> unit (* Run all the registered hooks. *) - (* Misc *) val override_sys_argv : string array -> unit @@ -151,3 +211,16 @@ val override_sys_argv : string array -> unit This is called by [run_script] so that [Sys.argv] represents "script.ml args..." instead of the full command line: "ocamlrun unix.cma ... script.ml args...". *) + +(**/**) + +(* internal functions used by [Topeval] *) + +type evaluation_outcome = Result of Obj.t | Exception of exn + +val backtrace: string option ref + +val parse_mod_use_file: + string -> Lexing.lexbuf -> Parsetree.toplevel_phrase list + +val refill_lexbuf: bytes -> int -> int diff --git a/ocaml/toplevel/topdirs.ml b/ocaml/toplevel/topdirs.ml index 729f6ba15bf..02c72b427fc 100644 --- a/ocaml/toplevel/topdirs.ml +++ b/ocaml/toplevel/topdirs.ml @@ -19,13 +19,17 @@ open Format open Misc open Longident open Types -open Cmo_format -open Trace open Toploop -module Alloc_mode = Btype.Alloc_mode -(* The standard output formatter *) -let std_out = std_formatter +let error_fmt () = + if !Sys.interactive then + Format.std_formatter + else + Format.err_formatter + +let action_on_suberror b = + if not b && not !Sys.interactive then + raise (Compenv.Exit_with_status 125) (* Directive sections (used in #help) *) let section_general = "General" @@ -55,7 +59,7 @@ let order_of_sections = section_undocumented; ]) (* Do not forget to keep the directives synchronized with the manual in - manual/manual/cmds/top.etex *) + manual/src/cmds/top.etex *) (* To quit *) @@ -73,7 +77,7 @@ let dir_directory s = let d = expand_directory Config.standard_library s in Dll.add_path [d]; let dir = Load_path.Dir.create d in - Load_path.add dir; + Load_path.prepend_dir dir; toplevel_env := Stdlib.String.Set.fold (fun name env -> @@ -105,6 +109,16 @@ let _ = add_directive "remove_directory" (Directive_string dir_remove_directory) section = section_run; doc = "Remove the given directory from the search path."; } + +let dir_show_dirs () = + List.iter print_endline (Load_path.get_paths ()) + +let _ = add_directive "show_dirs" (Directive_none dir_show_dirs) + { + section = section_run; + doc = "List directories currently in the search path."; + } + (* To change the current directory *) let dir_cd s = Sys.chdir s @@ -114,150 +128,54 @@ let _ = add_directive "cd" (Directive_string dir_cd) section = section_run; doc = "Change the current working directory."; } -(* Load in-core a .cmo file *) - -exception Load_failed - -let check_consistency ppf filename cu = - try Env.import_crcs ~source:filename cu.cu_imports - with Persistent_env.Consistbl.Inconsistency { - unit_name = name; - inconsistent_source = user; - original_source = auth; - } -> - fprintf ppf "@[The files %s@ and %s@ \ - disagree over interface %s@]@." - user auth name; - raise Load_failed - -let load_compunit ic filename ppf compunit = - check_consistency ppf filename compunit; - seek_in ic compunit.cu_pos; - let code_size = compunit.cu_codesize + 8 in - let code = LongString.create code_size in - LongString.input_bytes_into code ic compunit.cu_codesize; - LongString.set code compunit.cu_codesize (Char.chr Opcodes.opRETURN); - LongString.blit_string "\000\000\000\001\000\000\000" 0 - code (compunit.cu_codesize + 1) 7; - let initial_symtable = Symtable.current_state() in - Symtable.patch_object code compunit.cu_reloc; - Symtable.update_global_table(); - let events = - if compunit.cu_debug = 0 then [| |] - else begin - seek_in ic compunit.cu_debug; - [| input_value ic |] - end in - begin try - may_trace := true; - let _bytecode, closure = Meta.reify_bytecode code events None in - ignore (closure ()); - may_trace := false; - with exn -> - record_backtrace (); - may_trace := false; - Symtable.restore_state initial_symtable; - print_exception_outcome ppf exn; - raise Load_failed - end -let rec load_file recursive ppf name = - let filename = - try Some (Load_path.find name) with Not_found -> None - in - match filename with - | None -> fprintf ppf "Cannot find file %s.@." name; false - | Some filename -> - let ic = open_in_bin filename in - Misc.try_finally - ~always:(fun () -> close_in ic) - (fun () -> really_load_file recursive ppf name filename ic) - -and really_load_file recursive ppf name filename ic = - let buffer = really_input_string ic (String.length Config.cmo_magic_number) in - try - if buffer = Config.cmo_magic_number then begin - let compunit_pos = input_binary_int ic in (* Go to descriptor *) - seek_in ic compunit_pos; - let cu : compilation_unit_descr = input_value ic in - if recursive then - List.iter - (function - | (Reloc_getglobal id, _) - when not (Symtable.is_global_defined id) -> - let file = Ident.name id ^ ".cmo" in - begin match Load_path.find_uncap file with - | exception Not_found -> () - | file -> - if not (load_file recursive ppf file) then raise Load_failed - end - | _ -> () - ) - cu.cu_reloc; - load_compunit ic filename ppf cu; - true - end else - if buffer = Config.cma_magic_number then begin - let toc_pos = input_binary_int ic in (* Go to table of contents *) - seek_in ic toc_pos; - let lib = (input_value ic : library) in - List.iter - (fun dllib -> - let name = Dll.extract_dll_name dllib in - try Dll.open_dlls Dll.For_execution [name] - with Failure reason -> - fprintf ppf - "Cannot load required shared library %s.@.Reason: %s.@." - name reason; - raise Load_failed) - lib.lib_dllibs; - List.iter (load_compunit ic filename ppf) lib.lib_units; - true - end else begin - fprintf ppf "File %s is not a bytecode object file.@." name; - false - end - with Load_failed -> false - -let dir_load ppf name = ignore (load_file false ppf name) - -let _ = add_directive "load" (Directive_string (dir_load std_out)) + +let with_error_fmt f x = f (error_fmt ()) x + +let dir_load ppf name = + action_on_suberror (Topeval.load_file false ppf name) + +let _ = add_directive "load" (Directive_string (with_error_fmt dir_load)) { section = section_run; doc = "Load in memory a bytecode object, produced by ocamlc."; } -let dir_load_rec ppf name = ignore (load_file true ppf name) +let dir_load_rec ppf name = + action_on_suberror (Topeval.load_file true ppf name) let _ = add_directive "load_rec" - (Directive_string (dir_load_rec std_out)) + (Directive_string (with_error_fmt dir_load_rec)) { section = section_run; doc = "As #load, but loads dependencies recursively."; } -let load_file = load_file false +let load_file = Topeval.load_file false (* Load commands from a file *) -let dir_use ppf name = ignore(Toploop.use_file ppf name) -let dir_use_output ppf name = ignore(Toploop.use_output ppf name) -let dir_mod_use ppf name = ignore(Toploop.mod_use_file ppf name) +let dir_use ppf name = + action_on_suberror (Toploop.use_input ppf (Toploop.File name)) +let dir_use_output ppf name = action_on_suberror (Toploop.use_output ppf name) +let dir_mod_use ppf name = + action_on_suberror (Toploop.mod_use_input ppf (Toploop.File name)) -let _ = add_directive "use" (Directive_string (dir_use std_out)) +let _ = add_directive "use" (Directive_string (with_error_fmt dir_use)) { section = section_run; doc = "Read, compile and execute source phrases from the given file."; } -let _ = add_directive "use_output" (Directive_string (dir_use_output std_out)) +let _ = add_directive "use_output" + (Directive_string (with_error_fmt dir_use_output)) { section = section_run; doc = "Execute a command and read, compile and execute source phrases \ from its output."; } -let _ = add_directive "mod_use" (Directive_string (dir_mod_use std_out)) +let _ = add_directive "mod_use" (Directive_string (with_error_fmt dir_mod_use)) { section = section_run; doc = "Usage is identical to #use but #mod_use \ @@ -266,25 +184,34 @@ let _ = add_directive "mod_use" (Directive_string (dir_mod_use std_out)) (* Install, remove a printer *) +exception Bad_printing_function + let filter_arrow ty = let ty = Ctype.expand_head !toplevel_env ty in - match ty.desc with + match get_desc ty with | Tarrow ((lbl,_,_), l, r, _) when not (Btype.is_optional lbl) -> Some (l, r) | _ -> None let rec extract_last_arrow desc = match filter_arrow desc with - | None -> raise (Ctype.Unify []) + | None -> raise Bad_printing_function | Some (_, r as res) -> try extract_last_arrow r - with Ctype.Unify _ -> res + with Bad_printing_function -> res + +let extract_target_type ty = + let ty = fst (extract_last_arrow ty) in + match Ctype.filter_mono ty with + | exception Ctype.Filter_mono_failed -> + raise Bad_printing_function + | ty -> ty -let extract_target_type ty = fst (extract_last_arrow ty) let extract_target_parameters ty = let ty = extract_target_type ty |> Ctype.expand_head !toplevel_env in - match ty.desc with + match get_desc ty with | Tconstr (path, (_ :: _ as args), _) - when Ctype.all_distinct_vars !toplevel_env args -> Some (path, args) + when Ctype.all_distinct_vars !toplevel_env args -> + Some (path, args) | _ -> None type 'a printer_type_new = Format.formatter -> 'a -> unit @@ -306,9 +233,13 @@ let printer_type ppf typename = let match_simple_printer_type desc printer_type = Ctype.begin_def(); let ty_arg = Ctype.newvar() in - Ctype.unify !toplevel_env - (Ctype.newconstr printer_type [ty_arg]) - (Ctype.instance desc.val_type); + begin try + Ctype.unify !toplevel_env + (Ctype.newconstr printer_type [ty_arg]) + (Ctype.instance desc.val_type); + with Ctype.Unify _ -> + raise Bad_printing_function + end; Ctype.end_def(); Ctype.generalize ty_arg; (ty_arg, None) @@ -321,18 +252,24 @@ let match_generic_printer_type desc path args printer_type = List.map (fun ty_var -> Ctype.newconstr printer_type [ty_var]) args in let ty_expected = List.fold_right - (fun ty_arg ty -> Ctype.newty - (Tarrow ((Asttypes.Nolabel,Alloc_mode.global,Alloc_mode.global), - ty_arg, ty, - Cunknown))) + (fun ty_arg ty -> + let arrow_desc = + Asttypes.Nolabel,Alloc_mode.global,Alloc_mode.global + in + Ctype.newty + (Tarrow (arrow_desc, Ctype.newmono ty_arg, ty, commu_var ()))) ty_args (Ctype.newconstr printer_type [ty_target]) in - Ctype.unify !toplevel_env - ty_expected - (Ctype.instance desc.val_type); + begin try + Ctype.unify !toplevel_env + ty_expected + (Ctype.instance desc.val_type); + with Ctype.Unify _ -> + raise Bad_printing_function + end; Ctype.end_def(); Ctype.generalize ty_expected; if not (Ctype.all_distinct_vars !toplevel_env args) then - raise (Ctype.Unify []); + raise Bad_printing_function; (ty_expected, Some (path, ty_args)) let match_printer_type ppf desc = @@ -340,10 +277,10 @@ let match_printer_type ppf desc = let printer_type_old = printer_type ppf "printer_type_old" in try (match_simple_printer_type desc printer_type_new, false) - with Ctype.Unify _ -> + with Bad_printing_function -> try (match_simple_printer_type desc printer_type_old, true) - with Ctype.Unify _ as exn -> + with Bad_printing_function as exn -> match extract_target_parameters desc.val_type with | None -> raise exn | Some (path, args) -> @@ -355,8 +292,8 @@ let find_printer_type ppf lid = | (path, desc) -> begin match match_printer_type ppf desc with | (ty_arg, is_old_style) -> (ty_arg, path, is_old_style) - | exception Ctype.Unify _ -> - fprintf ppf "%a has a wrong type for a printing function.@." + | exception Bad_printing_function -> + fprintf ppf "%a has the wrong type for a printing function.@." Printtyp.longident lid; raise Exit end @@ -403,94 +340,22 @@ let dir_remove_printer ppf lid = with Exit -> () let _ = add_directive "install_printer" - (Directive_ident (dir_install_printer std_out)) + (Directive_ident (with_error_fmt dir_install_printer)) { section = section_print; doc = "Registers a printer for values of a certain type."; } let _ = add_directive "remove_printer" - (Directive_ident (dir_remove_printer std_out)) + (Directive_ident (with_error_fmt dir_remove_printer)) { section = section_print; doc = "Remove the named function from the table of toplevel printers."; } -(* The trace *) - -external current_environment: unit -> Obj.t = "caml_get_current_environment" - -let tracing_function_ptr = - get_code_pointer - (Obj.repr (fun arg -> Trace.print_trace (current_environment()) arg)) - -let dir_trace ppf lid = - match Env.find_value_by_name lid !toplevel_env with - | (path, desc) -> begin - (* Check if this is a primitive *) - match desc.val_kind with - | Val_prim _ -> - fprintf ppf "%a is an external function and cannot be traced.@." - Printtyp.longident lid - | _ -> - let clos = eval_value_path !toplevel_env path in - (* Nothing to do if it's not a closure *) - if Obj.is_block clos - && (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag) - && (match Ctype.(repr (expand_head !toplevel_env desc.val_type)) - with {desc=Tarrow _} -> true | _ -> false) - then begin - match is_traced clos with - | Some opath -> - fprintf ppf "%a is already traced (under the name %a).@." - Printtyp.path path - Printtyp.path opath - | None -> - (* Instrument the old closure *) - traced_functions := - { path = path; - closure = clos; - actual_code = get_code_pointer clos; - instrumented_fun = - instrument_closure !toplevel_env lid ppf desc.val_type } - :: !traced_functions; - (* Redirect the code field of the closure to point - to the instrumentation function *) - set_code_pointer clos tracing_function_ptr; - fprintf ppf "%a is now traced.@." Printtyp.longident lid - end else fprintf ppf "%a is not a function.@." Printtyp.longident lid - end - | exception Not_found -> - fprintf ppf "Unbound value %a.@." Printtyp.longident lid - -let dir_untrace ppf lid = - match Env.find_value_by_name lid !toplevel_env with - | (path, _desc) -> - let rec remove = function - | [] -> - fprintf ppf "%a was not traced.@." Printtyp.longident lid; - [] - | f :: rem -> - if Path.same f.path path then begin - set_code_pointer f.closure f.actual_code; - fprintf ppf "%a is no longer traced.@." Printtyp.longident lid; - rem - end else f :: remove rem in - traced_functions := remove !traced_functions - | exception Not_found -> - fprintf ppf "Unbound value %a.@." Printtyp.longident lid - -let dir_untrace_all ppf () = - List.iter - (fun f -> - set_code_pointer f.closure f.actual_code; - fprintf ppf "%a is no longer traced.@." Printtyp.path f.path) - !traced_functions; - traced_functions := [] - let parse_warnings ppf iserr s = - try Warnings.parse_options iserr s - with Arg.Bad err -> fprintf ppf "%s.@." err + try Option.iter Location.(prerr_alert none) @@ Warnings.parse_options iserr s + with Arg.Bad err -> fprintf ppf "%s.@." err; action_on_suberror true (* Typing information *) @@ -515,7 +380,7 @@ let trim_signature = function | mty -> mty let show_prim to_sig ppf lid = - let env = !Toploop.toplevel_env in + let env = !toplevel_env in let loc = Location.none in try let s = @@ -541,7 +406,7 @@ let reg_show_prim name to_sig doc = all_show_funs := to_sig :: !all_show_funs; add_directive name - (Directive_ident (show_prim to_sig std_out)) + (Directive_ident (show_prim to_sig std_formatter)) { section = section_env; doc; @@ -555,11 +420,40 @@ let () = ) "Print the signature of the corresponding value." +let is_nonrec_type id td = + (* We track both recursive uses of t (`type t = X of t`) and + nonrecursive uses (`type nonrec t = t`) to only print the nonrec keyword + when it is necessary to make the type printable. + *) + let recursive_use = ref false in + let nonrecursive_use = ref false in + let it_path = function + | Path.Pident id' when Ident.name id' = Ident.name id -> + if Ident.same id id' then + recursive_use := true + else + nonrecursive_use:= true + | _ -> () + in + let it = Btype.{type_iterators with it_path } in + let () = + it.it_type_declaration it td; + Btype.unmark_iterators.it_type_declaration Btype.unmark_iterators td + in + match !recursive_use, !nonrecursive_use with + | false, true -> Trec_not + | true, _ | _, false -> Trec_first + (* note: true, true is possible *) + let () = reg_show_prim "show_type" (fun env loc id lid -> - let _path, desc = Env.lookup_type ~loc lid env in - [ Sig_type (id, desc, Trec_not, Exported) ] + let path, desc = Env.lookup_type ~loc lid env in + let id, rs = match path with + | Pident id -> id, is_nonrec_type id desc + | _ -> id, Trec_first + in + [ Sig_type (id, desc, rs, Exported) ] ) "Print the signature of the corresponding type constructor." @@ -569,7 +463,7 @@ let () = * one for exception constructors and another for * non-exception constructors (normal and extensible variants). *) let is_exception_constructor env type_expr = - Ctype.equal env true [type_expr] [Predef.type_exn] + Ctype.is_equal env true [type_expr] [Predef.type_exn] let is_extension_constructor = function | Cstr_extension _ -> true @@ -583,11 +477,7 @@ let () = let desc = Env.lookup_constructor ~loc Env.Positive lid env in if is_exception_constructor env desc.cstr_res then raise Not_found; - let path = - match Ctype.repr desc.cstr_res with - | {desc=Tconstr(path, _, _)} -> path - | _ -> raise Not_found - in + let path = Btype.cstr_type_path desc in let type_decl = Env.find_type path env in if is_extension_constructor desc.cstr_tag then let ret_type = @@ -640,47 +530,103 @@ let () = ) "Print the signature of the corresponding exception." +let is_rec_module id md = + let exception Exit in + let rec it_path = function + | Path.Pdot(root, _ ) -> it_path root + | Path.Pident id' -> if (Ident.same id id') then raise Exit + | _ -> () + in + let it = Btype.{type_iterators with it_path } in + let rs = match it.it_module_declaration it md with + | () -> Trec_not + | exception Exit -> Trec_first + in + Btype.unmark_iterators.it_module_declaration Btype.unmark_iterators md; + rs + +let secretly_the_same_path env path1 path2 = + let norm path = Printtyp.rewrite_double_underscore_paths env path in + Path.same (norm path1) (norm path2) + let () = reg_show_prim "show_module" (fun env loc id lid -> - let rec accum_aliases md acc = - let acc = + let path, md = Env.lookup_module ~loc lid env in + let id = match path with + | Pident id -> id + | _ -> id + in + let rec accum_aliases path md acc = + let def rs = Sig_module (id, Mp_present, {md with md_type = trim_signature md.md_type}, - Trec_not, Exported) :: acc in + rs, Exported) in match md.md_type with - | Mty_alias path -> - let md = Env.find_module path env in - accum_aliases md acc + | Mty_alias new_path -> + let md = Env.find_module new_path env in + accum_aliases new_path md + (if secretly_the_same_path env path new_path + then acc + else def Trec_not :: acc) | Mty_ident _ | Mty_signature _ | Mty_functor _ -> - List.rev acc + List.rev (def (is_rec_module id md) :: acc) in - let _, md = Env.lookup_module ~loc lid env in - accum_aliases md [] + accum_aliases path md [] ) "Print the signature of the corresponding module." let () = reg_show_prim "show_module_type" (fun env loc id lid -> - let _path, desc = Env.lookup_modtype ~loc lid env in - [ Sig_modtype (id, desc, Exported) ] + let path, mtd = Env.lookup_modtype ~loc lid env in + let id = match path with + | Pident id -> id + | _ -> id + in + let rec accum_defs path mtd acc = + let def = Sig_modtype (id, mtd, Exported) in + match mtd.mtd_type with + | Some (Mty_ident new_path) -> + let mtd = Env.find_modtype new_path env in + accum_defs new_path mtd + (if secretly_the_same_path env path new_path + then acc + else def :: acc) + | None | Some (Mty_alias _ | Mty_signature _ | Mty_functor _) -> + List.rev (def :: acc) + in + accum_defs path mtd [] ) "Print the signature of the corresponding module type." let () = reg_show_prim "show_class" (fun env loc id lid -> - let _path, desc = Env.lookup_class ~loc lid env in - [ Sig_class (id, desc, Trec_not, Exported) ] + let path, desc_class = Env.lookup_class ~loc lid env in + let _path, desc_cltype = Env.lookup_cltype ~loc lid env in + let _path, typedcl = Env.lookup_type ~loc lid env in + let hash_typedcl = Env.find_hash_type path env in + [ + Sig_class (id, desc_class, Trec_not, Exported); + Sig_class_type (id, desc_cltype, Trec_not, Exported); + Sig_type (id, typedcl, Trec_not, Exported); + Sig_type (id, hash_typedcl, Trec_not, Exported); + ] ) "Print the signature of the corresponding class." let () = reg_show_prim "show_class_type" (fun env loc id lid -> - let _path, desc = Env.lookup_cltype ~loc lid env in - [ Sig_class_type (id, desc, Trec_not, Exported) ] + let path, desc = Env.lookup_cltype ~loc lid env in + let _path, typedcl = Env.lookup_type ~loc lid env in + let hash_typedcl = Env.find_hash_type path env in + [ + Sig_class_type (id, desc, Trec_not, Exported); + Sig_type (id, typedcl, Trec_not, Exported); + Sig_type (id, hash_typedcl, Trec_not, Exported); + ] ) "Print the signature of the corresponding class type." @@ -693,35 +639,13 @@ let show env loc id lid = if sg = [] then raise Not_found else sg let () = - add_directive "show" (Directive_ident (show_prim show std_out)) + add_directive "show" (Directive_ident (show_prim show std_formatter)) { section = section_env; doc = "Print the signatures of components \ from any of the categories below."; } -let _ = add_directive "trace" - (Directive_ident (dir_trace std_out)) - { - section = section_trace; - doc = "All calls to the function \ - named function-name will be traced."; - } - -let _ = add_directive "untrace" - (Directive_ident (dir_untrace std_out)) - { - section = section_trace; - doc = "Stop tracing the given function."; - } - -let _ = add_directive "untrace_all" - (Directive_none (dir_untrace_all std_out)) - { - section = section_trace; - doc = "Stop tracing all functions traced so far."; - } - (* Control the printing of values *) let _ = add_directive "print_depth" @@ -770,14 +694,14 @@ let _ = add_directive "ppx" } let _ = add_directive "warnings" - (Directive_string (parse_warnings std_out false)) + (Directive_string (with_error_fmt(fun ppf s -> parse_warnings ppf false s))) { section = section_options; doc = "Enable or disable warnings according to the argument."; } let _ = add_directive "warn_error" - (Directive_string (parse_warnings std_out true)) + (Directive_string (with_error_fmt(fun ppf s -> parse_warnings ppf true s))) { section = section_options; doc = "Treat as errors the warnings enabled by the argument."; @@ -787,17 +711,22 @@ let _ = add_directive "warn_error" let directive_sections () = let sections = Hashtbl.create 10 in - let add_dir name dir = + let add_dir name = + let dir = + match get_directive name with + | Some dir -> dir + | None -> assert false + in let section, doc = - match Hashtbl.find directive_info_table name with - | { section; doc } -> section, Some doc - | exception Not_found -> "Undocumented", None + match get_directive_info name with + | Some { section; doc } -> section, Some doc + | None -> "Undocumented", None in Hashtbl.replace sections section ((name, dir, doc) :: (try Hashtbl.find sections section with Not_found -> [])) in - Hashtbl.iter add_dir directive_table; + List.iter add_dir (all_directive_names ()); let take_section section = if not (Hashtbl.mem sections section) then (section, []) else begin @@ -842,7 +771,7 @@ let print_directives ppf () = List.iter (print_section ppf) (directive_sections ()) let _ = add_directive "help" - (Directive_none (print_directives std_out)) + (Directive_none (print_directives std_formatter)) { section = section_general; doc = "Prints a list of all available directives, with \ diff --git a/ocaml/toplevel/topdirs.mli b/ocaml/toplevel/topdirs.mli index 77d36600932..a65ae087206 100644 --- a/ocaml/toplevel/topdirs.mli +++ b/ocaml/toplevel/topdirs.mli @@ -26,12 +26,26 @@ val dir_use : formatter -> string -> unit val dir_use_output : formatter -> string -> unit val dir_install_printer : formatter -> Longident.t -> unit val dir_remove_printer : formatter -> Longident.t -> unit + +(* These are now injected from [Topeval], for the bytecode toplevel only: val dir_trace : formatter -> Longident.t -> unit val dir_untrace : formatter -> Longident.t -> unit val dir_untrace_all : formatter -> unit -> unit + *) + +val section_general : string +val section_run : string +val section_env : string + +val section_print : string +val section_trace : string +val section_options : string + +val section_undocumented : string + type 'a printer_type_new = Format.formatter -> 'a -> unit type 'a printer_type_old = 'a -> unit -(* For topmain.ml. Maybe shouldn't be there *) -val load_file : formatter -> string -> bool +(* Here for backwards compatibility, use [Toploop.load_file]. *) +val[@deprecated] load_file : formatter -> string -> bool diff --git a/ocaml/toplevel/topeval.mli b/ocaml/toplevel/topeval.mli new file mode 100644 index 00000000000..25b1eba98a0 --- /dev/null +++ b/ocaml/toplevel/topeval.mli @@ -0,0 +1,53 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* *) +(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** This module provides two alternative implementations for internals of + [Toploop], for bytecode and native code. + + You should not use it directly, refer to the functions in [Toploop] instead. +*) + +(**/**) + +open Format + +(* Accessors for the table of toplevel value bindings. For the bytecode + toplevel, these functions must appear as first and second exported functions + in this module. + (See module Translmod.) + They aren't used for the native toplevel. +*) +val getvalue : string -> Obj.t +val setvalue : string -> Obj.t -> unit + +(* Label appended after [OCaml version XXX] when starting the toplevel. *) +val implementation_label: string + +val execute_phrase : bool -> formatter -> Parsetree.toplevel_phrase -> bool + (* Read and execute commands from a file. + [use_file] prints the types and values of the results. + [use_silently] does not print them. + [mod_use_file] wrap the file contents into a module. *) + +val may_trace : bool ref + +module EvalBase: Topcommon.EVAL_BASE + +include module type of Topcommon.MakeEvalPrinter(EvalBase) + +(* For topmain.ml. Maybe shouldn't be there *) +val load_file : bool -> formatter -> string -> bool + +val init: unit -> unit diff --git a/ocaml/toplevel/toploop.ml b/ocaml/toplevel/toploop.ml index f9e69b262b5..028bed28635 100644 --- a/ocaml/toplevel/toploop.ml +++ b/ocaml/toplevel/toploop.ml @@ -1,4 +1,4 @@ -# 1 "toplevel/toploop.ml" +# 2 "toplevel/toploop.ml" (**************************************************************************) (* *) (* OCaml *) @@ -14,401 +14,29 @@ (* *) (**************************************************************************) -(* The interactive toplevel loop *) - open Format -open Misc -open Parsetree -open Types -open Typedtree -open Outcometree -open Ast_helper -module String = Misc.Stdlib.String - -type directive_fun = - | Directive_none of (unit -> unit) - | Directive_string of (string -> unit) - | Directive_int of (int -> unit) - | Directive_ident of (Longident.t -> unit) - | Directive_bool of (bool -> unit) - -type directive_info = { - section: string; - doc: string; -} - -(* Phase buffer that stores the last toplevel phrase (see - [Location.input_phrase_buffer]). *) -let phrase_buffer = Buffer.create 1024 - -(* The table of toplevel value bindings and its accessors *) - -let toplevel_value_bindings : Obj.t String.Map.t ref = ref String.Map.empty - -let getvalue name = - try - String.Map.find name !toplevel_value_bindings - with Not_found -> - fatal_error (name ^ " unbound at toplevel") - -let setvalue name v = - toplevel_value_bindings := String.Map.add name v !toplevel_value_bindings - -(* Return the value referred to by a path *) - -let rec eval_address = function - | Env.Aident id -> - if Ident.is_global_or_predef id then - Symtable.get_global_value id - else begin - let name = Translmod.toplevel_name id in - try - String.Map.find name !toplevel_value_bindings - with Not_found -> - raise (Symtable.Error(Symtable.Undefined_global name)) - end - | Env.Adot(p, pos) -> - Obj.field (eval_address p) pos - -let eval_path find env path = - match find path env with - | addr -> eval_address addr - | exception Not_found -> - fatal_error ("Cannot find address for: " ^ (Path.name path)) - -let eval_module_path env path = - eval_path Env.find_module_address env path - -let eval_value_path env path = - eval_path Env.find_value_address env path - -let eval_extension_path env path = - eval_path Env.find_constructor_address env path - -let eval_class_path env path = - eval_path Env.find_class_address env path - -(* To print values *) - -module EvalPath = struct - type valu = Obj.t - exception Error - let eval_address addr = - try eval_address addr with Symtable.Error _ -> raise Error - let same_value v1 v2 = (v1 == v2) -end - -module Printer = Genprintval.Make(Obj)(EvalPath) - -let max_printer_depth = ref 100 -let max_printer_steps = ref 300 - -let print_out_value = Oprint.out_value -let print_out_type = Oprint.out_type -let print_out_class_type = Oprint.out_class_type -let print_out_module_type = Oprint.out_module_type -let print_out_type_extension = Oprint.out_type_extension -let print_out_sig_item = Oprint.out_sig_item -let print_out_signature = Oprint.out_signature -let print_out_phrase = Oprint.out_phrase - -let print_untyped_exception ppf obj = - !print_out_value ppf (Printer.outval_of_untyped_exception obj) -let outval_of_value env obj ty = - Printer.outval_of_value !max_printer_steps !max_printer_depth - (fun _ _ _ -> None) env obj ty -let print_value env obj ppf ty = - !print_out_value ppf (outval_of_value env obj ty) - -type ('a, 'b) gen_printer = ('a, 'b) Genprintval.gen_printer = - | Zero of 'b - | Succ of ('a -> ('a, 'b) gen_printer) - -let install_printer = Printer.install_printer -let install_generic_printer = Printer.install_generic_printer -let install_generic_printer' = Printer.install_generic_printer' -let remove_printer = Printer.remove_printer - -(* Hooks for parsing functions *) - -let parse_toplevel_phrase = ref Parse.toplevel_phrase -let parse_use_file = ref Parse.use_file -let print_location = Location.print_loc -let print_error = Location.print_report -let print_warning = Location.print_warning -let input_name = Location.input_name - -let parse_mod_use_file name lb = - let modname = - String.capitalize_ascii - (Filename.remove_extension (Filename.basename name)) - in - let items = - List.concat - (List.map - (function Ptop_def s -> s | Ptop_dir _ -> []) - (!parse_use_file lb)) - in - [ Ptop_def - [ Str.module_ - (Mb.mk - (Location.mknoloc (Some modname)) - (Mod.structure items) - ) - ] - ] - -(* Hook for initialization *) - -let toplevel_startup_hook = ref (fun () -> ()) - -type event = .. -type event += - | Startup - | After_setup - -let hooks = ref [] - -let add_hook f = hooks := f :: !hooks - -let () = - add_hook (function - | Startup -> !toplevel_startup_hook () - | _ -> ()) - -let run_hooks hook = List.iter (fun f -> f hook) !hooks - -(* Load in-core and execute a lambda term *) - -let may_trace = ref false (* Global lock on tracing *) -type evaluation_outcome = Result of Obj.t | Exception of exn - -let backtrace = ref None - -let record_backtrace () = - if Printexc.backtrace_status () - then backtrace := Some (Printexc.get_backtrace ()) - -let load_lambda ppf lam = - if !Clflags.dump_rawlambda then fprintf ppf "%a@." Printlambda.lambda lam; - let slam = Simplif.simplify_lambda lam in - if !Clflags.dump_lambda then fprintf ppf "%a@." Printlambda.lambda slam; - let (init_code, fun_code) = Bytegen.compile_phrase slam in - if !Clflags.dump_instr then - fprintf ppf "%a%a@." - Printinstr.instrlist init_code - Printinstr.instrlist fun_code; - let (code, reloc, events) = - Emitcode.to_memory init_code fun_code - in - let can_free = (fun_code = []) in - let initial_symtable = Symtable.current_state() in - Symtable.patch_object code reloc; - Symtable.check_global_initialized reloc; - Symtable.update_global_table(); - let initial_bindings = !toplevel_value_bindings in - let bytecode, closure = Meta.reify_bytecode code [| events |] None in - match - may_trace := true; - Fun.protect - ~finally:(fun () -> may_trace := false; - if can_free then Meta.release_bytecode bytecode) - closure - with - | retval -> Result retval - | exception x -> - record_backtrace (); - toplevel_value_bindings := initial_bindings; (* PR#6211 *) - Symtable.restore_state initial_symtable; - Exception x - -(* Print the outcome of an evaluation *) - -let pr_item = - Printtyp.print_items - (fun env -> function - | Sig_value(id, {val_kind = Val_reg; val_type}, _) -> - Some (outval_of_value env (getvalue (Translmod.toplevel_name id)) - val_type) - | _ -> None - ) - -(* The current typing environment for the toplevel *) - -let toplevel_env = ref Env.empty -let toplevel_sig = ref [] - -(* Print an exception produced by an evaluation *) - -let print_out_exception ppf exn outv = - !print_out_phrase ppf (Ophr_exception (exn, outv)) - -let print_exception_outcome ppf exn = - if exn = Out_of_memory then Gc.full_major (); - let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in - print_out_exception ppf exn outv; - if Printexc.backtrace_status () - then - match !backtrace with - | None -> () - | Some b -> - print_string b; - backtrace := None - +include Topcommon +include Topeval -(* Inserting new toplevel directives *) - -let directive_table = (Hashtbl.create 23 : (string, directive_fun) Hashtbl.t) - -let directive_info_table = - (Hashtbl.create 23 : (string, directive_info) Hashtbl.t) - -let add_directive name dir_fun dir_info = - Hashtbl.add directive_table name dir_fun; - Hashtbl.add directive_info_table name dir_info - -(* Execute a toplevel phrase *) - -let execute_phrase print_outcome ppf phr = - match phr with - | Ptop_def sstr -> - let oldenv = !toplevel_env in - let oldsig = !toplevel_sig in - Typecore.reset_delayed_checks (); - let (str, sg, sn, newenv) = - Typemod.type_toplevel_phrase oldenv oldsig sstr - in - if !Clflags.dump_typedtree then Printtyped.implementation ppf str; - let sg' = Typemod.Signature_names.simplify newenv sn sg in - ignore (Includemod.signatures ~mark:Mark_positive oldenv sg sg'); - Typecore.force_delayed_checks (); - let lam = Translmod.transl_toplevel_definition str in - Warnings.check_fatal (); - begin try - toplevel_env := newenv; - toplevel_sig := List.rev_append sg' oldsig; - let res = load_lambda ppf lam in - let out_phr = - match res with - | Result v -> - if print_outcome then - Printtyp.wrap_printing_env ~error:false oldenv (fun () -> - match str.str_items with - | [ { str_desc = - (Tstr_eval (exp, _) - |Tstr_value - (Asttypes.Nonrecursive, - [{vb_pat = {pat_desc=Tpat_any}; - vb_expr = exp} - ] - ) - ) - } - ] -> - let outv = outval_of_value newenv v exp.exp_type in - let ty = Printtyp.tree_of_type_scheme exp.exp_type in - Ophr_eval (outv, ty) - - | [] -> Ophr_signature [] - | _ -> Ophr_signature (pr_item oldenv sg')) - else Ophr_signature [] - | Exception exn -> - toplevel_env := oldenv; - toplevel_sig := oldsig; - if exn = Out_of_memory then Gc.full_major(); - let outv = - outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn - in - Ophr_exception (exn, outv) - in - !print_out_phrase ppf out_phr; - if Printexc.backtrace_status () - then begin - match !backtrace with - | None -> () - | Some b -> - pp_print_string ppf b; - pp_print_flush ppf (); - backtrace := None; - end; - begin match out_phr with - | Ophr_eval (_, _) | Ophr_signature _ -> true - | Ophr_exception _ -> false - end - with x -> - toplevel_env := oldenv; toplevel_sig := oldsig; raise x - end - | Ptop_dir {pdir_name = {Location.txt = dir_name}; pdir_arg } -> - let d = - try Some (Hashtbl.find directive_table dir_name) - with Not_found -> None - in - begin match d with - | None -> - fprintf ppf "Unknown directive `%s'." dir_name; - let directives = - Hashtbl.fold (fun dir _ acc -> dir::acc) directive_table [] in - Misc.did_you_mean ppf - (fun () -> Misc.spellcheck directives dir_name); - fprintf ppf "@."; - false - | Some d -> - match d, pdir_arg with - | Directive_none f, None -> f (); true - | Directive_string f, Some {pdira_desc = Pdir_string s} -> f s; true - | Directive_int f, Some {pdira_desc = Pdir_int (n,None) } -> - begin match Int_literal_converter.int n with - | n -> f n; true - | exception _ -> - fprintf ppf "Integer literal exceeds the range of \ - representable integers for directive `%s'.@." - dir_name; - false - end - | Directive_int _, Some {pdira_desc = Pdir_int (_, Some _)} -> - fprintf ppf "Wrong integer literal for directive `%s'.@." - dir_name; - false - | Directive_ident f, Some {pdira_desc = Pdir_ident lid} -> f lid; true - | Directive_bool f, Some {pdira_desc = Pdir_bool b} -> f b; true - | _ -> - fprintf ppf "Wrong type of argument for directive `%s'.@." - dir_name; - false - end - -let execute_phrase print_outcome ppf phr = - try execute_phrase print_outcome ppf phr - with exn -> - Warnings.reset_fatal (); - raise exn - -(* Read and execute commands from a file, or from stdin if [name] is "". *) +type input = + | Stdin + | File of string + | String of string let use_print_results = ref true -let preprocess_phrase ppf phr = - let phr = - match phr with - | Ptop_def str -> - let str = - Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str - in - Ptop_def str - | phr -> phr - in - if !Clflags.dump_parsetree then Printast.top_phrase ppf phr; - if !Clflags.dump_source then Pprintast.top_phrase ppf phr; - phr +let filename_of_input = function + | File name -> name + | Stdin | String _ -> "" -let use_channel ppf ~wrap_in_module ic name filename = - let lb = Lexing.from_channel ic in +let use_lexbuf ppf ~wrap_in_module lb name filename = Warnings.reset_fatal (); Location.init lb filename; (* Skip initial #! line if any *) Lexer.skip_hash_bang lb; - protect_refs [ R (Location.input_name, filename); - R (Location.input_lexbuf, Some lb); ] + Misc.protect_refs + [ R (Location.input_name, filename); + R (Location.input_lexbuf, Some lb); ] (fun () -> try List.iter @@ -439,92 +67,80 @@ let use_output ppf command = let ic = open_in_bin fn in Misc.try_finally ~always:(fun () -> close_in ic) (fun () -> - use_channel ppf ~wrap_in_module:false ic "" "(command-output)") + let lexbuf = (Lexing.from_channel ic) in + use_lexbuf ppf ~wrap_in_module:false lexbuf "" "(command-output)") | n -> fprintf ppf "Command exited with code %d.@." n; false) -let use_file ppf ~wrap_in_module name = - match name with - | "" -> - use_channel ppf ~wrap_in_module stdin name "(stdin)" - | _ -> +let use_input ppf ~wrap_in_module input = + match input with + | Stdin -> + let lexbuf = Lexing.from_channel stdin in + use_lexbuf ppf ~wrap_in_module lexbuf "" "(stdin)" + | String value -> + let lexbuf = Lexing.from_string value in + use_lexbuf ppf ~wrap_in_module lexbuf "" "(command-line input)" + | File name -> match Load_path.find name with | filename -> let ic = open_in_bin filename in Misc.try_finally ~always:(fun () -> close_in ic) - (fun () -> use_channel ppf ~wrap_in_module ic name filename) + (fun () -> + let lexbuf = Lexing.from_channel ic in + use_lexbuf ppf ~wrap_in_module lexbuf name filename) | exception Not_found -> fprintf ppf "Cannot find file %s.@." name; false -let mod_use_file ppf name = - use_file ppf ~wrap_in_module:true name +let mod_use_input ppf name = + use_input ppf ~wrap_in_module:true name +let use_input ppf name = + use_input ppf ~wrap_in_module:false name let use_file ppf name = - use_file ppf ~wrap_in_module:false name + use_input ppf (File name) let use_silently ppf name = - protect_refs [ R (use_print_results, false) ] (fun () -> use_file ppf name) - -(* Reading function for interactive use *) + Misc.protect_refs + [ R (use_print_results, false) ] + (fun () -> use_input ppf name) -let first_line = ref true -let got_eof = ref false;; +let load_file = load_file false -let read_input_default prompt buffer len = - output_string stdout prompt; flush stdout; - let i = ref 0 in - try - while true do - if !i >= len then raise Exit; - let c = input_char stdin in - Bytes.set buffer !i c; - (* Also populate the phrase buffer as new characters are added. *) - Buffer.add_char phrase_buffer c; - incr i; - if c = '\n' then raise Exit; - done; - (!i, false) - with - | End_of_file -> - (!i, true) - | Exit -> - (!i, false) - -let read_interactive_input = ref read_input_default +(* Execute a script. If [name] is "", read the script from stdin. *) -let refill_lexbuf buffer len = - if !got_eof then (got_eof := false; 0) else begin - let prompt = - if !Clflags.noprompt then "" - else if !first_line then "# " - else if !Clflags.nopromptcont then "" - else if Lexer.in_comment () then "* " - else " " - in - first_line := false; - let (len, eof) = !read_interactive_input prompt buffer len in - if eof then begin - Location.echo_eof (); - if len > 0 then got_eof := true; - len - end else - len - end +let run_script ppf name args = + override_sys_argv args; + let filename = filename_of_input name in + Compmisc.init_path ~dir:(Filename.dirname filename) (); + (* Note: would use [Filename.abspath] here, if we had it. *) + begin + try toplevel_env := Compmisc.initial_env() + with Env.Error _ | Typetexp.Error _ as exn -> + Location.report_exception ppf exn; raise (Compenv.Exit_with_status 2) + end; + Sys.interactive := false; + run_hooks After_setup; + let explicit_name = + match name with + | File name as filename -> ( + (* Prevent use_silently from searching in the path. *) + if name <> "" && Filename.is_implicit name + then File (Filename.concat Filename.current_dir_name name) + else filename) + | (Stdin | String _) as x -> x + in + use_silently ppf explicit_name (* Toplevel initialization. Performed here instead of at the beginning of loop() so that user code linked in with ocamlmktop can call directives from Topdirs. *) - let _ = if !Sys.interactive then (* PR#6108 *) invalid_arg "The ocamltoplevel.cma library from compiler-libs \ cannot be loaded inside the OCaml toplevel"; Sys.interactive := true; - let crc_intfs = Symtable.init_toplevel() in - Compmisc.init_path (); - Env.import_crcs ~source:Sys.executable_name crc_intfs; - () + Topeval.init () let find_ocamlinit () = let ocamlinit = ".ocamlinit" in @@ -556,35 +172,13 @@ let find_ocamlinit () = let load_ocamlinit ppf = if !Clflags.noinit then () else match !Clflags.init_file with - | Some f -> if Sys.file_exists f then ignore (use_silently ppf f) - else fprintf ppf "Init file not found: \"%s\".@." f + | Some f -> + if Sys.file_exists f then ignore (use_silently ppf (File f) ) + else fprintf ppf "Init file not found: \"%s\".@." f | None -> match find_ocamlinit () with | None -> () - | Some file -> ignore (use_silently ppf file) -;; - -let set_paths () = - (* Add whatever -I options have been specified on the command line, - but keep the directories that user code linked in with ocamlmktop - may have added to load_path. *) - let expand = Misc.expand_directory Config.standard_library in - let current_load_path = Load_path.get_paths () in - let load_path = List.concat [ - [ "" ]; - List.map expand (List.rev !Compenv.first_include_dirs); - List.map expand (List.rev !Clflags.include_dirs); - List.map expand (List.rev !Compenv.last_include_dirs); - current_load_path; - [expand "+camlp4"]; - ] - in - Load_path.init load_path; - Dll.add_path load_path - -let initialize_toplevel_env () = - toplevel_env := Compmisc.initial_env(); - toplevel_sig := [] + | Some file -> ignore (use_silently ppf (File file)) (* The interactive loop *) @@ -594,7 +188,10 @@ let loop ppf = Clflags.debug := true; Location.formatter_for_warnings := ppf; if not !Clflags.noversion then - fprintf ppf " OCaml version %s@.@." Config.version; + fprintf ppf "OCaml version %s%s%s@.Enter #help;; for help.@.@." + Config.version + (if Topeval.implementation_label = "" then "" else " - ") + Topeval.implementation_label; begin try initialize_toplevel_env () with Env.Error _ | Typetexp.Error _ as exn -> @@ -627,31 +224,3 @@ let loop ppf = | PPerror -> () | x -> Location.report_exception ppf x; Btype.backtrack snap done - -external caml_sys_modify_argv : string array -> unit = - "caml_sys_modify_argv" - -let override_sys_argv new_argv = - caml_sys_modify_argv new_argv; - Arg.current := 0 - -(* Execute a script. If [name] is "", read the script from stdin. *) - -let run_script ppf name args = - override_sys_argv args; - Compmisc.init_path ~dir:(Filename.dirname name) (); - (* Note: would use [Filename.abspath] here, if we had it. *) - begin - try initialize_toplevel_env () - with Env.Error _ | Typetexp.Error _ as exn -> - Location.report_exception ppf exn; raise (Compenv.Exit_with_status 2) - end; - Sys.interactive := false; - run_hooks After_setup; - let explicit_name = - (* Prevent use_silently from searching in the path. *) - if name <> "" && Filename.is_implicit name - then Filename.concat Filename.current_dir_name name - else name - in - use_silently ppf explicit_name diff --git a/ocaml/toplevel/toploop.mli b/ocaml/toplevel/toploop.mli index 45a43bc3f6b..c5b6cb2fc6a 100644 --- a/ocaml/toplevel/toploop.mli +++ b/ocaml/toplevel/toploop.mli @@ -15,12 +15,21 @@ open Format +(* type of toplevel inputs *) +type input = + | Stdin + | File of string + | String of string + (* Accessors for the table of toplevel value bindings. These functions must appear as first and second exported functions in this module. (See module Translmod.) *) val getvalue : string -> Obj.t val setvalue : string -> Obj.t -> unit + +val filename_of_input: input -> string + (* Set the load paths, before running anything *) val set_paths : unit -> unit @@ -31,7 +40,7 @@ val loop : formatter -> unit (* Read and execute a script from the given file *) -val run_script : formatter -> string -> string array -> bool +val run_script : formatter -> input -> string array -> bool (* true if successful, false if error *) (* Interface with toplevel directives *) @@ -53,11 +62,19 @@ val add_directive : string -> directive_fun -> directive_info -> unit @since 4.03 *) -val directive_table : (string, directive_fun) Hashtbl.t - (* Deprecated: please use [add_directive] instead of inserting +val get_directive : string -> directive_fun option + +val get_directive_info : string -> directive_info option + +val all_directive_names : unit -> string list + +val[@deprecated] directive_table : (string, directive_fun) Hashtbl.t + (* @deprecated please use [add_directive] instead of inserting in this table directly. *) -val directive_info_table : (string, directive_info) Hashtbl.t +val[@deprecated] directive_info_table : (string, directive_info) Hashtbl.t + (* @deprecated please use [add_directive] instead of inserting + in this table directly. *) val toplevel_env : Env.t ref (* Typing environment for the toplevel *) @@ -74,14 +91,15 @@ val preprocess_phrase : formatter -> Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase (* Preprocess the given toplevel phrase using regular and ppx preprocessors. Return the updated phrase. *) -val use_file : formatter -> string -> bool +val use_input : formatter -> input -> bool val use_output : formatter -> string -> bool -val use_silently : formatter -> string -> bool -val mod_use_file : formatter -> string -> bool +val use_silently : formatter -> input -> bool +val mod_use_input : formatter -> input -> bool +val use_file : formatter -> string -> bool (* Read and execute commands from a file. - [use_file] prints the types and values of the results. + [use_input] prints the types and values of the results. [use_silently] does not print them. - [mod_use_file] wrap the file contents into a module. *) + [mod_use_input] wrap the file contents into a module. *) val eval_module_path: Env.t -> Path.t -> Obj.t val eval_value_path: Env.t -> Path.t -> Obj.t val eval_extension_path: Env.t -> Path.t -> Obj.t @@ -89,6 +107,8 @@ val eval_class_path: Env.t -> Path.t -> Obj.t (* Return the toplevel object referred to by the given path *) val record_backtrace : unit -> unit +val load_file: formatter -> string -> bool + (* Printing of values *) val print_value: Env.t -> Obj.t -> formatter -> Types.type_expr -> unit diff --git a/ocaml/toplevel/topmain.ml b/ocaml/toplevel/topmain.ml deleted file mode 100644 index a0020b680bd..00000000000 --- a/ocaml/toplevel/topmain.ml +++ /dev/null @@ -1,124 +0,0 @@ -(**************************************************************************) -(* *) -(* OCaml *) -(* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) -(* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) -(* en Automatique. *) -(* *) -(* All rights reserved. This file is distributed under the terms of *) -(* the GNU Lesser General Public License version 2.1, with the *) -(* special exception on linking described in the file LICENSE. *) -(* *) -(**************************************************************************) - -let usage = "Usage: ocaml [script-file [arguments]]\n\ - options are:" - -let preload_objects = ref [] - -(* Position of the first non expanded argument *) -let first_nonexpanded_pos = ref 0 - -let current = ref (!Arg.current) - -let argv = ref Sys.argv - -(* Test whether the option is part of a responsefile *) -let is_expanded pos = pos < !first_nonexpanded_pos - -let expand_position pos len = - if pos < !first_nonexpanded_pos then - (* Shift the position *) - first_nonexpanded_pos := !first_nonexpanded_pos + len - else - (* New last position *) - first_nonexpanded_pos := pos + len + 2 - -let prepare ppf = - Toploop.set_paths (); - try - let res = - let objects = - List.rev (!preload_objects @ !Compenv.first_objfiles) - in - List.for_all (Topdirs.load_file ppf) objects - in - Toploop.run_hooks Toploop.Startup; - res - with x -> - try Location.report_exception ppf x; false - with x -> - Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x); - false - -(* If [name] is "", then the "file" is stdin treated as a script file. *) -let file_argument name = - let ppf = Format.err_formatter in - if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma" - then preload_objects := name :: !preload_objects - else if is_expanded !current then begin - (* Script files are not allowed in expand options because otherwise the - check in override arguments may fail since the new argv can be larger - than the original argv. - *) - Printf.eprintf "For implementation reasons, the toplevel does not support\ - \ having script files (here %S) inside expanded arguments passed through the\ - \ -args{,0} command-line option.\n" name; - raise (Compenv.Exit_with_status 2) - end else begin - let newargs = Array.sub !argv !current - (Array.length !argv - !current) - in - Compenv.readenv ppf Before_link; - Compmisc.read_clflags_from_env (); - if prepare ppf && Toploop.run_script ppf name newargs - then raise (Compenv.Exit_with_status 0) - else raise (Compenv.Exit_with_status 2) - end - - -let wrap_expand f s = - let start = !current in - let arr = f s in - expand_position start (Array.length arr); - arr - -module Options = Main_args.Make_bytetop_options (struct - include Main_args.Default.Topmain - let _stdin () = file_argument "" - let _args = wrap_expand Arg.read_arg - let _args0 = wrap_expand Arg.read_arg0 - let anonymous s = file_argument s -end);; - -let () = - let extra_paths = - match Sys.getenv "OCAMLTOP_INCLUDE_PATH" with - | exception Not_found -> [] - | s -> Misc.split_path_contents s - in - Clflags.include_dirs := List.rev_append extra_paths !Clflags.include_dirs - -let main () = - let ppf = Format.err_formatter in - Compenv.readenv ppf Before_args; - let list = ref Options.list in - begin - try - Arg.parse_and_expand_argv_dynamic current argv list file_argument usage; - with - | Arg.Bad msg -> Printf.eprintf "%s" msg; raise (Compenv.Exit_with_status 2) - | Arg.Help msg -> Printf.printf "%s" msg; raise (Compenv.Exit_with_status 0) - end; - Compenv.readenv ppf Before_link; - Compmisc.read_clflags_from_env (); - if not (prepare ppf) then raise (Compenv.Exit_with_status 2); - Compmisc.init_path (); - Toploop.loop Format.std_formatter - -let main () = - match main () with - | exception Compenv.Exit_with_status n -> n - | () -> 0 diff --git a/ocaml/toplevel/trace.mli b/ocaml/toplevel/trace.mli index ab9d217ec4b..19630c237f3 100644 --- a/ocaml/toplevel/trace.mli +++ b/ocaml/toplevel/trace.mli @@ -15,6 +15,9 @@ (* The "trace" facility *) +(* /!\ Not available in native code /!\ + functions will raise [Invalid_argument] if called in a native toplevel *) + open Format type codeptr diff --git a/ocaml/typing/btype.ml b/ocaml/typing/btype.ml index 5b264e51d92..37b4e4f2b6f 100644 --- a/ocaml/typing/btype.ml +++ b/ocaml/typing/btype.ml @@ -22,9 +22,75 @@ open Local_store (**** Sets, maps and hashtables of types ****) -module TypeSet = Set.Make(TypeOps) -module TypeMap = Map.Make (TypeOps) -module TypeHash = Hashtbl.Make(TypeOps) +let wrap_repr f ty = f (Transient_expr.repr ty) +let wrap_type_expr f tty = f (Transient_expr.type_expr tty) + +module TransientTypeSet = Set.Make(TransientTypeOps) +module TypeSet = struct + include TransientTypeSet + let add = wrap_repr add + let mem = wrap_repr mem + let singleton = wrap_repr singleton + let exists p = TransientTypeSet.exists (wrap_type_expr p) + let elements set = + List.map Transient_expr.type_expr (TransientTypeSet.elements set) +end +module TransientTypeMap = Map.Make(TransientTypeOps) +module TypeMap = struct + include TransientTypeMap + let add ty = wrap_repr add ty + let find ty = wrap_repr find ty + let singleton ty = wrap_repr singleton ty + let fold f = TransientTypeMap.fold (wrap_type_expr f) +end +module TransientTypeHash = Hashtbl.Make(TransientTypeOps) +module TypeHash = struct + include TransientTypeHash + let add hash = wrap_repr (add hash) + let remove hash = wrap_repr (remove hash) + let find hash = wrap_repr (find hash) + let iter f = TransientTypeHash.iter (wrap_type_expr f) +end +module TransientTypePairs = + Hashtbl.Make (struct + type t = transient_expr * transient_expr + let equal (t1, t1') (t2, t2') = (t1 == t2) && (t1' == t2') + let hash (t, t') = t.id + 93 * t'.id + end) +module TypePairs = struct + module H = TransientTypePairs + open Transient_expr + + type t = { + set : unit H.t; + mutable elems : (transient_expr * transient_expr) list; + (* elems preserves the (reversed) insertion order of elements *) + } + + let create n = + { elems = []; set = H.create n } + + let clear t = + t.elems <- []; + H.clear t.set + + let repr2 (t1, t2) = (repr t1, repr t2) + + let add t p = + let p = repr2 p in + if H.mem t.set p then () else begin + H.add t.set p (); + t.elems <- p :: t.elems + end + + let mem t p = H.mem t.set (repr2 p) + + let iter f t = + (* iterate in insertion order, not Hashtbl.iter order *) + List.rev t.elems + |> List.iter (fun (t1,t2) -> + f (type_expr t1, type_expr t2)) +end (**** Forward declarations ****) @@ -42,12 +108,10 @@ let pivot_level = 2 * lowest_level - 1 (**** Some type creators ****) -let new_id = s_ref (-1) - -let newty2 level desc = - incr new_id; { desc; level; scope = lowest_level; id = !new_id } -let newgenty desc = newty2 generic_level desc +let newgenty desc = newty2 ~level:generic_level desc let newgenvar ?name () = newgenty (Tvar name) +let newgenstub ~scope = newty3 ~level:generic_level ~scope (Tvar None) + (* let newmarkedvar level = incr new_id; { desc = Tvar; level = pivot_level - level; id = !new_id } @@ -58,130 +122,15 @@ let newmarkedgenvar () = (**** Check some types ****) -let is_Tvar = function {desc=Tvar _} -> true | _ -> false -let is_Tunivar = function {desc=Tunivar _} -> true | _ -> false -let is_Tconstr = function {desc=Tconstr _} -> true | _ -> false +let is_Tvar ty = match get_desc ty with Tvar _ -> true | _ -> false +let is_Tunivar ty = match get_desc ty with Tunivar _ -> true | _ -> false +let is_Tconstr ty = match get_desc ty with Tconstr _ -> true | _ -> false +let is_Tpoly ty = match get_desc ty with Tpoly _ -> true | _ -> false let dummy_method = "*dummy method*" -(**** Definitions for backtracking ****) - -type change = - Ctype of type_expr * type_desc - | Ccompress of type_expr * type_desc * type_desc - | Clevel of type_expr * int - | Cscope of type_expr * int - | Cname of - (Path.t * type_expr list) option ref * (Path.t * type_expr list) option - | Crow of row_field option ref * row_field option - | Ckind of field_kind option ref * field_kind option - | Ccommu of commutable ref * commutable - | Cuniv of type_expr option ref * type_expr option - | Ctypeset of TypeSet.t ref * TypeSet.t - | Cmode_upper of alloc_mode_var * alloc_mode_const - | Cmode_lower of alloc_mode_var * alloc_mode_const - | Cmode_vlower of alloc_mode_var * alloc_mode_var list - -type changes = - Change of change * changes ref - | Unchanged - | Invalid - -let trail = s_table Weak.create 1 - -let log_change ch = - match Weak.get !trail 0 with None -> () - | Some r -> - let r' = ref Unchanged in - r := Change (ch, r'); - Weak.set !trail 0 (Some r') - -let log_changes chead ctail = - if chead = Unchanged then (assert (!ctail = Unchanged)) - else match Weak.get !trail 0 with None -> () - | Some r -> - r := chead; - Weak.set !trail 0 (Some ctail) - -let append_change ctail ch = - assert (!(!ctail) = Unchanged); - let r' = ref Unchanged in - (!ctail) := Change (ch, r'); - ctail := r' - (**** Representative of a type ****) -let rec field_kind_repr = - function - Fvar {contents = Some kind} -> field_kind_repr kind - | kind -> kind - -let rec repr_link compress t d = - function - {desc = Tlink t' as d'} -> - repr_link true t d' t' - | {desc = Tfield (_, k, _, t') as d'} when field_kind_repr k = Fabsent -> - repr_link true t d' t' - | t' -> - if compress then begin - log_change (Ccompress (t, t.desc, d)); t.desc <- d - end; - t' - -let repr t = - match t.desc with - Tlink t' as d -> - repr_link false t d t' - | Tfield (_, k, _, t') as d when field_kind_repr k = Fabsent -> - repr_link false t d t' - | _ -> t - -let rec commu_repr = function - Clink r when !r <> Cunknown -> commu_repr !r - | c -> c - -let rec row_field_repr_aux tl = function - Reither(_, tl', _, {contents = Some fi}) -> - row_field_repr_aux (tl@tl') fi - | Reither(c, tl', m, r) -> - Reither(c, tl@tl', m, r) - | Rpresent (Some _) when tl <> [] -> - Rpresent (Some (List.hd tl)) - | fi -> fi - -let row_field_repr fi = row_field_repr_aux [] fi - -let rec rev_concat l ll = - match ll with - [] -> l - | l'::ll -> rev_concat (l'@l) ll - -let rec row_repr_aux ll row = - match (repr row.row_more).desc with - | Tvariant row' -> - let f = row.row_fields in - row_repr_aux (if f = [] then ll else f::ll) row' - | _ -> - if ll = [] then row else - {row with row_fields = rev_concat row.row_fields ll} - -let row_repr row = row_repr_aux [] row - -let rec row_field tag row = - let rec find = function - | (tag',f) :: fields -> - if tag = tag' then row_field_repr f else find fields - | [] -> - match repr row.row_more with - | {desc=Tvariant row'} -> row_field tag row' - | _ -> Rabsent - in find row.row_fields - -let rec row_more row = - match repr row.row_more with - | {desc=Tvariant row'} -> row_more row' - | ty -> ty - let merge_fixed_explanation fixed1 fixed2 = match fixed1, fixed2 with | Some Univar _ as x, _ | _, (Some Univar _ as x) -> x @@ -192,30 +141,27 @@ let merge_fixed_explanation fixed1 fixed2 = let fixed_explanation row = - let row = row_repr row in - match row.row_fixed with + match row_fixed row with | Some _ as x -> x | None -> - let more = repr row.row_more in - match more.desc with + let ty = row_more row in + match get_desc ty with | Tvar _ | Tnil -> None - | Tunivar _ -> Some (Univar more) + | Tunivar _ -> Some (Univar ty) | Tconstr (p,_,_) -> Some (Reified p) | _ -> assert false -let is_fixed row = match row.row_fixed with +let is_fixed row = match row_fixed row with | None -> false | Some _ -> true -let row_fixed row = fixed_explanation row <> None - +let has_fixed_explanation row = fixed_explanation row <> None let static_row row = - let row = row_repr row in - row.row_closed && + row_closed row && List.for_all (fun (_,f) -> match row_field_repr f with Reither _ -> false | _ -> true) - row.row_fields + (row_fields row) let hash_variant s = let accu = ref 0 in @@ -228,28 +174,26 @@ let hash_variant s = if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu let proxy ty = - let ty0 = repr ty in - match ty0.desc with + match get_desc ty with | Tvariant row when not (static_row row) -> row_more row | Tobject (ty, _) -> let rec proxy_obj ty = - match ty.desc with - Tfield (_, _, _, ty) | Tlink ty -> proxy_obj ty + match get_desc ty with + Tfield (_, _, _, ty) -> proxy_obj ty | Tvar _ | Tunivar _ | Tconstr _ -> ty - | Tnil -> ty0 + | Tnil -> ty | _ -> assert false in proxy_obj ty - | _ -> ty0 + | _ -> ty (**** Utilities for fixed row private types ****) let row_of_type t = - match (repr t).desc with + match get_desc t with Tobject(t,_) -> let rec get_row t = - let t = repr t in - match t.desc with + match get_desc t with Tfield(_,_,_,t) -> get_row t | _ -> t in get_row t @@ -263,36 +207,50 @@ let has_constr_row t = let is_row_name s = let l = String.length s in - if l < 4 then false else String.sub s (l-4) 4 = "#row" + (* PR#10661: when l=4 and s is "#row", this is not a row name + but the valid #-type name of a class named "row". *) + l > 4 && String.sub s (l-4) 4 = "#row" let is_constr_row ~allow_ident t = - match t.desc with + match get_desc t with Tconstr (Path.Pident id, _, _) when allow_ident -> is_row_name (Ident.name id) | Tconstr (Path.Pdot (_, s), _, _) -> is_row_name s | _ -> false +(* TODO: where should this really be *) +(* Set row_name in Env, cf. GPR#1204/1329 *) +let set_static_row_name decl path = + match decl.type_manifest with + None -> () + | Some ty -> + match get_desc ty with + Tvariant row when static_row row -> + let row = + set_row_name row (Some (path, decl.type_params)) in + set_type_desc ty (Tvariant row) + | _ -> () + (**********************************) (* Utilities for type traversal *) (**********************************) -let rec fold_row f init row = +let fold_row f init row = let result = List.fold_left (fun init (_, fi) -> match row_field_repr fi with | Rpresent(Some ty) -> f init ty - | Reither(_, tl, _, _) -> List.fold_left f init tl + | Reither(_, tl, _) -> List.fold_left f init tl | _ -> init) init - row.row_fields + (row_fields row) in - match (repr row.row_more).desc with - Tvariant row -> fold_row f result row + match get_desc (row_more row) with | Tvar _ | Tunivar _ | Tsubst _ | Tconstr _ | Tnil -> begin match - Option.map (fun (_,l) -> List.fold_left f result l) row.row_name + Option.map (fun (_,l) -> List.fold_left f result l) (row_name row) with | None -> result | Some result -> result @@ -303,32 +261,32 @@ let iter_row f row = fold_row (fun () v -> f v) () row let fold_type_expr f init ty = - match ty.desc with + match get_desc ty with Tvar _ -> init | Tarrow (_, ty1, ty2, _) -> - let result = f init ty1 in - f result ty2 + let result = f init ty1 in + f result ty2 | Ttuple l -> List.fold_left f init l | Tconstr (_, l, _) -> List.fold_left f init l - | Tobject(ty, {contents = Some (_, p)}) - -> - let result = f init ty in - List.fold_left f result p + | Tobject(ty, {contents = Some (_, p)}) -> + let result = f init ty in + List.fold_left f result p | Tobject (ty, _) -> f init ty | Tvariant row -> - let result = fold_row f init row in - f result (row_more row) + let result = fold_row f init row in + f result (row_more row) | Tfield (_, _, ty1, ty2) -> - let result = f init ty1 in - f result ty2 + let result = f init ty1 in + f result ty2 | Tnil -> init - | Tlink ty -> f init ty - | Tsubst ty -> f init ty + | Tlink _ + | Tsubst _ -> assert false | Tunivar _ -> init | Tpoly (ty, tyl) -> let result = f init ty in List.fold_left f result tyl - | Tpackage (_, _, l) -> List.fold_left f init l + | Tpackage (_, fl) -> + List.fold_left (fun result (_n, ty) -> f result ty) init fl let iter_type_expr f ty = fold_type_expr (fun () v -> f v) () ty @@ -351,23 +309,23 @@ type type_iterators = it_functor_param: type_iterators -> functor_parameter -> unit; it_module_type: type_iterators -> module_type -> unit; it_class_type: type_iterators -> class_type -> unit; - it_type_kind: type_iterators -> type_kind -> unit; + it_type_kind: type_iterators -> type_decl_kind -> unit; it_do_type_expr: type_iterators -> type_expr -> unit; it_type_expr: type_iterators -> type_expr -> unit; it_path: Path.t -> unit; } let iter_type_expr_cstr_args f = function - | Cstr_tuple tl -> List.iter f tl + | Cstr_tuple tl -> List.iter (fun (ty, _) -> f ty) tl | Cstr_record lbls -> List.iter (fun d -> f d.ld_type) lbls let map_type_expr_cstr_args f = function - | Cstr_tuple tl -> Cstr_tuple (List.map f tl) + | Cstr_tuple tl -> Cstr_tuple (List.map (fun (ty, gf) -> (f ty, gf)) tl) | Cstr_record lbls -> Cstr_record (List.map (fun d -> {d with ld_type=f d.ld_type}) lbls) let iter_type_expr_kind f = function | Type_abstract -> () - | Type_variant cstrs -> + | Type_variant (cstrs, _) -> List.iter (fun cd -> iter_type_expr_cstr_args f cd.cd_args; @@ -432,10 +390,9 @@ let type_iterators = it.it_class_type it cty | Cty_signature cs -> it.it_type_expr it cs.csig_self; + it.it_type_expr it cs.csig_self_row; Vars.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_vars; - List.iter - (fun (p, tl) -> it.it_path p; List.iter (it.it_type_expr it) tl) - cs.csig_inher + Meths.iter (fun _ (_,_,ty) -> it.it_type_expr it ty) cs.csig_meths | Cty_arrow (_, ty, cty) -> it.it_type_expr it ty; it.it_class_type it cty @@ -443,13 +400,13 @@ let type_iterators = iter_type_expr_kind (it.it_type_expr it) kind and it_do_type_expr it ty = iter_type_expr (it.it_type_expr it) ty; - match ty.desc with + match get_desc ty with Tconstr (p, _, _) | Tobject (_, {contents=Some (p, _)}) - | Tpackage (p, _, _) -> + | Tpackage (p, _) -> it.it_path p | Tvariant row -> - Option.iter (fun (p,_) -> it.it_path p) (row_repr row).row_name + Option.iter (fun (p,_) -> it.it_path p) (row_name row) | _ -> () and it_path _p = () in @@ -460,43 +417,27 @@ let type_iterators = it_type_declaration; it_value_description; it_signature_item; } let copy_row f fixed row keep more = + let Row {fields = orig_fields; fixed = orig_fixed; closed; name = orig_name} = + row_repr row in let fields = List.map (fun (l, fi) -> l, match row_field_repr fi with - | Rpresent(Some ty) -> Rpresent(Some(f ty)) - | Reither(c, tl, m, e) -> - let e = if keep then e else ref None in + | Rpresent oty -> rf_present (Option.map f oty) + | Reither(c, tl, m) -> + let use_ext_of = if keep then Some fi else None in let m = if is_fixed row then fixed else m in let tl = List.map f tl in - Reither(c, tl, m, e) - | _ -> fi) - row.row_fields in + rf_either tl ?use_ext_of ~no_arg:c ~matched:m + | Rabsent -> rf_absent) + orig_fields in let name = - match row.row_name with + match orig_name with | None -> None | Some (path, tl) -> Some (path, List.map f tl) in - let row_fixed = if fixed then row.row_fixed else None in - { row_fields = fields; row_more = more; - row_bound = (); row_fixed; - row_closed = row.row_closed; row_name = name; } - -let rec copy_kind = function - Fvar{contents = Some k} -> copy_kind k - | Fvar _ -> Fvar (ref None) - | Fpresent -> Fpresent - | Fabsent -> assert false - -let copy_commu c = - if commu_repr c = Cok then Cok else Clink (ref Cunknown) - -(* Since univars may be used as row variables, we need to do some - encoding during substitution *) -let rec norm_univar ty = - match ty.desc with - Tunivar _ | Tsubst _ -> ty - | Tlink ty -> norm_univar ty - | Ttuple (ty :: _) -> norm_univar ty - | _ -> assert false + let fixed = if fixed then orig_fixed else None in + create_row ~fields ~more ~fixed ~closed ~name + +let copy_commu c = if is_commu_ok c then commu_ok else commu_var () let rec copy_type_desc ?(keep_names=false) f = function Tvar _ as ty -> if keep_names then ty else Tvar None @@ -507,119 +448,48 @@ let rec copy_type_desc ?(keep_names=false) f = function -> Tobject (f ty, ref (Some(p, List.map f tl))) | Tobject (ty, _) -> Tobject (f ty, ref None) | Tvariant _ -> assert false (* too ambiguous *) - | Tfield (p, k, ty1, ty2) -> (* the kind is kept shared *) - Tfield (p, field_kind_repr k, f ty1, f ty2) + | Tfield (p, k, ty1, ty2) -> + Tfield (p, field_kind_internal_repr k, f ty1, f ty2) + (* the kind is kept shared, with indirections removed for performance *) | Tnil -> Tnil - | Tlink ty -> copy_type_desc f ty.desc + | Tlink ty -> copy_type_desc f (get_desc ty) | Tsubst _ -> assert false | Tunivar _ as ty -> ty (* always keep the name *) | Tpoly (ty, tyl) -> - let tyl = List.map (fun x -> norm_univar (f x)) tyl in + let tyl = List.map f tyl in Tpoly (f ty, tyl) - | Tpackage (p, n, l) -> Tpackage (p, n, List.map f l) + | Tpackage (p, fl) -> Tpackage (p, List.map (fun (n, ty) -> (n, f ty)) fl) (* Utilities for copying *) module For_copy : sig type copy_scope - val save_desc: copy_scope -> type_expr -> type_desc -> unit - - val dup_kind: copy_scope -> field_kind option ref -> unit + val redirect_desc: copy_scope -> type_expr -> type_desc -> unit val with_scope: (copy_scope -> 'a) -> 'a end = struct type copy_scope = { - mutable saved_desc : (type_expr * type_desc) list; + mutable saved_desc : (transient_expr * type_desc) list; (* Save association of generic nodes with their description. *) - - mutable saved_kinds: field_kind option ref list; - (* duplicated kind variables *) - - mutable new_kinds : field_kind option ref list; - (* new kind variables *) } - let save_desc copy_scope ty desc = - copy_scope.saved_desc <- (ty, desc) :: copy_scope.saved_desc - - let dup_kind copy_scope r = - assert (Option.is_none !r); - if not (List.memq r copy_scope.new_kinds) then begin - copy_scope.saved_kinds <- r :: copy_scope.saved_kinds; - let r' = ref None in - copy_scope.new_kinds <- r' :: copy_scope.new_kinds; - r := Some (Fvar r') - end + let redirect_desc copy_scope ty desc = + let ty = Transient_expr.repr ty in + copy_scope.saved_desc <- (ty, ty.desc) :: copy_scope.saved_desc; + Transient_expr.set_desc ty desc (* Restore type descriptions. *) - let cleanup { saved_desc; saved_kinds; _ } = - List.iter (fun (ty, desc) -> ty.desc <- desc) saved_desc; - List.iter (fun r -> r := None) saved_kinds + let cleanup { saved_desc; _ } = + List.iter (fun (ty, desc) -> Transient_expr.set_desc ty desc) saved_desc let with_scope f = - let scope = { saved_desc = []; saved_kinds = []; new_kinds = [] } in + let scope = { saved_desc = [] } in let res = f scope in cleanup scope; res end -(* Mark a type. *) -let rec mark_type ty = - let ty = repr ty in - if ty.level >= lowest_level then begin - ty.level <- pivot_level - ty.level; - iter_type_expr mark_type ty - end - -let mark_type_node ty = - let ty = repr ty in - if ty.level >= lowest_level then begin - ty.level <- pivot_level - ty.level; - end - -let mark_type_params ty = - iter_type_expr mark_type ty - -let type_iterators = - let it_type_expr it ty = - let ty = repr ty in - if ty.level >= lowest_level then begin - mark_type_node ty; - it.it_do_type_expr it ty; - end - in - {type_iterators with it_type_expr} - - -(* Remove marks from a type. *) -let rec unmark_type ty = - let ty = repr ty in - if ty.level < lowest_level then begin - ty.level <- pivot_level - ty.level; - iter_type_expr unmark_type ty - end - -let unmark_iterators = - let it_type_expr _it ty = unmark_type ty in - {type_iterators with it_type_expr} - -let unmark_type_decl decl = - unmark_iterators.it_type_declaration unmark_iterators decl - -let unmark_extension_constructor ext = - List.iter unmark_type ext.ext_type_params; - iter_type_expr_cstr_args unmark_type ext.ext_args; - Option.iter unmark_type ext.ext_ret_type - -let unmark_class_signature sign = - unmark_type sign.csig_self; - Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars - -let unmark_class_type cty = - unmark_iterators.it_class_type unmark_iterators cty - - (*******************************************) (* Memorization of abbreviation expansion *) (*******************************************) @@ -692,6 +562,11 @@ let check_memorized_abbrevs () = List.for_all (fun mem -> check_abbrev_rec !mem) !memo *) +(* Re-export backtrack *) + +let snapshot = snapshot +let backtrack = backtrack ~cleanup_abbrev + (**********************************) (* Utilities for labels *) (**********************************) @@ -718,569 +593,202 @@ let rec extract_label_aux hd l = function let extract_label l ls = extract_label_aux [] l ls + (*******************************) + (* Operations on class types *) + (*******************************) - (**********************************) - (* Utilities for backtracking *) - (**********************************) - -let undo_change = function - Ctype (ty, desc) -> ty.desc <- desc - | Ccompress (ty, desc, _) -> ty.desc <- desc - | Clevel (ty, level) -> ty.level <- level - | Cscope (ty, scope) -> ty.scope <- scope - | Cname (r, v) -> r := v - | Crow (r, v) -> r := v - | Ckind (r, v) -> r := v - | Ccommu (r, v) -> r := v - | Cuniv (r, v) -> r := v - | Ctypeset (r, v) -> r := v - | Cmode_upper (v, u) -> v.upper <- u - | Cmode_lower (v, l) -> v.lower <- l - | Cmode_vlower (v, vs) -> v.vlower <- vs - -type snapshot = changes ref * int -let last_snapshot = s_ref 0 - -let log_type ty = - if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc)) -let link_type ty ty' = - log_type ty; - let desc = ty.desc in - ty.desc <- Tlink ty'; - (* Name is a user-supplied name for this unification variable (obtained - * through a type annotation for instance). *) - match desc, ty'.desc with - Tvar name, Tvar name' -> - begin match name, name' with - | Some _, None -> log_type ty'; ty'.desc <- Tvar name - | None, Some _ -> () - | Some _, Some _ -> - if ty.level < ty'.level then (log_type ty'; ty'.desc <- Tvar name) - | None, None -> () - end - | _ -> () - (* ; assert (check_memorized_abbrevs ()) *) - (* ; check_expans [] ty' *) -let set_type_desc ty td = - if td != ty.desc then begin - log_type ty; - ty.desc <- td - end -let set_level ty level = - if level <> ty.level then begin - if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level)); - ty.level <- level - end -let set_scope ty scope = - if scope <> ty.scope then begin - if ty.id <= !last_snapshot then log_change (Cscope (ty, ty.scope)); - ty.scope <- scope - end -let set_univar rty ty = - log_change (Cuniv (rty, !rty)); rty := Some ty -let set_name nm v = - log_change (Cname (nm, !nm)); nm := v -let set_row_field e v = - log_change (Crow (e, !e)); e := Some v -let set_kind rk k = - log_change (Ckind (rk, !rk)); rk := Some k -let set_commu rc c = - log_change (Ccommu (rc, !rc)); rc := c -let set_typeset rs s = - log_change (Ctypeset (rs, !rs)); rs := s - -let snapshot () = - let old = !last_snapshot in - last_snapshot := !new_id; - match Weak.get !trail 0 with Some r -> (r, old) - | None -> - let r = ref Unchanged in - Weak.set !trail 0 (Some r); - (r, old) - -let rec rev_log accu = function - Unchanged -> accu - | Invalid -> assert false - | Change (ch, next) -> - let d = !next in - next := Invalid; - rev_log (ch::accu) d - -let backtrack (changes, old) = - match !changes with - Unchanged -> last_snapshot := old - | Invalid -> failwith "Btype.backtrack" - | Change _ as change -> - cleanup_abbrev (); - let backlog = rev_log [] change in - List.iter undo_change backlog; - changes := Unchanged; - last_snapshot := old; - Weak.set !trail 0 (Some changes) - -let rec rev_compress_log log r = - match !r with - Unchanged | Invalid -> - log - | Change (Ccompress _, next) -> - rev_compress_log (r::log) next - | Change (_, next) -> - rev_compress_log log next - -let undo_compress (changes, _old) = - match !changes with - Unchanged - | Invalid -> () - | Change _ -> - let log = rev_compress_log [] changes in - List.iter - (fun r -> match !r with - Change (Ccompress (ty, desc, d), next) when ty.desc == d -> - ty.desc <- desc; r := !next - | _ -> ()) - log +let rec signature_of_class_type = + function + Cty_constr (_, _, cty) -> signature_of_class_type cty + | Cty_signature sign -> sign + | Cty_arrow (_, _, cty) -> signature_of_class_type cty + + +let rec class_body cty = + match cty with + Cty_constr _ -> + cty (* Only class bodies can be abbreviated *) + | Cty_signature _ -> + cty + | Cty_arrow (_, _, cty) -> + class_body cty + +(* Fully expand the head of a class type *) +let rec scrape_class_type = + function + Cty_constr (_, _, cty) -> scrape_class_type cty + | cty -> cty +let rec class_type_arity = + function + Cty_constr (_, _, cty) -> class_type_arity cty + | Cty_signature _ -> 0 + | Cty_arrow (_, _, cty) -> 1 + class_type_arity cty + +let rec abbreviate_class_type path params cty = + match cty with + Cty_constr (_, _, _) | Cty_signature _ -> + Cty_constr (path, params, cty) + | Cty_arrow (l, ty, cty) -> + Cty_arrow (l, ty, abbreviate_class_type path params cty) + +let self_type cty = + (signature_of_class_type cty).csig_self + +let self_type_row cty = + (signature_of_class_type cty).csig_self_row + +(* Return the methods of a class signature *) +let methods sign = + Meths.fold + (fun name _ l -> name :: l) + sign.csig_meths [] + +(* Return the virtual methods of a class signature *) +let virtual_methods sign = + Meths.fold + (fun name (_priv, vr, _ty) l -> + match vr with + | Virtual -> name :: l + | Concrete -> l) + sign.csig_meths [] + +(* Return the concrete methods of a class signature *) +let concrete_methods sign = + Meths.fold + (fun name (_priv, vr, _ty) s -> + match vr with + | Virtual -> s + | Concrete -> MethSet.add name s) + sign.csig_meths MethSet.empty + +(* Return the public methods of a class signature *) +let public_methods sign = + Meths.fold + (fun name (priv, _vr, _ty) l -> + match priv with + | Mprivate _ -> l + | Mpublic -> name :: l) + sign.csig_meths [] + +(* Return the instance variables of a class signature *) +let instance_vars sign = + Vars.fold + (fun name _ l -> name :: l) + sign.csig_vars [] + +(* Return the virtual instance variables of a class signature *) +let virtual_instance_vars sign = + Vars.fold + (fun name (_mut, vr, _ty) l -> + match vr with + | Virtual -> name :: l + | Concrete -> l) + sign.csig_vars [] + +(* Return the concrete instance variables of a class signature *) +let concrete_instance_vars sign = + Vars.fold + (fun name (_mut, vr, _ty) s -> + match vr with + | Virtual -> s + | Concrete -> VarSet.add name s) + sign.csig_vars VarSet.empty + +let method_type label sign = + match Meths.find label sign.csig_meths with + | (_, _, ty) -> ty + | exception Not_found -> assert false + +let instance_variable_type label sign = + match Vars.find label sign.csig_vars with + | (_, _, ty) -> ty + | exception Not_found -> assert false + + (********************************) + (* Utilities for poly types *) + (********************************) + +let tpoly_is_mono ty = + match get_desc ty with + | Tpoly(_, []) -> true + | Tpoly(_, _ :: _) -> false + | _ -> assert false -module Alloc_mode = struct - type nonrec const = Types.alloc_mode_const = Global | Local - type t = Types.alloc_mode = - | Amode of const - | Amodevar of alloc_mode_var +let tpoly_get_poly ty = + match get_desc ty with + | Tpoly(ty, vars) -> (ty, vars) + | _ -> assert false - let global = Amode Global - let local = Amode Local - let of_const = function - | Global -> global - | Local -> local +let tpoly_get_mono ty = + match get_desc ty with + | Tpoly(ty, []) -> ty + | _ -> assert false - let min_mode = global + (**********************************) + (* Utilities for level-marking *) + (**********************************) - let max_mode = local +let not_marked_node ty = get_level ty >= lowest_level + (* type nodes with negative levels are "marked" *) - let le_const a b = - match a, b with - | Global, _ | _, Local -> true - | Local, Global -> false +let flip_mark_node ty = + let ty = Transient_expr.repr ty in + Transient_expr.set_level ty (pivot_level - ty.level) +let logged_mark_node ty = + set_level ty (pivot_level - get_level ty) - let join_const a b = - match a, b with - | Local, _ | _, Local -> Local - | Global, Global -> Global +let try_mark_node ty = not_marked_node ty && (flip_mark_node ty; true) +let try_logged_mark_node ty = not_marked_node ty && (logged_mark_node ty; true) - let meet_const a b = - match a, b with - | Global, _ | _, Global -> Global - | Local, Local -> Local +let rec mark_type ty = + if not_marked_node ty then begin + flip_mark_node ty; + iter_type_expr mark_type ty + end - exception NotSubmode -(* - let pp_c ppf = function - | Global -> Printf.fprintf ppf "0" - | Local -> Printf.fprintf ppf "1" - let pp_v ppf v = - let i = v.mvid in - (if i < 26 then Printf.fprintf ppf "%c" (Char.chr (Char.code 'a' + i)) - else Printf.fprintf ppf "v%d" i); - Printf.fprintf ppf "[%a%a]" pp_c v.lower pp_c v.upper -*) +let mark_type_params ty = + iter_type_expr mark_type ty - let set_lower ~log v lower = - append_change log (Cmode_lower (v, v.lower)); - v.lower <- lower - - let set_upper ~log v upper = - append_change log (Cmode_upper (v, v.upper)); - v.upper <- upper - - let set_vlower ~log v vlower = - append_change log (Cmode_vlower (v, v.vlower)); - v.vlower <- vlower - - let submode_cv ~log m v = - (* Printf.printf " %a <= %a\n" pp_c m pp_v v; *) - if le_const m v.lower then () - else if not (le_const m v.upper) then raise NotSubmode - else begin - let m = join_const v.lower m in - set_lower ~log v m; - if m = v.upper then set_vlower ~log v [] - end +let type_iterators = + let it_type_expr it ty = + if try_mark_node ty then it.it_do_type_expr it ty + in + {type_iterators with it_type_expr} - let rec submode_vc ~log v m = - (* Printf.printf " %a <= %a\n" pp_v v pp_c m; *) - if le_const v.upper m then () - else if not (le_const v.lower m) then raise NotSubmode - else begin - let m = meet_const v.upper m in - set_upper ~log v m; - v.vlower |> List.iter (fun a -> - (* a <= v <= m *) - submode_vc ~log a m; - set_lower ~log v (join_const v.lower a.lower); - ); - if v.lower = m then set_vlower ~log v [] - end - let submode_vv ~log a b = - (* Printf.printf " %a <= %a\n" pp_v a pp_v b; *) - if le_const a.upper b.lower then () - else if a == b || List.memq a b.vlower then () - else begin - submode_vc ~log a b.upper; - set_vlower ~log b (a :: b.vlower); - submode_cv ~log a.lower b; - end +(* Remove marks from a type. *) +let rec unmark_type ty = + if get_level ty < lowest_level then begin + (* flip back the marked level *) + flip_mark_node ty; + iter_type_expr unmark_type ty + end - let submode a b = - let log_head = ref Unchanged in - let log = ref log_head in - match - match a, b with - | Amode a, Amode b -> - if not (le_const a b) then raise NotSubmode - | Amodevar v, Amode c -> - (* Printf.printf "%a <= %a\n" pp_v v pp_c c; *) - submode_vc ~log v c - | Amode c, Amodevar v -> - (* Printf.printf "%a <= %a\n" pp_c c pp_v v; *) - submode_cv ~log c v - | Amodevar a, Amodevar b -> - (* Printf.printf "%a <= %a\n" pp_v a pp_v b; *) - submode_vv ~log a b - with - | () -> - log_changes !log_head !log; - Ok () - | exception NotSubmode -> - let backlog = rev_log [] !log_head in - List.iter undo_change backlog; - Error () - - let submode_exn t1 t2 = - match submode t1 t2 with - | Ok () -> () - | Error () -> invalid_arg "submode_exn" - - let equate a b = - match submode a b, submode b a with - | Ok (), Ok () -> Ok () - | Error (), _ | _, Error () -> Error () - - let make_global_exn t = - submode_exn t global - - let make_local_exn t = - submode_exn local t - - let next_id = ref (-1) - let fresh () = - incr next_id; - { upper = Local; - lower = Global; - vlower = []; - mvid = !next_id; - mark = false } - - let rec all_equal v = function - | [] -> true - | v' :: rest -> - if v == v' then all_equal v rest - else false - - let joinvars vars = - match vars with - | [] -> global - | v :: rest -> - let v = - if all_equal v rest then v - else begin - let v = fresh () in - List.iter (fun v' -> submode_exn (Amodevar v') (Amodevar v)) vars; - v - end - in - Amodevar v - - let join ms = - let rec aux vars = function - | [] -> joinvars vars - | Amode Global :: ms -> aux vars ms - | Amode Local :: _ -> local - | Amodevar v :: ms -> aux (v :: vars) ms - in aux [] ms - - let constrain_upper = function - | Amode m -> m - | Amodevar v -> - submode_exn (Amode v.upper) (Amodevar v); - v.upper - - exception Became_constant - let compress_vlower v = - let nmarked = ref 0 in - let mark v' = - assert (not v'.mark); - v'.mark <- true; - incr nmarked - in - let unmark v' = - assert v'.mark; - v'.mark <- false; - decr nmarked - in - let new_lower = ref v.lower in - let new_vlower = ref v.vlower in - (* Ensure that each transitive lower bound of v - is a direct lower bound of v *) - let rec trans v' = - if le_const v'.upper !new_lower then () - else if v'.mark then () - else begin - mark v'; - new_vlower := v' :: !new_vlower; - trans_low v' - end - and trans_low v' = - assert (v != v'); - if not (le_const v'.lower v.upper) then - Misc.fatal_error "compress_vlower: invalid bounds"; - if not (le_const v'.lower !new_lower) then begin - new_lower := join_const !new_lower v'.lower; - if !new_lower = v.upper then - (* v is now a constant, no need to keep computing bounds *) - raise Became_constant - end; - List.iter trans v'.vlower - in - mark v; - List.iter mark v.vlower; - let became_constant = - match List.iter trans_low v.vlower with - | () -> false - | exception Became_constant -> true - in - List.iter unmark !new_vlower; - unmark v; - assert (!nmarked = 0); - if became_constant then new_vlower := []; - if !new_lower != v.lower || !new_vlower != v.vlower then begin - let log_head = ref Unchanged in - let log = ref log_head in - set_lower ~log v !new_lower; - set_vlower ~log v !new_vlower; - log_changes !log_head !log; - end +let unmark_iterators = + let it_type_expr _it ty = unmark_type ty in + {type_iterators with it_type_expr} - let constrain_lower = function - | Amode m -> m - | Amodevar v -> - compress_vlower v; - submode_exn (Amodevar v) (Amode v.lower); - v.lower - - let newvar () = Amodevar (fresh ()) - - let newvar_below = function - | Amode Global -> Amode Global, false - | m -> - let v = newvar () in - submode_exn v m; - v, true - - let newvar_above = function - | Amode Local -> Amode Local, false - | m -> - let v = newvar () in - submode_exn m v; - v, true - - let check_const = function - | Amode m -> Some m - | Amodevar v -> - compress_vlower v; - if v.lower = v.upper then Some v.lower else None - - let print_const ppf = function - | Global -> Format.fprintf ppf "Global" - | Local -> Format.fprintf ppf "Local" - - let print_var_id ppf v = - Format.fprintf ppf "?%i" v.mvid - - let print_var ppf v = - compress_vlower v; - if v.lower = v.upper then begin - print_const ppf v.lower - end else if v.vlower = [] then begin - print_var_id ppf v - end else begin - Format.fprintf ppf "%a[> %a]" - print_var_id v - (Format.pp_print_list print_var_id) v.vlower - end +let unmark_type_decl decl = + unmark_iterators.it_type_declaration unmark_iterators decl - let print ppf = function - | Amode m -> print_const ppf m - | Amodevar v -> print_var ppf v +let unmark_extension_constructor ext = + List.iter unmark_type ext.ext_type_params; + iter_type_expr_cstr_args unmark_type ext.ext_args; + Option.iter unmark_type ext.ext_ret_type -end +let unmark_class_signature sign = + unmark_type sign.csig_self; + unmark_type sign.csig_self_row; + Vars.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_vars; + Meths.iter (fun _l (_m, _v, t) -> unmark_type t) sign.csig_meths -module Value_mode = struct - - type const = - | Global - | Regional - | Local - - let r_as_l : const -> Alloc_mode.const = function - | Global -> Global - | Regional -> Local - | Local -> Local - [@@warning "-unused-value-declaration"] - - let r_as_g : const -> Alloc_mode.const = function - | Global -> Global - | Regional -> Global - | Local -> Local - [@@warning "-unused-value-declaration"] - - let of_alloc_consts - ~(r_as_l : Alloc_mode.const) - ~(r_as_g : Alloc_mode.const) = - match r_as_l, r_as_g with - | Global, Global -> Global - | Global, Local -> assert false - | Local, Global -> Regional - | Local, Local -> Local - - type t = Types.value_mode = - { r_as_l : Alloc_mode.t; - (* [r_as_l] is the image of the mode under the [r_as_l] function *) - r_as_g : Alloc_mode.t; - (* [r_as_g] is the image of the mode under the [r_as_g] function. - Always less than [r_as_l]. *) } - - let global = - let r_as_l = Alloc_mode.global in - let r_as_g = Alloc_mode.global in - { r_as_l; r_as_g } - - let regional = - let r_as_l = Alloc_mode.local in - let r_as_g = Alloc_mode.global in - { r_as_l; r_as_g } - - let local = - let r_as_l = Alloc_mode.local in - let r_as_g = Alloc_mode.local in - { r_as_l; r_as_g } - - let of_const = function - | Global -> global - | Regional -> regional - | Local -> local - - let max_mode = - let r_as_l = Alloc_mode.max_mode in - let r_as_g = Alloc_mode.max_mode in - { r_as_l; r_as_g } - - let min_mode = - let r_as_l = Alloc_mode.min_mode in - let r_as_g = Alloc_mode.min_mode in - { r_as_l; r_as_g } - - let of_alloc mode = - let r_as_l = mode in - let r_as_g = mode in - { r_as_l; r_as_g } - - let local_to_regional t = { t with r_as_g = Alloc_mode.global } - - let regional_to_global t = { t with r_as_l = t.r_as_g } - - let regional_to_local t = { t with r_as_g = t.r_as_l } - - let global_to_regional t = { t with r_as_l = Alloc_mode.local } - - let regional_to_global_alloc t = t.r_as_g - - let regional_to_local_alloc t = t.r_as_l - - type error = [`Regionality | `Locality] - - let submode t1 t2 = - match Alloc_mode.submode t1.r_as_l t2.r_as_l with - | Error () -> Error `Regionality - | Ok () as ok -> begin - match Alloc_mode.submode t1.r_as_g t2.r_as_g with - | Ok () -> ok - | Error () -> Error `Locality - end +let unmark_class_type cty = + unmark_iterators.it_class_type unmark_iterators cty - let submode_exn t1 t2 = - match submode t1 t2 with - | Ok () -> () - | Error _ -> invalid_arg "submode_exn" - - let rec submode_meet t = function - | [] -> Ok () - | t' :: rest -> - match submode t t' with - | Ok () -> submode_meet t rest - | Error _ as err -> err - - let join ts = - let r_as_l = Alloc_mode.join (List.map (fun t -> t.r_as_l) ts) in - let r_as_g = Alloc_mode.join (List.map (fun t -> t.r_as_g) ts) in - { r_as_l; r_as_g } - - let constrain_upper t = - let r_as_l = Alloc_mode.constrain_upper t.r_as_l in - let r_as_g = Alloc_mode.constrain_upper t.r_as_g in - of_alloc_consts ~r_as_l ~r_as_g - - let constrain_lower t = - let r_as_l = Alloc_mode.constrain_lower t.r_as_l in - let r_as_g = Alloc_mode.constrain_lower t.r_as_g in - of_alloc_consts ~r_as_l ~r_as_g - - let newvar () = - let r_as_l = Alloc_mode.newvar () in - let r_as_g = Alloc_mode.newvar () in - Alloc_mode.submode_exn r_as_g r_as_l; - { r_as_l; r_as_g } - - let newvar_below = function - | { r_as_l = Amode Global; - r_as_g = Amode Global } -> - global - | m -> - let v = newvar () in - submode_exn v m; - v - - let check_const t = - match Alloc_mode.check_const t.r_as_l with - | None -> None - | Some r_as_l -> - match Alloc_mode.check_const t.r_as_g with - | None -> None - | Some r_as_g -> - Some (of_alloc_consts ~r_as_l ~r_as_g) - - let print_const ppf = function - | Global -> Format.fprintf ppf "Global" - | Regional -> Format.fprintf ppf "Regional" - | Local -> Format.fprintf ppf "Local" - - let print ppf t = - match check_const t with - | Some const -> print_const ppf const - | None -> - Format.fprintf ppf - "@[<2>r_as_l: %a@ r_as_g: %a@]" - Alloc_mode.print t.r_as_l - Alloc_mode.print t.r_as_g +(**** Type information getter ****) -end +let cstr_type_path cstr = + match get_desc cstr.cstr_res with + | Tconstr (p, _, _) -> p + | _ -> assert false diff --git a/ocaml/typing/btype.mli b/ocaml/typing/btype.mli index 81e5b611ea3..8655ac85407 100644 --- a/ocaml/typing/btype.mli +++ b/ocaml/typing/btype.mli @@ -20,20 +20,50 @@ open Types (**** Sets, maps and hashtables of types ****) -module TypeSet : Set.S with type elt = type_expr -module TypeMap : Map.S with type key = type_expr -module TypeHash : Hashtbl.S with type key = type_expr +module TypeSet : sig + include Set.S with type elt = transient_expr + val add: type_expr -> t -> t + val mem: type_expr -> t -> bool + val singleton: type_expr -> t + val exists: (type_expr -> bool) -> t -> bool + val elements: t -> type_expr list +end +module TransientTypeMap : Map.S with type key = transient_expr +module TypeMap : sig + include Map.S with type key = transient_expr + and type 'a t = 'a TransientTypeMap.t + val add: type_expr -> 'a -> 'a t -> 'a t + val find: type_expr -> 'a t -> 'a + val singleton: type_expr -> 'a -> 'a t + val fold: (type_expr -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b +end +module TypeHash : sig + include Hashtbl.S with type key = transient_expr + val add: 'a t -> type_expr -> 'a -> unit + val remove : 'a t -> type_expr -> unit + val find: 'a t -> type_expr -> 'a + val iter: (type_expr -> 'a -> unit) -> 'a t -> unit +end +module TypePairs : sig + type t + val create: int -> t + val clear: t -> unit + val add: t -> type_expr * type_expr -> unit + val mem: t -> type_expr * type_expr -> bool + val iter: (type_expr * type_expr -> unit) -> t -> unit +end (**** Levels ****) val generic_level: int -val newty2: int -> type_desc -> type_expr - (* Create a type *) val newgenty: type_desc -> type_expr (* Create a generic type *) val newgenvar: ?name:string -> unit -> type_expr (* Return a fresh generic variable *) +val newgenstub: scope:int -> type_expr + (* Return a fresh generic node, to be instantiated + by [Transient_expr.set_stub_desc] *) (* Use Tsubst instead val newmarkedvar: int -> type_expr @@ -47,34 +77,18 @@ val newmarkedgenvar: unit -> type_expr val is_Tvar: type_expr -> bool val is_Tunivar: type_expr -> bool val is_Tconstr: type_expr -> bool -val dummy_method: label - -val repr: type_expr -> type_expr - (* Return the canonical representative of a type. *) +val is_Tpoly: type_expr -> bool -val field_kind_repr: field_kind -> field_kind - (* Return the canonical representative of an object field - kind. *) - -val commu_repr: commutable -> commutable - (* Return the canonical representative of a commutation lock *) +val dummy_method: label (**** polymorphic variants ****) -val row_repr: row_desc -> row_desc - (* Return the canonical representative of a row description *) -val row_field_repr: row_field -> row_field -val row_field: label -> row_desc -> row_field - (* Return the canonical representative of a row field *) -val row_more: row_desc -> type_expr - (* Return the extension variable of the row *) - val is_fixed: row_desc -> bool (* Return whether the row is directly marked as fixed or not *) -val row_fixed: row_desc -> bool +val has_fixed_explanation: row_desc -> bool (* Return whether the row should be treated as fixed or not. - In particular, [is_fixed row] implies [row_fixed row]. + In particular, [is_fixed row] implies [has_fixed_explanation row]. *) val fixed_explanation: row_desc -> fixed_explanation option @@ -94,12 +108,22 @@ val proxy: type_expr -> type_expr (* Return the proxy representative of the type: either itself or a row variable *) +(* Poly types. *) + +(* These three functions can only be called on [Tpoly] nodes. *) +val tpoly_is_mono : type_expr -> bool +val tpoly_get_mono : type_expr -> type_expr +val tpoly_get_poly : type_expr -> type_expr * type_expr list + (**** Utilities for private abbreviations with fixed rows ****) val row_of_type: type_expr -> type_expr val has_constr_row: type_expr -> bool val is_row_name: string -> bool val is_constr_row: allow_ident:bool -> type_expr -> bool +(* Set the polymorphic variant row_name field *) +val set_static_row_name: type_declaration -> Path.t -> unit + (**** Utilities for type traversal ****) val iter_type_expr: (type_expr -> unit) -> type_expr -> unit @@ -110,6 +134,13 @@ val iter_row: (type_expr -> unit) -> row_desc -> unit val fold_row: ('a -> type_expr -> 'a) -> 'a -> row_desc -> 'a val iter_abbrev: (type_expr -> unit) -> abbrev_memo -> unit (* Iteration on types in an abbreviation list *) +val iter_type_expr_kind: (type_expr -> unit) -> (type_decl_kind -> unit) + +val iter_type_expr_cstr_args: (type_expr -> unit) -> + (constructor_arguments -> unit) +val map_type_expr_cstr_args: (type_expr -> type_expr) -> + (constructor_arguments -> constructor_arguments) + type type_iterators = { it_signature: type_iterators -> signature -> unit; @@ -124,13 +155,13 @@ type type_iterators = it_functor_param: type_iterators -> functor_parameter -> unit; it_module_type: type_iterators -> module_type -> unit; it_class_type: type_iterators -> class_type -> unit; - it_type_kind: type_iterators -> type_kind -> unit; + it_type_kind: type_iterators -> type_decl_kind -> unit; it_do_type_expr: type_iterators -> type_expr -> unit; it_type_expr: type_iterators -> type_expr -> unit; it_path: Path.t -> unit; } val type_iterators: type_iterators (* Iteration on arbitrary type information. - [it_type_expr] calls [mark_type_node] to avoid loops. *) + [it_type_expr] calls [mark_node] to avoid loops. *) val unmark_iterators: type_iterators (* Unmark any structure containing types. See [unmark_type] below. *) @@ -140,7 +171,6 @@ val copy_type_desc: val copy_row: (type_expr -> type_expr) -> bool -> row_desc -> bool -> type_expr -> row_desc -val copy_kind: field_kind -> field_kind module For_copy : sig @@ -151,11 +181,8 @@ module For_copy : sig While it is possible to circumvent that discipline in various ways, you should NOT do that. *) - val save_desc: copy_scope -> type_expr -> type_desc -> unit - (* Save a type description *) - - val dup_kind: copy_scope -> field_kind option ref -> unit - (* Save a None field_kind, and make it point to a fresh Fvar *) + val redirect_desc: copy_scope -> type_expr -> type_desc -> unit + (* Temporarily change a type description *) val with_scope: (copy_scope -> 'a) -> 'a (* [with_scope f] calls [f] and restores saved type descriptions @@ -164,14 +191,32 @@ end val lowest_level: int (* Marked type: ty.level < lowest_level *) -val pivot_level: int - (* Type marking: ty.level <- pivot_level - ty.level *) + +val not_marked_node: type_expr -> bool + (* Return true if a type node is not yet marked *) + +val logged_mark_node: type_expr -> unit + (* Mark a type node, logging the marking so it can be backtracked *) +val try_logged_mark_node: type_expr -> bool + (* Mark a type node if it is not yet marked, logging the marking so it + can be backtracked. + Return false if it was already marked *) + +val flip_mark_node: type_expr -> unit + (* Mark a type node. + The marking is not logged and will have to be manually undone using + one of the various [unmark]'ing functions below. *) +val try_mark_node: type_expr -> bool + (* Mark a type node if it is not yet marked. + The marking is not logged and will have to be manually undone using + one of the various [unmark]'ing functions below. + + Return false if it was already marked *) val mark_type: type_expr -> unit - (* Mark a type *) -val mark_type_node: type_expr -> unit - (* Mark a type node (but not its sons) *) + (* Mark a type recursively *) val mark_type_params: type_expr -> unit - (* Mark the sons of a type node *) + (* Mark the sons of a type node recursively *) + val unmark_type: type_expr -> unit val unmark_type_decl: type_declaration -> unit val unmark_extension_constructor: extension_constructor -> unit @@ -195,6 +240,14 @@ val forget_abbrev: abbrev_memo ref -> Path.t -> unit (* Remove an abbreviation from the cache *) +(**** Backtracking ****) + +val snapshot: unit -> snapshot +val backtrack: snapshot -> unit + (* Backtrack to a given snapshot. Only possible if you have + not already backtracked to a previous snapshot. + Calls [cleanup_abbrev] internally *) + (**** Utilities for labels ****) val is_optional : arg_label -> bool @@ -211,190 +264,62 @@ val extract_label : whether (label, value) was at the head of the list, list without the extracted (label, value) *) -(**** Utilities for backtracking ****) - -type snapshot - (* A snapshot for backtracking *) -val snapshot: unit -> snapshot - (* Make a snapshot for later backtracking. Costs nothing *) -val backtrack: snapshot -> unit - (* Backtrack to a given snapshot. Only possible if you have - not already backtracked to a previous snapshot. - Calls [cleanup_abbrev] internally *) -val undo_compress: snapshot -> unit - (* Backtrack only path compression. Only meaningful if you have - not already backtracked to a previous snapshot. - Does not call [cleanup_abbrev] *) - -(* Functions to use when modifying a type (only Ctype?) *) -val link_type: type_expr -> type_expr -> unit - (* Set the desc field of [t1] to [Tlink t2], logging the old - value if there is an active snapshot *) -val set_type_desc: type_expr -> type_desc -> unit - (* Set directly the desc field, without sharing *) -val set_level: type_expr -> int -> unit -val set_scope: type_expr -> int -> unit -val set_name: - (Path.t * type_expr list) option ref -> - (Path.t * type_expr list) option -> unit -val set_row_field: row_field option ref -> row_field -> unit -val set_univar: type_expr option ref -> type_expr -> unit -val set_kind: field_kind option ref -> field_kind -> unit -val set_commu: commutable ref -> commutable -> unit -val set_typeset: TypeSet.t ref -> TypeSet.t -> unit - (* Set references, logging the old value *) - -(**** Forward declarations ****) -val print_raw: (Format.formatter -> type_expr -> unit) ref - -val iter_type_expr_kind: (type_expr -> unit) -> (type_kind -> unit) - -val iter_type_expr_cstr_args: (type_expr -> unit) -> - (constructor_arguments -> unit) -val map_type_expr_cstr_args: (type_expr -> type_expr) -> - (constructor_arguments -> constructor_arguments) +(**** Utilities for class types ****) +(* Get the class signature within a class type *) +val signature_of_class_type : class_type -> class_signature +(* Get the body of a class type (i.e. without parameters) *) +val class_body : class_type -> class_type -module Alloc_mode : sig +(* Fully expand the head of a class type *) +val scrape_class_type : class_type -> class_type - (* Modes are ordered so that [global] is a submode of [local] *) - type t = Types.alloc_mode - type const = Types.alloc_mode_const = Global | Local +(* Return the number of parameters of a class type *) +val class_type_arity : class_type -> int - val global : t +(* Given a path and type parameters, add an abbreviation to a class type *) +val abbreviate_class_type : + Path.t -> type_expr list -> class_type -> class_type - val local : t +(* Get the self type of a class *) +val self_type : class_type -> type_expr - val of_const : const -> t +(* Get the row variable of the self type of a class *) +val self_type_row : class_type -> type_expr - val min_mode : t +(* Return the methods of a class signature *) +val methods : class_signature -> string list - val max_mode : t +(* Return the virtual methods of a class signature *) +val virtual_methods : class_signature -> string list - val submode : t -> t -> (unit, unit) result +(* Return the concrete methods of a class signature *) +val concrete_methods : class_signature -> MethSet.t - val submode_exn : t -> t -> unit +(* Return the public methods of a class signature *) +val public_methods : class_signature -> string list - val equate : t -> t -> (unit, unit) result +(* Return the instance variables of a class signature *) +val instance_vars : class_signature -> string list - val make_global_exn : t -> unit +(* Return the virtual instance variables of a class signature *) +val virtual_instance_vars : class_signature -> string list - val make_local_exn : t -> unit +(* Return the concrete instance variables of a class signature *) +val concrete_instance_vars : class_signature -> VarSet.t - val join_const : const -> const -> const +(* Return the type of a method. + @raises [Assert_failure] if the class has no such method. *) +val method_type : label -> class_signature -> type_expr - val join : t list -> t +(* Return the type of an instance variable. + @raises [Assert_failure] if the class has no such method. *) +val instance_variable_type : label -> class_signature -> type_expr - (* Force a mode variable to its upper bound *) - val constrain_upper : t -> const - - (* Force a mode variable to its lower bound *) - val constrain_lower : t -> const - - val newvar : unit -> t - - val newvar_below : t -> t * bool - - val newvar_above : t -> t * bool - - val check_const : t -> const option - - val print : Format.formatter -> t -> unit - -end - -module Value_mode : sig - - type const = - | Global - | Regional - | Local - - type t = Types.value_mode - - val global : t - - val regional : t - - val local : t - - val of_const : const -> t - - val max_mode : t - - val min_mode : t - - (** Injections from [Alloc_mode.t] into [Value_mode.t] *) - - (** [of_alloc] maps [Global] to [Global] and [Local] to [Local] *) - val of_alloc : Alloc_mode.t -> t - - (** Kernel operators *) - - (** The kernel operator [local_to_regional] maps [Local] to - [Regional] and leaves the others unchanged. *) - val local_to_regional : t -> t - - (** The kernel operator [regional_to_global] maps [Regional] - to [Global] and leaves the others unchanged. *) - val regional_to_global : t -> t - - (** Closure operators *) - - (** The closure operator [regional_to_local] maps [Regional] - to [Local] and leaves the others unchanged. *) - val regional_to_local : t -> t - - (** The closure operator [global_to_regional] maps [Global] to - [Regional] and leaves the others unchanged. *) - val global_to_regional : t -> t - - (** Note that the kernal and closure operators are in the following - adjunction relationship: - {v - local_to_regional - -| regional_to_local - -| regional_to_global - -| global_to_regional - v} - - Equivalently, - {v - local_to_regional a <= b iff a <= regional_to_local b - regional_to_local a <= b iff a <= regional_to_global b - regional_to_global a <= b iff a <= global_to_regional b - v} - *) - - (** Versions of the operators that return [Alloc.t] *) - - (** Maps [Regional] to [Global] and leaves the others unchanged. *) - val regional_to_global_alloc : t -> Alloc_mode.t - - (** Maps [Regional] to [Local] and leaves the others unchanged. *) - val regional_to_local_alloc : t -> Alloc_mode.t - - type error = [`Regionality | `Locality] - - val submode : t -> t -> (unit, error) result - - val submode_exn : t -> t -> unit - - val submode_meet : t -> t list -> (unit, error) result - - val join : t list -> t - - val constrain_upper : t -> const - - val constrain_lower : t -> const - - val newvar : unit -> t - - val newvar_below : t -> t - - val check_const : t -> const option +(**** Forward declarations ****) +val print_raw: (Format.formatter -> type_expr -> unit) ref - val print : Format.formatter -> t -> unit +(**** Type information getter ****) -end +val cstr_type_path : constructor_description -> Path.t diff --git a/ocaml/typing/ctype.ml b/ocaml/typing/ctype.ml index 0705a9b50d1..ad564c1850e 100644 --- a/ocaml/typing/ctype.ml +++ b/ocaml/typing/ctype.ml @@ -19,8 +19,10 @@ open Misc open Asttypes open Types open Btype +open Errortrace open Local_store +module Int = Misc.Stdlib.Int (* Type manipulation after type inference @@ -42,7 +44,7 @@ open Local_store class do not depend on sharing thanks to constrained abbreviations. (Of course, even if some sharing is lost, typing will still be correct.) - - All nodes of a type have a level : that way, one know whether a + - All nodes of a type have a level : that way, one knows whether a node need to be duplicated or not when instantiating a type. - Levels of a type are decreasing (generic level being considered as greatest). @@ -56,109 +58,64 @@ open Local_store (**** Errors ****) -module Unification_trace = struct - - type position = First | Second - let swap_position = function - | First -> Second - | Second -> First - - type desc = { t: type_expr; expanded: type_expr option } - type 'a diff = { got: 'a; expected: 'a} - - type 'a escape = - | Constructor of Path.t - | Univ of type_expr - (* The type_expr argument of [Univ] is always a [Tunivar _], - we keep a [type_expr] to track renaming in {!Printtyp} *) - | Self - | Module_type of Path.t - | Equation of 'a - - type fixed_row_case = - | Cannot_be_closed - | Cannot_add_tags of string list - - type variant = - | No_intersection - | No_tags of position * (Asttypes.label * row_field) list - | Incompatible_types_for of string - | Fixed_row of position * fixed_row_case * fixed_explanation - - - type obj = - | Missing_field of position * string - | Abstract_row of position - | Self_cannot_be_closed - - type 'a elt = - | Diff of 'a diff - | Variant of variant - | Obj of obj - | Escape of {context:type_expr option; kind: 'a escape} - | Incompatible_fields of {name:string; diff:type_expr diff } - | Rec_occur of type_expr * type_expr - - type t = desc elt list - let short t = { t; expanded = None } - let map_diff f r = - (* ordering is often meaningful when dealing with type_expr *) - let got = f r.got in - let expected = f r.expected in - { got; expected} - let diff got expected = Diff (map_diff short {got;expected}) - - let map_elt f = function - | Diff x -> Diff (map_diff f x) - | Escape {kind=Equation x; context} -> Escape {kind=Equation(f x); context} - | Rec_occur (_,_) - | Escape {kind=(Univ _ | Self|Constructor _ | Module_type _ ); _} - | Variant _ | Obj _ - | Incompatible_fields _ as x -> x - let map f = List.map (map_elt f) - - - (* Convert desc to type_expr * type_expr *) - let flatten_desc f x = match x.expanded with - | None -> f x.t x.t - | Some expanded -> f x.t expanded - let flatten f = map (flatten_desc f) - - (* Permute the expected and actual values *) - let swap_diff x = { got = x.expected; expected = x.got } - let swap_elt = function - | Diff x -> Diff (swap_diff x) - | Incompatible_fields {name;diff} -> - Incompatible_fields { name; diff = swap_diff diff} - | Obj (Missing_field(pos,s)) -> Obj(Missing_field(swap_position pos,s)) - | Obj (Abstract_row pos) -> Obj(Abstract_row (swap_position pos)) - | Variant (Fixed_row(pos,k,f)) -> Variant (Fixed_row(swap_position pos,k,f)) - | Variant (No_tags(pos,f)) -> Variant (No_tags(swap_position pos,f)) - | x -> x - let swap x = List.map swap_elt x - - exception Unify of t - - let escape kind = Escape { kind; context = None} - let scope_escape x = Unify[escape (Equation (short x))] - let rec_occur x y = Unify[Rec_occur(x, y)] - let incompatible_fields name got expected = - Incompatible_fields {name; diff={got; expected} } - - let explain trace f = - let rec explain = function - | [] -> None - | [h] -> f ~prev:None h - | h :: (prev :: _ as rem) -> - match f ~prev:(Some prev) h with - | Some _ as m -> m - | None -> explain rem in - explain (List.rev trace) - -end -module Trace = Unification_trace - -exception Unify = Trace.Unify +(* There are two classes of errortrace-related exceptions: *traces* and + *errors*. The former, whose names end with [_trace], contain + [Errortrace.trace]s, representing traces that are currently being built; they + are local to this file. All the internal functions that implement + unification, type equality, and moregen raise trace exceptions. Once we are + done, in the top level functions such as [unify], [equal], and [moregen], we + catch the trace exceptions and transform them into the analogous error + exception. This indicates that we are done building the trace, and expect + the error to flow out of unification, type equality, or moregen into + surrounding code (with some few exceptions when these top-level functions are + used as building blocks elsewhere.) Only the error exceptions are exposed in + [ctype.mli]; the trace exceptions are an implementation detail. Any trace + exception that escapes from a function in this file is a bug. *) + +exception Unify_trace of unification trace +exception Equality_trace of comparison trace +exception Moregen_trace of comparison trace + +exception Unify of unification_error +exception Equality of equality_error +exception Moregen of moregen_error +exception Subtype of Subtype.error + +exception Escape of type_expr escape + +(* For local use: throw the appropriate exception. Can be passed into local + functions as a parameter *) +type _ trace_exn = +| Unify : unification trace_exn +| Moregen : comparison trace_exn +| Equality : comparison trace_exn + +let raise_trace_for + (type variant) + (tr_exn : variant trace_exn) + (tr : variant trace) : 'a = + match tr_exn with + | Unify -> raise (Unify_trace tr) + | Equality -> raise (Equality_trace tr) + | Moregen -> raise (Moregen_trace tr) + +(* Uses of this function are a bit suspicious, as we usually want to maintain + trace information; sometimes it makes sense, however, since we're maintaining + the trace at an outer exception handler. *) +let raise_unexplained_for tr_exn = + raise_trace_for tr_exn [] + +let raise_for tr_exn e = + raise_trace_for tr_exn [e] + +(* Thrown from [moregen_kind] *) +exception Public_method_to_private_method + +let escape kind = {kind; context = None} +let escape_exn kind = Escape (escape kind) +let scope_escape_exn ty = escape_exn (Equation ty) +let raise_escape_exn kind = raise (escape_exn kind) +let raise_scope_escape_exn ty = raise (scope_escape_exn ty) exception Tags of label * label @@ -175,12 +132,18 @@ let () = | _ -> None ) -exception Subtype of Unification_trace.t * Unification_trace.t - exception Cannot_expand exception Cannot_apply +exception Cannot_subst + +exception Cannot_unify_universal_variables + +exception Matches_failure of Env.t * unification_error + +exception Incompatible + (**** Type level management ****) let current_level = s_ref 0 @@ -269,92 +232,99 @@ let proper_abbrevs path tl abbrev = (* Re-export generic type creators *) -let newty2 = Btype.newty2 -let newty desc = newty2 !current_level desc +let newty desc = newty2 ~level:!current_level desc +let new_scoped_ty scope desc = newty3 ~level:!current_level ~scope desc -let newvar ?name () = newty2 !current_level (Tvar name) -let newvar2 ?name level = newty2 level (Tvar name) -let new_global_var ?name () = newty2 !global_level (Tvar name) +let newvar ?name () = newty2 ~level:!current_level (Tvar name) +let newvar2 ?name level = newty2 ~level:level (Tvar name) +let new_global_var ?name () = newty2 ~level:!global_level (Tvar name) +let newstub ~scope = newty3 ~level:!current_level ~scope (Tvar None) let newobj fields = newty (Tobject (fields, ref None)) let newconstr path tyl = newty (Tconstr (path, tyl, ref Mnil)) -let none = newty (Ttuple []) (* Clearly ill-formed type *) - -(**** Representative of a type ****) - -(* Re-export repr *) -let repr = repr +let newmono ty = newty (Tpoly(ty, [])) -(**** Type maps ****) - -module TypePairs = struct - module H = Hashtbl.Make (struct - type t = type_expr * type_expr - let equal (t1, t1') (t2, t2') = (t1 == t2) && (t1' == t2') - let hash (t, t') = t.id + 93 * t'.id - end) - - type t = { - set : unit H.t; - mutable elems : (type_expr * type_expr) list; - (* elems preserves the (reversed) insertion order of elements *) - } - - let create n = - { elems = []; set = H.create n } +let none = newty (Ttuple []) (* Clearly ill-formed type *) - let clear t = - t.elems <- []; - H.clear t.set +(**** unification mode ****) - let repr2 (t1, t2) = (repr t1, repr t2) +type equations_generation = + | Forbidden + | Allowed of { equated_types : TypePairs.t } - let add t p = - let p = repr2 p in - if H.mem t.set p then () else begin - H.add t.set p (); - t.elems <- p :: t.elems - end +type unification_mode = + | Expression (* unification in expression *) + | Pattern of + { equations_generation : equations_generation; + assume_injective : bool; + allow_recursive_equations : bool; } + (* unification in pattern which may add local constraints *) + | Subst + (* unification during type constructor expansion; more + relaxed than [Expression] in some cases. *) - let mem t p = H.mem t.set (repr2 p) +let umode = ref Expression - let iter f t = - (* iterate in insertion order, not Hashtbl.iter order *) - List.rev t.elems - |> List.iter (fun (t1,t2) -> - f (t1, t2)) -end +let in_pattern_mode () = + match !umode with + | Expression | Subst -> false + | Pattern _ -> true +let in_subst_mode () = + match !umode with + | Expression | Pattern _ -> false + | Subst -> true -(**** unification mode ****) +let can_generate_equations () = + match !umode with + | Expression | Subst | Pattern { equations_generation = Forbidden } -> false + | Pattern { equations_generation = Allowed _ } -> true -type unification_mode = - | Expression (* unification in expression *) - | Pattern (* unification in pattern which may add local constraints *) +(* Can only be called when generate_equations is true *) +let record_equation t1 t2 = + match !umode with + | Expression | Subst | Pattern { equations_generation = Forbidden } -> + assert false + | Pattern { equations_generation = Allowed { equated_types } } -> + TypePairs.add equated_types (t1, t2) -type equations_generation = - | Forbidden - | Allowed of { equated_types : TypePairs.t } +let can_assume_injective () = + match !umode with + | Expression | Subst -> false + | Pattern { assume_injective } -> assume_injective + +let allow_recursive_equations () = + !Clflags.recursive_types + || match !umode with + | Expression | Subst -> false + | Pattern { allow_recursive_equations } -> allow_recursive_equations + +let set_mode_pattern ~allow_recursive_equations ~equated_types f = + let equations_generation = Allowed { equated_types } in + let assume_injective = true in + let new_umode = + Pattern + { equations_generation; + assume_injective; + allow_recursive_equations } + in + Misc.protect_refs [ Misc.R (umode, new_umode) ] f -let umode = ref Expression -let equations_generation = ref Forbidden -let assume_injective = ref false -let allow_recursive_equation = ref false +let without_assume_injective f = + match !umode with + | Expression | Subst -> f () + | Pattern r -> + let new_umode = Pattern { r with assume_injective = false } in + Misc.protect_refs [ Misc.R (umode, new_umode) ] f -let can_generate_equations () = - match !equations_generation with - | Forbidden -> false - | _ -> true - -let set_mode_pattern ~generate ~injective ~allow_recursive f = - Misc.protect_refs - [ Misc.R (umode, Pattern); - Misc.R (equations_generation, generate); - Misc.R (assume_injective, injective); - Misc.R (allow_recursive_equation, allow_recursive); - ] f +let without_generating_equations f = + match !umode with + | Expression | Subst -> f () + | Pattern r -> + let new_umode = Pattern { r with equations_generation = Forbidden } in + Misc.protect_refs [ Misc.R (umode, new_umode) ] f (*** Checks for type definitions ***) @@ -386,14 +356,13 @@ let is_datatype decl= (**** Object field manipulation. ****) let object_fields ty = - match (repr ty).desc with + match get_desc ty with Tobject (fields, _) -> fields | _ -> assert false let flatten_fields ty = let rec flatten l ty = - let ty = repr ty in - match ty.desc with + match get_desc ty with Tfield(s, k, ty1, ty2) -> flatten ((s, k, ty1)::l) ty2 | _ -> @@ -404,7 +373,7 @@ let flatten_fields ty = let build_fields level = List.fold_right - (fun (s, k, ty1) ty2 -> newty2 level (Tfield(s, k, ty1, ty2))) + (fun (s, k, ty1) ty2 -> newty2 ~level (Tfield(s, k, ty1, ty2))) let associate_fields fields1 fields2 = let rec associate p s s' = @@ -422,121 +391,50 @@ let associate_fields fields1 fields2 = in associate [] [] [] (fields1, fields2) -let rec has_dummy_method ty = - match repr ty with - {desc = Tfield (m, _, _, ty2)} -> - m = dummy_method || has_dummy_method ty2 - | _ -> false - -let is_self_type = function - | Tobject (ty, _) -> has_dummy_method ty - | _ -> false - (**** Check whether an object is open ****) (* +++ The abbreviation should eventually be expanded *) let rec object_row ty = - let ty = repr ty in - match ty.desc with + match get_desc ty with Tobject (t, _) -> object_row t | Tfield(_, _, _, t) -> object_row t | _ -> ty let opened_object ty = - match (object_row ty).desc with + match get_desc (object_row ty) with | Tvar _ | Tunivar _ | Tconstr _ -> true | _ -> false let concrete_object ty = - match (object_row ty).desc with + match get_desc (object_row ty) with | Tvar _ -> false | _ -> true -(**** Close an object ****) - -let close_object ty = - let rec close ty = - let ty = repr ty in - match ty.desc with - Tvar _ -> - link_type ty (newty2 ty.level Tnil); true - | Tfield(lab, _, _, _) when lab = dummy_method -> - false - | Tfield(_, _, _, ty') -> close ty' - | _ -> assert false - in - match (repr ty).desc with - Tobject (ty, _) -> close ty - | _ -> assert false - (**** Row variable of an object type ****) -let row_variable ty = - let rec find ty = - let ty = repr ty in - match ty.desc with - Tfield (_, _, _, ty) -> find ty - | Tvar _ -> ty - | _ -> assert false - in - match (repr ty).desc with - Tobject (fi, _) -> find fi - | _ -> assert false +let rec fields_row_variable ty = + match get_desc ty with + | Tfield (_, _, _, ty) -> fields_row_variable ty + | Tvar _ -> ty + | _ -> assert false (**** Object name manipulation ****) (* +++ Bientot obsolete *) -let set_object_name id rv params ty = - match (repr ty).desc with - Tobject (_fi, nm) -> +let set_object_name id params ty = + match get_desc ty with + | Tobject (fi, nm) -> + let rv = fields_row_variable fi in set_name nm (Some (Path.Pident id, rv::params)) - | _ -> - assert false + | Tconstr (_, _, _) -> () + | _ -> fatal_error "Ctype.set_object_name" let remove_object_name ty = - match (repr ty).desc with + match get_desc ty with Tobject (_, nm) -> set_name nm None | Tconstr (_, _, _) -> () | _ -> fatal_error "Ctype.remove_object_name" -(**** Hiding of private methods ****) - -let hide_private_methods ty = - match (repr ty).desc with - Tobject (fi, nm) -> - nm := None; - let (fl, _) = flatten_fields fi in - List.iter - (function (_, k, _) -> - match field_kind_repr k with - Fvar r -> set_kind r Fabsent - | _ -> ()) - fl - | _ -> - assert false - - - (*******************************) - (* Operations on class types *) - (*******************************) - - -let rec signature_of_class_type = - function - Cty_constr (_, _, cty) -> signature_of_class_type cty - | Cty_signature sign -> sign - | Cty_arrow (_, _, cty) -> signature_of_class_type cty - -let self_type cty = - repr (signature_of_class_type cty).csig_self - -let rec class_type_arity = - function - Cty_constr (_, _, cty) -> class_type_arity cty - | Cty_signature _ -> 0 - | Cty_arrow (_, _, cty) -> 1 + class_type_arity cty - - (*******************************************) (* Miscellaneous operations on row types *) (*******************************************) @@ -565,9 +463,26 @@ let rec filter_row_fields erase = function let fi = filter_row_fields erase fi in match row_field_repr f with Rabsent -> fi - | Reither(_,_,false,e) when erase -> set_row_field e Rabsent; fi + | Reither(_,_,false) when erase -> + link_row_field_ext ~inside:f rf_absent; fi | _ -> p :: fi + +(* Ensure all mode variables are fully determined *) +let remove_mode_variables ty = + let visited = ref TypeSet.empty in + let rec go ty = + if TypeSet.mem ty !visited then () else begin + visited := TypeSet.add ty !visited; + match get_desc ty with + | Tarrow ((_,marg,mret),targ,tret,_) -> + let _ = Alloc_mode.constrain_lower marg in + let _ = Alloc_mode.constrain_lower mret in + go targ; go tret + | _ -> iter_type_expr go ty + end + in go ty + (**************************************) (* Check genericity of type schemes *) (**************************************) @@ -599,16 +514,14 @@ let really_closed = ref None and only returns a [variable list]. *) let rec free_vars_rec real ty = - let ty = repr ty in - if ty.level >= lowest_level then begin - ty.level <- pivot_level - ty.level; - begin match ty.desc, !really_closed with + if try_mark_node ty then + match get_desc ty, !really_closed with Tvar _, _ -> free_variables := (ty, real) :: !free_variables | Tconstr (path, tl, _), Some env -> begin try let (_, body, _) = Env.find_type_expansion path env in - if (repr body).level <> generic_level then + if get_level body <> generic_level then free_variables := (ty, real) :: !free_variables with Not_found -> () end; @@ -622,13 +535,10 @@ let rec free_vars_rec real ty = | Tfield (_, _, ty1, ty2), _ -> free_vars_rec true ty1; free_vars_rec false ty2 | Tvariant row, _ -> - let row = row_repr row in iter_row (free_vars_rec true) row; - if not (static_row row) then free_vars_rec false row.row_more + if not (static_row row) then free_vars_rec false (row_more row) | _ -> iter_type_expr (free_vars_rec true) ty - end; - end let free_vars ?env ty = free_variables := []; @@ -645,6 +555,7 @@ let free_variables ?env ty = tl let closed_type ty = + remove_mode_variables ty; match free_vars ty with [] -> () | (v, real) :: _ -> raise (Non_closed (v, real)) @@ -663,14 +574,14 @@ let closed_type_decl decl = begin match decl.type_kind with Type_abstract -> () - | Type_variant v -> + | Type_variant (v, _rep) -> List.iter (fun {cd_args; cd_res; _} -> match cd_res with | Some _ -> () | None -> match cd_args with - | Cstr_tuple l -> List.iter closed_type l + | Cstr_tuple l -> List.iter (fun (ty, _) -> closed_type ty) l | Cstr_record l -> List.iter (fun l -> closed_type l.ld_type) l ) v @@ -701,34 +612,23 @@ let closed_extension_constructor ext = unmark_extension_constructor ext; Some ty -type closed_class_failure = - CC_Method of type_expr * bool * string * type_expr - | CC_Value of type_expr * bool * string * type_expr - -exception CCFailure of closed_class_failure +exception CCFailure of (type_expr * bool * string * type_expr) let closed_class params sign = - let ty = object_fields (repr sign.csig_self) in - let (fields, rest) = flatten_fields ty in List.iter mark_type params; - mark_type rest; - List.iter - (fun (lab, _, ty) -> if lab = dummy_method then mark_type ty) - fields; + ignore (try_mark_node sign.csig_self_row); try - mark_type_node (repr sign.csig_self); - List.iter - (fun (lab, kind, ty) -> - if field_kind_repr kind = Fpresent then - try closed_type ty with Non_closed (ty0, real) -> - raise (CCFailure (CC_Method (ty0, real, lab, ty)))) - fields; - mark_type_params (repr sign.csig_self); + Meths.iter + (fun lab (priv, _, ty) -> + if priv = Mpublic then begin + try closed_type ty with Non_closed (ty0, real) -> + raise (CCFailure (ty0, real, lab, ty)) + end) + sign.csig_meths; List.iter unmark_type params; unmark_class_signature sign; None with CCFailure reason -> - mark_type_params (repr sign.csig_self); List.iter unmark_type params; unmark_class_signature sign; Some reason @@ -760,10 +660,11 @@ let duplicate_class_type ty = preserved. Does it worth duplicating this code ? *) let rec generalize ty = - let ty = repr ty in - if (ty.level > !current_level) && (ty.level <> generic_level) then begin + let level = get_level ty in + if (level > !current_level) && (level <> generic_level) then begin set_level ty generic_level; - begin match ty.desc with + (* recur into abbrev for the speed *) + begin match get_desc ty with Tconstr (_, _, abbrev) -> iter_abbrev generalize !abbrev | _ -> () @@ -777,33 +678,33 @@ let generalize ty = (* Generalize the structure and lower the variables *) -let rec generalize_structure var_level ty = - let ty = repr ty in - if ty.level <> generic_level then begin - if is_Tvar ty && ty.level > var_level then - set_level ty var_level +let rec generalize_structure ty = + let level = get_level ty in + if level <> generic_level then begin + if is_Tvar ty && level > !current_level then + set_level ty !current_level else if - ty.level > !current_level && - match ty.desc with + level > !current_level && + match get_desc ty with Tconstr (p, _, abbrev) -> not (is_object_type p) && (abbrev := Mnil; true) | _ -> true then begin set_level ty generic_level; - iter_type_expr (generalize_structure var_level) ty + iter_type_expr generalize_structure ty end end let generalize_structure ty = simple_abbrevs := Mnil; - generalize_structure !current_level ty + generalize_structure ty (* Generalize the spine of a function, if the level >= !current_level *) let rec generalize_spine ty = - let ty = repr ty in - if ty.level < !current_level || ty.level = generic_level then () else - match ty.desc with + let level = get_level ty in + if level < !current_level || level = generic_level then () else + match get_desc ty with Tarrow (_, ty1, ty2, _) -> set_level ty generic_level; generalize_spine ty1; @@ -811,18 +712,20 @@ let rec generalize_spine ty = | Tpoly (ty', _) -> set_level ty generic_level; generalize_spine ty' - | Ttuple tyl - | Tpackage (_, _, tyl) -> + | Ttuple tyl -> set_level ty generic_level; List.iter generalize_spine tyl + | Tpackage (_, fl) -> + set_level ty generic_level; + List.iter (fun (_n, ty) -> generalize_spine ty) fl | Tconstr (p, tyl, memo) when not (is_object_type p) -> set_level ty generic_level; memo := Mnil; List.iter generalize_spine tyl | _ -> () -let forward_try_expand_once = (* Forward declaration *) - ref (fun _env _ty -> raise Cannot_expand) +let forward_try_expand_safe = (* Forward declaration *) + ref (fun _env _ty -> assert false) (* Lower the levels of a type (assume [level] is not @@ -846,51 +749,47 @@ let rec normalize_package_path env p = | _ -> p let rec check_scope_escape env level ty = - let mark ty = - (* Mark visited types with [ty.level < lowest_level]. *) - set_level ty (pivot_level - ty.level) - in - let ty = repr ty in - (* If the type hasn't been marked, check it. Otherwise, we have already - checked it. - *) - if ty.level >= lowest_level then begin - if level < ty.scope then - raise(Trace.scope_escape ty); - begin match ty.desc with + let orig_level = get_level ty in + if try_logged_mark_node ty then begin + if level < get_scope ty then + raise_scope_escape_exn ty; + begin match get_desc ty with | Tconstr (p, _, _) when level < Path.scope p -> - begin match !forward_try_expand_once env ty with + begin match !forward_try_expand_safe env ty with | ty' -> - mark ty; check_scope_escape env level ty' | exception Cannot_expand -> - raise Trace.(Unify [escape (Constructor p)]) + raise_escape_exn (Constructor p) end - | Tpackage (p, nl, tl) when level < Path.scope p -> + | Tpackage (p, fl) when level < Path.scope p -> let p' = normalize_package_path env p in - if Path.same p p' then raise Trace.(Unify [escape (Module_type p)]); - let orig_level = ty.level in - mark ty; + if Path.same p p' then raise_escape_exn (Module_type p); check_scope_escape env level - (Btype.newty2 orig_level (Tpackage (p', nl, tl))) + (newty2 ~level:orig_level (Tpackage (p', fl))) | _ -> - mark ty; - iter_type_expr (check_scope_escape env level) ty + iter_type_expr (check_scope_escape env level) ty end; end let check_scope_escape env level ty = let snap = snapshot () in try check_scope_escape env level ty; backtrack snap - with Unify [Trace.Escape x] -> + with Escape e -> backtrack snap; - raise Trace.(Unify[Escape { x with context = Some ty }]) + raise (Escape { e with context = Some ty }) + +let rec update_scope scope ty = + if get_scope ty < scope then begin + if get_level ty < scope then raise_scope_escape_exn ty; + set_scope ty scope; + (* Only recurse in principal mode as this is not necessary for soundness *) + if !Clflags.principal then iter_type_expr (update_scope scope) ty + end -let update_scope scope ty = - let ty = repr ty in - let scope = max scope ty.scope in - if ty.level < scope then raise (Trace.scope_escape ty); - set_scope ty scope +let update_scope_for tr_exn scope ty = + try + update_scope scope ty + with Escape e -> raise_for tr_exn (Escape e) (* Note: the level of a type constructor must be greater than its binding time. That way, a type constructor cannot escape the scope of its @@ -901,17 +800,17 @@ let update_scope scope ty = *) let rec update_level env level expand ty = - let ty = repr ty in - if ty.level > level then begin - if level < ty.scope then raise (Trace.scope_escape ty); - match ty.desc with + if get_level ty > level then begin + if level < get_scope ty then raise_scope_escape_exn ty; + match get_desc ty with Tconstr(p, _tl, _abbrev) when level < Path.scope p -> (* Try first to replace an abbreviation by its expansion. *) begin try - link_type ty (!forward_try_expand_once env ty); - update_level env level expand ty + let ty' = !forward_try_expand_safe env ty in + link_type ty ty'; + update_level env level expand ty' with Cannot_expand -> - raise Trace.(Unify [escape(Constructor p)]) + raise_escape_exn (Constructor p) end | Tconstr(p, (_ :: _ as tl), _) -> let variance = @@ -920,38 +819,38 @@ let rec update_level env level expand ty = let needs_expand = expand || List.exists2 - (fun var ty -> var = Variance.null && (repr ty).level > level) + (fun var ty -> var = Variance.null && get_level ty > level) variance tl in begin try if not needs_expand then raise Cannot_expand; - link_type ty (!forward_try_expand_once env ty); - update_level env level expand ty + let ty' = !forward_try_expand_safe env ty in + link_type ty ty'; + update_level env level expand ty' with Cannot_expand -> set_level ty level; iter_type_expr (update_level env level expand) ty end - | Tpackage (p, nl, tl) when level < Path.scope p -> + | Tpackage (p, fl) when level < Path.scope p -> let p' = normalize_package_path env p in - if Path.same p p' then raise Trace.(Unify [escape (Module_type p)]); - set_type_desc ty (Tpackage (p', nl, tl)); + if Path.same p p' then raise_escape_exn (Module_type p); + set_type_desc ty (Tpackage (p', fl)); update_level env level expand ty - | Tobject(_, ({contents=Some(p, _tl)} as nm)) + | Tobject (_, ({contents=Some(p, _tl)} as nm)) when level < Path.scope p -> set_name nm None; update_level env level expand ty | Tvariant row -> - let row = row_repr row in - begin match row.row_name with + begin match row_name row with | Some (p, _tl) when level < Path.scope p -> - set_type_desc ty (Tvariant {row with row_name = None}) + set_type_desc ty (Tvariant (set_row_name row None)) | _ -> () end; set_level ty level; iter_type_expr (update_level env level expand) ty | Tfield(lab, _, ty1, _) - when lab = dummy_method && (repr ty1).level > level -> - raise Trace.(Unify [escape Self]) + when lab = dummy_method && level < get_scope ty1 -> + raise_escape_exn Self | _ -> set_level ty level; (* XXX what about abbreviations in Tconstr ? *) @@ -961,30 +860,33 @@ let rec update_level env level expand ty = (* First try without expanding, then expand everything, to avoid combinatorial blow-up *) let update_level env level ty = - let ty = repr ty in - if ty.level > level then begin + if get_level ty > level then begin let snap = snapshot () in try update_level env level false ty - with Unify _ -> + with Escape _ -> backtrack snap; update_level env level true ty end +let update_level_for tr_exn env level ty = + try + update_level env level ty + with Escape e -> raise_for tr_exn (Escape e) + (* Lower level of type variables inside contravariant branches *) let rec lower_contravariant env var_level visited contra ty = - let ty = repr ty in let must_visit = - ty.level > var_level && - match Hashtbl.find visited ty.id with + get_level ty > var_level && + match Hashtbl.find visited (get_id ty) with | done_contra -> contra && not done_contra | exception Not_found -> true in if must_visit then begin - Hashtbl.add visited ty.id contra; + Hashtbl.add visited (get_id ty) contra; let lower_rec = lower_contravariant env var_level visited in - match ty.desc with + match get_desc ty with Tvar _ -> if contra then set_level ty var_level | Tconstr (_, [], _) -> () | Tconstr (path, tyl, _abbrev) -> @@ -1008,12 +910,12 @@ let rec lower_contravariant env var_level visited contra ty = else lower_rec contra t) variance tyl in if maybe_expand then (* we expand cautiously to avoid missing cmis *) - match !forward_try_expand_once env ty with + match !forward_try_expand_safe env ty with | ty -> lower_rec contra ty | exception Cannot_expand -> not_expanded () else not_expanded () - | Tpackage (_, _, tyl) -> - List.iter (lower_rec true) tyl + | Tpackage (_, fl) -> + List.iter (fun (_n, ty) -> lower_rec true ty) fl | Tarrow (_, t1, t2, _) -> lower_rec true t1; lower_rec contra t2 @@ -1021,46 +923,68 @@ let rec lower_contravariant env var_level visited contra ty = iter_type_expr (lower_rec contra) ty end +let lower_variables_only env level ty = + simple_abbrevs := Mnil; + lower_contravariant env level (Hashtbl.create 7) true ty + let lower_contravariant env ty = simple_abbrevs := Mnil; lower_contravariant env !nongen_level (Hashtbl.create 7) false ty +let rec generalize_class_type' gen = + function + Cty_constr (_, params, cty) -> + List.iter gen params; + generalize_class_type' gen cty + | Cty_signature csig -> + gen csig.csig_self; + gen csig.csig_self_row; + Vars.iter (fun _ (_, _, ty) -> gen ty) csig.csig_vars; + Meths.iter (fun _ (_, _, ty) -> gen ty) csig.csig_meths + | Cty_arrow (_, ty, cty) -> + gen ty; + generalize_class_type' gen cty + +let generalize_class_type cty = + generalize_class_type' generalize cty + +let generalize_class_type_structure cty = + generalize_class_type' generalize_structure cty + (* Correct the levels of type [ty]. *) let correct_levels ty = duplicate_type ty (* Only generalize the type ty0 in ty *) let limited_generalize ty0 ty = - let ty0 = repr ty0 in - let graph = Hashtbl.create 17 in let idx = ref lowest_level in let roots = ref [] in let rec inverse pty ty = - let ty = repr ty in - if (ty.level > !current_level) || (ty.level = generic_level) then begin + let level = get_level ty in + if (level > !current_level) || (level = generic_level) then begin decr idx; Hashtbl.add graph !idx (ty, ref pty); - if (ty.level = generic_level) || (ty == ty0) then + if (level = generic_level) || eq_type ty ty0 then roots := ty :: !roots; set_level ty !idx; iter_type_expr (inverse [ty]) ty - end else if ty.level < lowest_level then begin - let (_, parents) = Hashtbl.find graph ty.level in + end else if level < lowest_level then begin + let (_, parents) = Hashtbl.find graph level in parents := pty @ !parents end and generalize_parents ty = - let idx = ty.level in + let idx = get_level ty in if idx <> generic_level then begin set_level ty generic_level; List.iter generalize_parents !(snd (Hashtbl.find graph idx)); (* Special case for rows: must generalize the row variable *) - match ty.desc with + match get_desc ty with Tvariant row -> let more = row_more row in - let lv = more.level in + let lv = get_level more in if (lv < lowest_level || lv > !current_level) && lv <> generic_level then set_level more generic_level | _ -> () @@ -1068,14 +992,16 @@ let limited_generalize ty0 ty = in inverse [] ty; - if ty0.level < lowest_level then + if get_level ty0 < lowest_level then iter_type_expr (inverse []) ty0; List.iter generalize_parents !roots; Hashtbl.iter (fun _ (ty, _) -> - if ty.level <> generic_level then set_level ty !current_level) + if get_level ty <> generic_level then set_level ty !current_level) graph +let limited_generalize_class_type rv cty = + generalize_class_type' (limited_generalize rv) cty (* Compute statically the free univars of all nodes in a type *) (* This avoids doing it repeatedly during instantiation *) @@ -1085,7 +1011,6 @@ type inv_type_expr = mutable inv_parents : inv_type_expr list } let rec inv_type hash pty ty = - let ty = repr ty in try let inv = TypeHash.find hash ty in inv.inv_parents <- pty @ inv.inv_parents @@ -1099,8 +1024,8 @@ let compute_univars ty = inv_type inverted [] ty; let node_univars = TypeHash.create 17 in let rec add_univar univ inv = - match inv.inv_type.desc with - Tpoly (_ty, tl) when List.memq univ (List.map repr tl) -> () + match get_desc inv.inv_type with + Tpoly (_ty, tl) when List.memq (get_id univ) (List.map get_id tl) -> () | _ -> try let univs = TypeHash.find node_univars inv.inv_type in @@ -1119,17 +1044,13 @@ let compute_univars ty = let fully_generic ty = - let rec aux acc ty = - acc && - let ty = repr ty in - ty.level < lowest_level || ( - ty.level = generic_level && ( - mark_type_node ty; - fold_type_expr aux true ty - ) - ) + let rec aux ty = + if not_marked_node ty then + if get_level ty = generic_level then + (flip_mark_node ty; iter_type_expr aux ty) + else raise Exit in - let res = aux true ty in + let res = try aux ty; true with Exit -> false in unmark_type ty; res @@ -1167,34 +1088,31 @@ let abbreviations = ref (ref Mnil) before we call type_pat *) let rec copy ?partial ?keep_names scope ty = let copy = copy ?partial ?keep_names scope in - let ty = repr ty in - match ty.desc with - Tsubst ty -> ty - | _ -> - if ty.level <> generic_level && partial = None then ty else + match get_desc ty with + Tsubst (ty, _) -> ty + | desc -> + let level = get_level ty in + if level <> generic_level && partial = None then ty else (* We only forget types that are non generic and do not contain free univars *) let forget = - if ty.level = generic_level then generic_level else + if level = generic_level then generic_level else match partial with None -> assert false | Some (free_univars, keep) -> - if TypeSet.is_empty (free_univars ty) then - if keep then ty.level else !current_level + if not (is_Tpoly ty) && TypeSet.is_empty (free_univars ty) then + if keep then level else !current_level else generic_level in - if forget <> generic_level then newty2 forget (Tvar None) else - let desc = ty.desc in - For_copy.save_desc scope ty desc; - let t = newvar() in (* Stub *) - set_scope t ty.scope; - ty.desc <- Tsubst t; - t.desc <- - begin match desc with + if forget <> generic_level then newty2 ~level:forget (Tvar None) else + let t = newstub ~scope:(get_scope ty) in + For_copy.redirect_desc scope ty (Tsubst (t, None)); + let desc' = + match desc with | Tconstr (p, tl, _) -> let abbrevs = proper_abbrevs p tl !abbreviations in begin match find_repr p !abbrevs with - Some ty when repr ty != t -> + Some ty when not (eq_type ty t) -> Tlink ty | _ -> (* @@ -1211,34 +1129,37 @@ let rec copy ?partial ?keep_names scope ty = Mcons _ -> Mlink !abbreviations | abbrev -> abbrev)) end - | Tvariant row0 -> - let row = row_repr row0 in - let more = repr row.row_more in + | Tvariant row -> + let more = row_more row in + let mored = get_desc more in (* We must substitute in a subtle way *) (* Tsubst takes a tuple containing the row var and the variant *) - begin match more.desc with - Tsubst {desc = Ttuple [_;ty2]} -> + begin match mored with + Tsubst (_, Some ty2) -> (* This variant type has been already copied *) - ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *) + (* Change the stub to avoid Tlink in the new type *) + For_copy.redirect_desc scope ty (Tsubst (ty2, None)); Tlink ty2 | _ -> (* If the row variable is not generic, we must keep it *) - let keep = more.level <> generic_level && partial = None in + let keep = get_level more <> generic_level && partial = None in let more' = - match more.desc with - Tsubst ty -> ty + match mored with + Tsubst (ty, None) -> ty + (* TODO: is this case possible? + possibly an interaction with (copy more) below? *) | Tconstr _ | Tnil -> - For_copy.save_desc scope more more.desc; copy more | Tvar _ | Tunivar _ -> - For_copy.save_desc scope more more.desc; - if keep then more else newty more.desc + if keep then more else newty mored | _ -> assert false in let row = - match repr more' with (* PR#6163 *) - {desc=Tconstr (x,_,_)} when not (is_fixed row) -> - {row with row_fixed = Some (Reified x)} + match get_desc more' with (* PR#6163 *) + Tconstr (x,_,_) when not (is_fixed row) -> + let Row {fields; more; closed; name} = row_repr row in + create_row ~fields ~more ~closed ~name + ~fixed:(Some (Reified x)) | _ -> row in (* Open row if partial for pattern and contains Reither *) @@ -1246,42 +1167,37 @@ let rec copy ?partial ?keep_names scope ty = match partial with Some (free_univars, false) -> let more' = - if more.id != more'.id then more' else - let lv = if keep then more.level else !current_level in - newty2 lv (Tvar None) + if not (eq_type more more') then + more' (* we've already made a copy *) + else + newvar () in let not_reither (_, f) = match row_field_repr f with Reither _ -> false | _ -> true in - if row.row_closed && not (is_fixed row) + let fields = row_fields row in + if row_closed row && not (is_fixed row) && TypeSet.is_empty (free_univars ty) - && not (List.for_all not_reither row.row_fields) then + && not (List.for_all not_reither fields) then (more', - {row_fields = List.filter not_reither row.row_fields; - row_more = more'; row_bound = (); - row_closed = false; row_fixed = None; row_name = None}) + create_row ~fields:(List.filter not_reither fields) + ~more:more' ~closed:false ~fixed:None ~name:None) else (more', row) | _ -> (more', row) in (* Register new type first for recursion *) - more.desc <- Tsubst(newgenty(Ttuple[more';t])); + For_copy.redirect_desc scope more + (Tsubst(more', Some t)); (* Return a new copy *) Tvariant (copy_row copy true row keep more') end - | Tfield (_p, k, _ty1, ty2) -> - begin match field_kind_repr k with - Fabsent -> Tlink (copy ty2) - | Fpresent -> copy_type_desc copy desc - | Fvar r -> - For_copy.dup_kind scope r; - copy_type_desc copy desc - end | Tobject (ty1, _) when partial <> None -> Tobject (copy ty1, ref None) | _ -> copy_type_desc ?keep_names copy desc - end; + in + Transient_expr.set_stub_desc t desc'; t (**** Variants of instantiations ****) @@ -1319,7 +1235,12 @@ let get_new_abstract_name s = if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else Printf.sprintf "%s%d" s index -let new_declaration expansion_scope manifest = +let new_local_type ?(loc = Location.none) ?manifest_and_scope () = + let manifest, expansion_scope = + match manifest_and_scope with + None -> None, Btype.lowest_level + | Some (ty, scope) -> Some ty, scope + in { type_params = []; type_arity = 0; @@ -1330,33 +1251,31 @@ let new_declaration expansion_scope manifest = type_separability = []; type_is_newtype = true; type_expansion_scope = expansion_scope; - type_loc = Location.none; + type_loc = loc; type_attributes = []; type_immediate = Unknown; - type_unboxed = unboxed_false_default_false; + type_unboxed_default = false; type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } -let existential_name cstr ty = match repr ty with - | {desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name +let existential_name cstr ty = + match get_desc ty with + | Tvar (Some name) -> "$" ^ cstr.cstr_name ^ "_'" ^ name | _ -> "$" ^ cstr.cstr_name let instance_constructor ?in_pattern cstr = For_copy.with_scope (fun scope -> begin match in_pattern with | None -> () - | Some (env, expansion_scope) -> + | Some (env, fresh_constr_scope) -> let process existential = - let decl = new_declaration expansion_scope None in + let decl = new_local_type () in let name = existential_name cstr existential in - let path = - Path.Pident - (Ident.create_scoped ~scope:expansion_scope - (get_new_abstract_name name)) - in - let new_env = Env.add_local_type path decl !env in + let (id, new_env) = + Env.enter_type (get_new_abstract_name name) decl !env + ~scope:fresh_constr_scope in env := new_env; - let to_unify = newty (Tconstr (path,[],ref Mnil)) in + let to_unify = newty (Tconstr (Path.Pident id,[],ref Mnil)) in let tv = copy scope existential in assert (is_Tvar tv); link_type tv to_unify @@ -1364,8 +1283,9 @@ let instance_constructor ?in_pattern cstr = List.iter process cstr.cstr_existentials end; let ty_res = copy scope cstr.cstr_res in - let ty_args = List.map (copy scope) cstr.cstr_args in - (ty_args, ty_res) + let ty_args = List.map (fun (ty, gf) -> copy scope ty, gf) cstr.cstr_args in + let ty_ex = List.map (copy scope) cstr.cstr_existentials in + (ty_args, ty_res, ty_ex) ) let instance_parameterized_type ?keep_names sch_args sch = @@ -1386,7 +1306,7 @@ let instance_parameterized_type_2 sch_args sch_lst sch = let map_kind f = function | Type_abstract -> Type_abstract | Type_open -> Type_open - | Type_variant cl -> + | Type_variant (cl, rep) -> Type_variant ( List.map (fun c -> @@ -1394,7 +1314,7 @@ let map_kind f = function cd_args = map_type_expr_cstr_args f c.cd_args; cd_res = Option.map f c.cd_res }) - cl) + cl, rep) | Type_record (fl, rr) -> Type_record ( List.map @@ -1427,13 +1347,15 @@ let instance_class params cty = | Cty_signature sign -> Cty_signature {csig_self = copy scope sign.csig_self; + csig_self_row = copy scope sign.csig_self_row; csig_vars = - Vars.map (function (m, v, ty) -> (m, v, copy scope ty)) + Vars.map + (function (m, v, ty) -> (m, v, copy scope ty)) sign.csig_vars; - csig_concr = sign.csig_concr; - csig_inher = - List.map (fun (p,tl) -> (p, List.map (copy scope) tl)) - sign.csig_inher} + csig_meths = + Meths.map + (function (p, v, ty) -> (p, v, copy scope ty)) + sign.csig_meths} | Cty_arrow (l, ty, cty) -> Cty_arrow (l, copy scope ty, copy_class_type scope cty) in @@ -1451,73 +1373,85 @@ let rec diff_list l1 l2 = | a :: l1 -> a :: diff_list l1 l2 let conflicts free bound = - let bound = List.map repr bound in - TypeSet.exists (fun t -> List.memq (repr t) bound) free + let bound = List.map get_id bound in + TypeSet.exists (fun t -> List.memq (get_id t) bound) free let delayed_copy = ref [] (* copying to do later *) (* Copy without sharing until there are no free univars left *) (* all free univars must be included in [visited] *) -let rec copy_sep cleanup_scope fixed free bound visited ty = - let ty = repr ty in +let rec copy_sep ~cleanup_scope ~fixed ~free ~bound ~may_share + (visited : (int * (type_expr * type_expr list)) list) (ty : type_expr) = let univars = free ty in - if TypeSet.is_empty univars then - if ty.level <> generic_level then ty else - let t = newvar () in + if is_Tvar ty || may_share && TypeSet.is_empty univars then + if get_level ty <> generic_level then ty else + let t = newstub ~scope:(get_scope ty) in delayed_copy := - lazy (t.desc <- Tlink (copy cleanup_scope ty)) + lazy (Transient_expr.set_stub_desc t (Tlink (copy cleanup_scope ty))) :: !delayed_copy; t else try - let t, bound_t = List.assq ty visited in + let t, bound_t = List.assq (get_id ty) visited in let dl = if is_Tunivar ty then [] else diff_list bound bound_t in if dl <> [] && conflicts univars dl then raise Not_found; t with Not_found -> begin - let t = newvar() in (* Stub *) + let t = newstub ~scope:(get_scope ty) in + let desc = get_desc ty in let visited = - match ty.desc with + match desc with Tarrow _ | Ttuple _ | Tvariant _ | Tconstr _ | Tobject _ | Tpackage _ -> - (ty,(t,bound)) :: visited - | Tvar _ | Tfield _ | Tnil | Tpoly _ | Tunivar _ | Tlink _ | Tsubst _ -> + (get_id ty, (t, bound)) :: visited + | Tvar _ | Tfield _ | Tnil | Tpoly _ | Tunivar _ -> visited + | Tlink _ | Tsubst _ -> + assert false in - let copy_rec = copy_sep cleanup_scope fixed free bound visited in - t.desc <- - begin match ty.desc with - | Tvariant row0 -> - let row = row_repr row0 in - let more = repr row.row_more in + let copy_rec = copy_sep ~cleanup_scope ~fixed ~free ~bound visited in + let desc' = + match desc with + | Tvariant row -> + let more = row_more row in (* We shall really check the level on the row variable *) - let keep = is_Tvar more && more.level <> generic_level in - let more' = copy_rec more in + let keep = is_Tvar more && get_level more <> generic_level in + let more' = copy_rec ~may_share:false more in let fixed' = fixed && (is_Tvar more || is_Tunivar more) in - let row = copy_row copy_rec fixed' row keep more' in + let row = + copy_row (copy_rec ~may_share:true) fixed' row keep more' in Tvariant row | Tpoly (t1, tl) -> - let tl = List.map repr tl in - let tl' = List.map (fun t -> newty t.desc) tl in + let tl' = List.map (fun t -> newty (get_desc t)) tl in let bound = tl @ bound in let visited = - List.map2 (fun ty t -> ty,(t,bound)) tl tl' @ visited in - Tpoly (copy_sep cleanup_scope fixed free bound visited t1, tl') - | _ -> copy_type_desc copy_rec ty.desc - end; + List.map2 (fun ty t -> get_id ty, (t, bound)) tl tl' @ visited in + let body = + copy_sep ~cleanup_scope ~fixed ~free ~bound ~may_share:true + visited t1 in + Tpoly (body, tl') + | Tfield (p, k, ty1, ty2) -> + (* the kind is kept shared, see Btype.copy_type_desc *) + Tfield (p, field_kind_internal_repr k, copy_rec ~may_share:true ty1, + copy_rec ~may_share:false ty2) + | _ -> copy_type_desc (copy_rec ~may_share:true) desc + in + Transient_expr.set_stub_desc t desc'; t end let instance_poly' cleanup_scope ~keep_names fixed univars sch = - let univars = List.map repr univars in + (* In order to compute univars below, [sch] should not contain [Tsubst] *) let copy_var ty = - match ty.desc with + match get_desc ty with Tunivar name -> if keep_names then newty (Tvar name) else newvar () | _ -> assert false in let vars = List.map copy_var univars in - let pairs = List.map2 (fun u v -> u, (v, [])) univars vars in + let pairs = List.map2 (fun u v -> get_id u, (v, [])) univars vars in delayed_copy := []; - let ty = copy_sep cleanup_scope fixed (compute_univars sch) [] pairs sch in + let ty = + copy_sep ~cleanup_scope ~fixed ~free:(compute_univars sch) ~bound:[] + ~may_share:true pairs sch in List.iter Lazy.force !delayed_copy; delayed_copy := []; vars, ty @@ -1529,14 +1463,15 @@ let instance_poly ?(keep_names=false) fixed univars sch = let instance_label fixed lbl = For_copy.with_scope (fun scope -> - let ty_res = copy scope lbl.lbl_res in let vars, ty_arg = - match repr lbl.lbl_arg with - {desc = Tpoly (ty, tl)} -> + match get_desc lbl.lbl_arg with + Tpoly (ty, tl) -> instance_poly' scope ~keep_names:false fixed tl ty | _ -> [], copy scope lbl.lbl_arg in + (* call [copy] after [instance_poly] to avoid introducing [Tsubst] *) + let ty_res = copy scope lbl.lbl_res in (vars, ty_arg, ty_res) ) @@ -1549,7 +1484,7 @@ let prim_mode mvar = function | None -> assert false let rec instance_prim_locals locals mvar macc finalret ty = - match locals, (repr ty).desc with + match locals, get_desc ty with | l :: locals, Tarrow ((lbl,_,mret),arg,ret,commu) -> let marg = prim_mode (Some mvar) l in let macc = Alloc_mode.join [marg; mret; macc] in @@ -1559,7 +1494,7 @@ let rec instance_prim_locals locals mvar macc finalret ty = | _ :: _ -> macc (* curried arrow *) in let ret = instance_prim_locals locals mvar macc finalret ret in - newty2 ty.level (Tarrow ((lbl,marg,mret),arg,ret, commu)) + newty2 ~level:(get_level ty) (Tarrow ((lbl,marg,mret),arg,ret, commu)) | _ :: _, _ -> assert false | [], _ -> ty @@ -1578,33 +1513,42 @@ let instance_prim_mode (desc : Primitive.description) ty = (**** Instantiation with parameter substitution ****) -let unify' = (* Forward declaration *) - ref (fun _env _ty1 _ty2 -> raise (Unify [])) +(* NB: since this is [unify_var], it raises [Unify], not [Unify_trace] *) +let unify_var' = (* Forward declaration *) + ref (fun _env _ty1 _ty2 -> assert false) -let subst env level priv abbrev ty params args body = - if List.length params <> List.length args then raise (Unify []); +let subst env level priv abbrev oty params args body = + if List.length params <> List.length args then raise Cannot_subst; let old_level = !current_level in current_level := level; + let body0 = newvar () in (* Stub *) + let undo_abbrev = + match oty with + | None -> fun () -> () (* No abbreviation added *) + | Some ty -> + match get_desc ty with + Tconstr (path, tl, _) -> + let abbrev = proper_abbrevs path tl abbrev in + memorize_abbrev abbrev priv path ty body0; + fun () -> forget_abbrev abbrev path + | _ -> assert false + in + abbreviations := abbrev; + let (params', body') = instance_parameterized_type params body in + abbreviations := ref Mnil; + let old_umode = !umode in + umode := Subst; try - let body0 = newvar () in (* Stub *) - begin match ty with - None -> () - | Some ({desc = Tconstr (path, tl, _)} as ty) -> - let abbrev = proper_abbrevs path tl abbrev in - memorize_abbrev abbrev priv path ty body0 - | _ -> - assert false - end; - abbreviations := abbrev; - let (params', body') = instance_parameterized_type params body in - abbreviations := ref Mnil; - !unify' env body0 body'; - List.iter2 (!unify' env) params' args; + !unify_var' env body0 body'; + List.iter2 (!unify_var' env) params' args; current_level := old_level; + umode := old_umode; body' - with Unify _ as exn -> + with Unify _ -> current_level := old_level; - raise exn + umode := old_umode; + undo_abbrev (); + raise Cannot_subst (* Only the shape of the type matters, not whether it is generic or @@ -1616,7 +1560,7 @@ let apply env params body args = try subst env generic_level Public (ref Mnil) None params args body with - Unify _ -> raise Cannot_apply + Cannot_subst -> raise Cannot_apply let () = Subst.ctype_apply_env_empty := apply Env.empty @@ -1660,8 +1604,10 @@ let check_abbrev_env env = *) let expand_abbrev_gen kind find_type_expansion env ty = check_abbrev_env env; - match ty with - {desc = Tconstr (path, args, abbrev); level = level; scope} -> + match get_desc ty with + Tconstr (path, args, abbrev) -> + let level = get_level ty in + let scope = get_scope ty in let lookup_abbrev = proper_abbrevs path args abbrev in begin match find_expans kind path !lookup_abbrev with Some ty' -> @@ -1670,7 +1616,7 @@ let expand_abbrev_gen kind find_type_expansion env ty = if level <> generic_level then begin try update_level env level ty' - with Unify _ -> + with Escape _ -> (* XXX This should not happen. However, levels are not correctly restored after a typing error *) @@ -1678,14 +1624,12 @@ let expand_abbrev_gen kind find_type_expansion env ty = end; begin try update_scope scope ty'; - with Unify _ -> + with Escape _ -> (* XXX This should not happen. However, levels are not correctly restored after a typing error *) () end; - let ty' = repr ty' in - (* assert (ty != ty'); *) (* PR#7324 *) ty' | None -> match find_type_expansion path env with @@ -1693,19 +1637,21 @@ let expand_abbrev_gen kind find_type_expansion env ty = (* another way to expand is to normalize the path itself *) let path' = Env.normalize_type_path None env path in if Path.same path path' then raise Cannot_expand - else newty2 level (Tconstr (path', args, abbrev)) + else newty2 ~level (Tconstr (path', args, abbrev)) | (params, body, lv) -> (* prerr_endline ("add a "^string_of_kind kind^" expansion for "^Path.name path);*) - let ty' = subst env level kind abbrev (Some ty) params args body in + let ty' = + try + subst env level kind abbrev (Some ty) params args body + with Cannot_subst -> raise_escape_exn Constraint + in (* For gadts, remember type as non exportable *) (* The ambiguous level registered for ty' should be the highest *) - if !trace_gadt_instances then begin - let scope = max lv ty.scope in - if level < scope then raise (Trace.scope_escape ty); - set_scope ty scope; - set_scope ty' scope - end; + (* if !trace_gadt_instances then begin *) + let scope = Misc.Stdlib.Int.max lv (get_scope ty) in + update_scope scope ty; + update_scope scope ty'; ty' end | _ -> @@ -1717,47 +1663,58 @@ let expand_abbrev env ty = (* Expand once the head of a type *) let expand_head_once env ty = - try expand_abbrev env (repr ty) with Cannot_expand -> assert false + try + expand_abbrev env ty + with Cannot_expand | Escape _ -> assert false (* Check whether a type can be expanded *) let safe_abbrev env ty = let snap = Btype.snapshot () in - try ignore (expand_abbrev env ty); true - with Cannot_expand | Unify _ -> - Btype.backtrack snap; - false + try ignore (expand_abbrev env ty); true with + Cannot_expand -> + Btype.backtrack snap; + false + | Escape _ -> + Btype.backtrack snap; + cleanup_abbrev (); + false (* Expand the head of a type once. Raise Cannot_expand if the type cannot be expanded. - May raise Unify, if a recursion was hidden in the type. *) + May raise Escape, if a recursion was hidden in the type. *) let try_expand_once env ty = - let ty = repr ty in - match ty.desc with - Tconstr _ -> repr (expand_abbrev env ty) + match get_desc ty with + Tconstr _ -> expand_abbrev env ty | _ -> raise Cannot_expand (* This one only raises Cannot_expand *) let try_expand_safe env ty = let snap = Btype.snapshot () in try try_expand_once env ty - with Unify _ -> - Btype.backtrack snap; raise Cannot_expand + with Escape _ -> + Btype.backtrack snap; cleanup_abbrev (); raise Cannot_expand (* Fully expand the head of a type. *) -let rec try_expand_head try_once env ty = +let rec try_expand_head + (try_once : Env.t -> type_expr -> type_expr) env ty = let ty' = try_once env ty in try try_expand_head try_once env ty' with Cannot_expand -> ty' -(* Unsafe full expansion, may raise Unify. *) +(* Unsafe full expansion, may raise [Unify [Escape _]]. *) let expand_head_unif env ty = - try try_expand_head try_expand_once env ty with Cannot_expand -> repr ty + try + try_expand_head try_expand_once env ty + with + | Cannot_expand -> ty + | Escape e -> raise_for Unify (Escape e) (* Safe version of expand_head, never fails *) let expand_head env ty = - try try_expand_head try_expand_safe env ty with Cannot_expand -> repr ty + try try_expand_head try_expand_safe env ty + with Cannot_expand -> ty -let _ = forward_try_expand_once := try_expand_safe +let _ = forward_try_expand_safe := try_expand_safe (* Expand until we find a non-abstract type declaration, @@ -1765,18 +1722,33 @@ let _ = forward_try_expand_once := try_expand_safe called on recursive types *) +type typedecl_extraction_result = + | Typedecl of Path.t * Path.t * type_declaration + | Has_no_typedecl + | May_have_typedecl + let rec extract_concrete_typedecl env ty = - let ty = repr ty in - match ty.desc with + match get_desc ty with Tconstr (p, _, _) -> - let decl = Env.find_type p env in - if decl.type_kind <> Type_abstract then (p, p, decl) else - let ty = - try try_expand_safe env ty with Cannot_expand -> raise Not_found - in - let (_, p', decl) = extract_concrete_typedecl env ty in - (p, p', decl) - | _ -> raise Not_found + begin match Env.find_type p env with + | exception Not_found -> May_have_typedecl + | decl -> + if decl.type_kind <> Type_abstract then Typedecl(p, p, decl) + else begin + match try_expand_safe env ty with + | exception Cannot_expand -> May_have_typedecl + | ty -> + match extract_concrete_typedecl env ty with + | Typedecl(_, p', decl) -> Typedecl(p, p', decl) + | Has_no_typedecl -> Has_no_typedecl + | May_have_typedecl -> May_have_typedecl + end + end + | Tpoly(ty, _) -> extract_concrete_typedecl env ty + | Tarrow _ | Ttuple _ | Tobject _ | Tfield _ | Tnil + | Tvariant _ | Tpackage _ -> Has_no_typedecl + | Tvar _ | Tunivar _ -> May_have_typedecl + | Tlink _ | Tsubst _ -> assert false (* Implementing function [expand_head_opt], the compiler's own version of [expand_head] used for type-based optimisations. @@ -1785,52 +1757,55 @@ let rec extract_concrete_typedecl env ty = normally hidden to the type-checker out of the implementation module of the private abbreviation. *) -let expand_abbrev_opt = - expand_abbrev_gen Private Env.find_type_expansion_opt +let expand_abbrev_opt env ty = + expand_abbrev_gen Private Env.find_type_expansion_opt env ty + +let safe_abbrev_opt env ty = + let snap = Btype.snapshot () in + try ignore (expand_abbrev_opt env ty); true + with Cannot_expand | Escape _ -> + Btype.backtrack snap; + false let try_expand_once_opt env ty = - let ty = repr ty in - match ty.desc with - Tconstr _ -> repr (expand_abbrev_opt env ty) + match get_desc ty with + Tconstr _ -> expand_abbrev_opt env ty | _ -> raise Cannot_expand -let rec try_expand_head_opt env ty = - let ty' = try_expand_once_opt env ty in - begin try - try_expand_head_opt env ty' - with Cannot_expand -> - ty' - end - -let expand_head_opt env ty = +let try_expand_safe_opt env ty = let snap = Btype.snapshot () in - try try_expand_head_opt env ty - with Cannot_expand | Unify _ -> (* expand_head shall never fail *) - Btype.backtrack snap; - repr ty + try try_expand_once_opt env ty + with Escape _ -> + Btype.backtrack snap; raise Cannot_expand -(* Make sure that the type parameters of the type constructor [ty] - respect the type constraints *) -let enforce_constraints env ty = - match ty with - {desc = Tconstr (path, args, _abbrev); level = level} -> - begin try - let decl = Env.find_type path env in - ignore - (subst env level Public (ref Mnil) None decl.type_params args - (newvar2 level)) - with Not_found -> () - end - | _ -> - assert false +let expand_head_opt env ty = + try try_expand_head try_expand_safe_opt env ty with Cannot_expand -> ty (* Recursively expand the head of a type. - Also expand #-types. *) -let full_expand env ty = - let ty = repr (expand_head env ty) in - match ty.desc with - Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar (repr v) -> - newty2 ty.level (Tobject (fi, ref None)) + Also expand #-types. + + Error printing relies on [full_expand] returning exactly its input (i.e., a + physically equal type) when nothing changes. *) +let full_expand ~may_forget_scope env ty = + let ty = + if may_forget_scope then + try expand_head_unif env ty with Unify_trace _ -> + (* #10277: forget scopes when printing trace *) + begin_def (); + init_def (get_level ty); + let ty = + (* The same as [expand_head], except in the failing case we return the + *original* type, not [correct_levels ty].*) + try try_expand_head try_expand_safe env (correct_levels ty) with + | Cannot_expand -> ty + in + end_def (); + ty + else expand_head env ty + in + match get_desc ty with + Tobject (fi, {contents = Some (_, v::_)}) when is_Tvar v -> + newty2 ~level:(get_level ty) (Tobject (fi, ref None)) | _ -> ty @@ -1842,7 +1817,7 @@ let full_expand env ty = let generic_abbrev env path = try let (_, body, _) = Env.find_type_expansion path env in - (repr body).level = generic_level + get_level body = generic_level with Not_found -> false @@ -1853,7 +1828,7 @@ let generic_private_abbrev env path = {type_kind = Type_abstract; type_private = Private; type_manifest = Some body} -> - (repr body).level = generic_level + get_level body = generic_level | _ -> false with Not_found -> false @@ -1871,12 +1846,9 @@ let is_contractive env p = exception Occur -let rec occur_rec env allow_recursive visited ty0 = function - | {desc=Tlink ty} -> - occur_rec env allow_recursive visited ty0 ty - | ty -> - if ty == ty0 then raise Occur; - match ty.desc with +let rec occur_rec env allow_recursive visited ty0 ty = + if eq_type ty ty0 then raise Occur; + match get_desc ty with Tconstr(p, _tl, _abbrev) -> if allow_recursive && is_contractive env p then () else begin try @@ -1904,24 +1876,27 @@ let type_changed = ref false (* trace possible changes to the studied type *) let merge r b = if b then r := true let occur env ty0 ty = - let allow_recursive = - !Clflags.recursive_types || !umode = Pattern && !allow_recursive_equation in + let allow_recursive = allow_recursive_equations () in let old = !type_changed in try while type_changed := false; - occur_rec env allow_recursive TypeSet.empty ty0 ty; + if not (eq_type ty0 ty) then + occur_rec env allow_recursive TypeSet.empty ty0 ty; !type_changed do () (* prerr_endline "changed" *) done; merge type_changed old with exn -> merge type_changed old; - match exn with - | Occur -> raise (Trace.rec_occur ty0 ty) - | _ -> raise exn + raise exn + +let occur_for tr_exn env t1 t2 = + try + occur env t1 t2 + with Occur -> raise_for tr_exn (Rec_occur(t1, t2)) let occur_in env ty0 t = - try occur env ty0 t; false with Unify _ -> true + try occur env ty0 t; false with Occur -> true (* Check that a local constraint is well-founded *) (* PR#6405: not needed since we allow recursion and work on normalized types *) @@ -1930,17 +1905,16 @@ let occur_in env ty0 t = let rec local_non_recursive_abbrev ~allow_rec strict visited env p ty = (*Format.eprintf "@[Check %s =@ %a@]@." (Path.name p) !Btype.print_raw ty;*) - let ty = repr ty in - if not (List.memq ty visited) then begin - match ty.desc with + if not (List.memq (get_id ty) visited) then begin + match get_desc ty with Tconstr(p', args, _abbrev) -> if Path.same p p' then raise Occur; if allow_rec && not strict && is_contractive env p' then () else - let visited = ty :: visited in + let visited = get_id ty :: visited in begin try (* try expanding, since [p] could be hidden *) local_non_recursive_abbrev ~allow_rec strict visited env p - (try_expand_head try_expand_once_opt env ty) + (try_expand_head try_expand_safe_opt env ty) with Cannot_expand -> let params = try (Env.find_type p' env).type_params @@ -1948,7 +1922,7 @@ let rec local_non_recursive_abbrev ~allow_rec strict visited env p ty = in List.iter2 (fun tv ty -> - let strict = strict || not (is_Tvar (repr tv)) in + let strict = strict || not (is_Tvar tv) in local_non_recursive_abbrev ~allow_rec strict visited env p ty) params args end @@ -1956,14 +1930,13 @@ let rec local_non_recursive_abbrev ~allow_rec strict visited env p ty = () | _ -> if strict || not allow_rec then (* PR#7374 *) - let visited = ty :: visited in + let visited = get_id ty :: visited in iter_type_expr (local_non_recursive_abbrev ~allow_rec true visited env p) ty end let local_non_recursive_abbrev env p ty = - let allow_rec = - !Clflags.recursive_types || !umode = Pattern && !allow_recursive_equation in + let allow_rec = allow_recursive_equations () in try (* PR#7397: need to check trace_gadt_instances *) wrap_trace_gadt_instances env (local_non_recursive_abbrev ~allow_rec false [] env p) ty; @@ -1977,51 +1950,58 @@ let local_non_recursive_abbrev env p ty = (* Since we cannot duplicate universal variables, unification must be done at meta-level, using bindings in univar_pairs *) +(* TODO: use find_opt *) let rec unify_univar t1 t2 = function (cl1, cl2) :: rem -> let find_univ t cl = try - let (_, r) = List.find (fun (t',_) -> t == repr t') cl in + let (_, r) = List.find (fun (t',_) -> eq_type t t') cl in Some r with Not_found -> None in begin match find_univ t1 cl1, find_univ t2 cl2 with - Some {contents=Some t'2}, Some _ when t2 == repr t'2 -> + Some {contents=Some t'2}, Some _ when eq_type t2 t'2 -> () | Some({contents=None} as r1), Some({contents=None} as r2) -> set_univar r1 t2; set_univar r2 t1 | None, None -> unify_univar t1 t2 rem | _ -> - raise (Unify []) + raise Cannot_unify_universal_variables end - | [] -> raise (Unify []) + | [] -> raise Cannot_unify_universal_variables + +(* The same as [unify_univar], but raises the appropriate exception instead of + [Cannot_unify_universal_variables] *) +let unify_univar_for tr_exn t1 t2 univar_pairs = + try unify_univar t1 t2 univar_pairs + with Cannot_unify_universal_variables -> raise_unexplained_for tr_exn (* Test the occurrence of free univars in a type *) -(* that's way too expensive. Must do some kind of caching *) -let occur_univar env ty = +(* That's way too expensive. Must do some kind of caching *) +(* If [inj_only=true], only check injective positions *) +let occur_univar ?(inj_only=false) env ty = let visited = ref TypeMap.empty in let rec occur_rec bound ty = - let ty = repr ty in - if ty.level >= lowest_level && + if not_marked_node ty then if TypeSet.is_empty bound then - (ty.level <- pivot_level - ty.level; true) + (flip_mark_node ty; occur_desc bound ty) else try let bound' = TypeMap.find ty !visited in - if TypeSet.exists (fun x -> not (TypeSet.mem x bound)) bound' then - (visited := TypeMap.add ty (TypeSet.inter bound bound') !visited; - true) - else false + if not (TypeSet.subset bound' bound) then begin + visited := TypeMap.add ty (TypeSet.inter bound bound') !visited; + occur_desc bound ty + end with Not_found -> visited := TypeMap.add ty bound !visited; - true - then - match ty.desc with + occur_desc bound ty + and occur_desc bound ty = + match get_desc ty with Tunivar _ -> if not (TypeSet.mem ty bound) then - raise Trace.(Unify [escape (Univ ty)]) + raise_escape_exn (Univ ty) | Tpoly (ty, tyl) -> - let bound = List.fold_right TypeSet.add (List.map repr tyl) bound in + let bound = List.fold_right TypeSet.add tyl bound in occur_rec bound ty | Tconstr (_, [], _) -> () | Tconstr (p, tl, _) -> @@ -2036,10 +2016,11 @@ let occur_univar env ty = in this position. Physical expansion, as done in `occur`, would be costly here, since we need to check inside object and variant types too. *) - if not Variance.(eq v null) then occur_rec bound t) + if Variance.(if inj_only then mem Inj v else not (eq v null)) + then occur_rec bound t) tl td.type_variance with Not_found -> - List.iter (occur_rec bound) tl + if not inj_only then List.iter (occur_rec bound) tl end | _ -> iter_type_expr (occur_rec bound) ty in @@ -2048,15 +2029,25 @@ let occur_univar env ty = ) ~always:(fun () -> unmark_type ty) +let has_free_univars env ty = + try occur_univar ~inj_only:false env ty; false with Escape _ -> true +let has_injective_univars env ty = + try occur_univar ~inj_only:true env ty; false with Escape _ -> true + +let occur_univar_for tr_exn env ty = + try + occur_univar env ty + with Escape e -> raise_for tr_exn (Escape e) + (* Grouping univars by families according to their binders *) let add_univars = - List.fold_left (fun s (t,_) -> TypeSet.add (repr t) s) + List.fold_left (fun s (t,_) -> TypeSet.add t s) let get_univar_family univar_pairs univars = if univars = [] then TypeSet.empty else let insert s = function cl1, (_::_ as cl2) -> - if List.exists (fun (t1,_) -> TypeSet.mem (repr t1) s) cl1 then + if List.exists (fun (t1,_) -> TypeSet.mem t1 s) cl1 then add_univars s cl2 else s | _ -> s @@ -2069,15 +2060,13 @@ let univars_escape env univar_pairs vl ty = let family = get_univar_family univar_pairs vl in let visited = ref TypeSet.empty in let rec occur t = - let t = repr t in if TypeSet.mem t !visited then () else begin visited := TypeSet.add t !visited; - match t.desc with + match get_desc t with Tpoly (t, tl) -> - if List.exists (fun t -> TypeSet.mem (repr t) family) tl then () + if List.exists (fun t -> TypeSet.mem t family) tl then () else occur t - | Tunivar _ -> - if TypeSet.mem t family then raise Trace.(Unify [escape(Univ t)]) + | Tunivar _ -> if TypeSet.mem t family then raise_escape_exn (Univ t) | Tconstr (_, [], _) -> () | Tconstr (p, tl, _) -> begin try @@ -2102,7 +2091,6 @@ let enter_poly env univar_pairs t1 tl1 t2 tl2 f = List.fold_left (fun s (cl,_) -> add_univars s cl) TypeSet.empty old_univars in - let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in if List.exists (fun t -> TypeSet.mem t known_univars) tl1 then univars_escape env old_univars tl1 (newty(Tpoly(t2,tl2))); if List.exists (fun t -> TypeSet.mem t known_univars) tl2 then @@ -2113,18 +2101,21 @@ let enter_poly env univar_pairs t1 tl1 t2 tl2 f = Misc.try_finally (fun () -> f t1 t2) ~always:(fun () -> univar_pairs := old_univars) +let enter_poly_for tr_exn env univar_pairs t1 tl1 t2 tl2 f = + try + enter_poly env univar_pairs t1 tl1 t2 tl2 f + with Escape e -> raise_for tr_exn (Escape e) + let univar_pairs = ref [] (**** Instantiate a generic type into a poly type ***) let polyfy env ty vars = let subst_univar scope ty = - let ty = repr ty in - match ty.desc with - | Tvar name when ty.level = generic_level -> - For_copy.save_desc scope ty ty.desc; + match get_desc ty with + | Tvar name when get_level ty = generic_level -> let t = newty (Tunivar name) in - ty.desc <- Tsubst t; + For_copy.redirect_desc scope ty (Tsubst (t, None)); Some t | _ -> None in @@ -2134,7 +2125,7 @@ let polyfy env ty vars = For_copy.with_scope (fun scope -> let vars' = List.filter_map (subst_univar scope) vars in let ty = copy scope ty in - let ty = newty2 ty.level (Tpoly(repr ty, vars')) in + let ty = newty2 ~level:(get_level ty) (Tpoly(ty, vars')) in let complete = List.length vars = List.length vars' in ty, complete ) @@ -2153,28 +2144,59 @@ let reify_univars env ty = let rec has_cached_expansion p abbrev = match abbrev with - Mnil -> false - | Mcons(_, p', _, _, rem) -> Path.same p p' || has_cached_expansion p rem - | Mlink rem -> has_cached_expansion p !rem + Mnil -> false + | Mcons(_, p', _, _, rem) -> Path.same p p' || has_cached_expansion p rem + | Mlink rem -> has_cached_expansion p !rem (**** Transform error trace ****) (* +++ Move it to some other place ? *) +(* That's hard to do because it relies on the expansion machinery in Ctype, + but still might be nice. *) + +let expand_type env ty = + { ty = ty; + expanded = full_expand ~may_forget_scope:true env ty } + +let expand_any_trace map env trace = + map (expand_type env) trace let expand_trace env trace = - let expand_desc x = match x.Trace.expanded with - | None -> Trace.{ t = repr x.t; expanded= Some(full_expand env x.t) } - | Some _ -> x in - Unification_trace.map expand_desc trace + expand_any_trace Errortrace.map env trace + +let expand_subtype_trace env trace = + expand_any_trace Subtype.map env trace + +let expand_to_unification_error env trace = + unification_error ~trace:(expand_trace env trace) + +let expand_to_equality_error env trace subst = + equality_error ~trace:(expand_trace env trace) ~subst + +let expand_to_moregen_error env trace = + moregen_error ~trace:(expand_trace env trace) + +(* [expand_trace] and the [expand_to_*_error] functions take care of most of the + expansion in this file, but we occasionally need to build [Errortrace.error]s + in other ways/elsewhere, so we expose some machinery for doing so +*) + +(* Equivalent to [expand_trace env [Diff {got; expected}]] for a single + element *) +let expanded_diff env ~got ~expected = + Diff (map_diff (expand_type env) {got; expected}) + +(* Diff while transforming a [type_expr] into an [expanded_type] without + expanding *) +let unexpanded_diff ~got ~expected = + Diff (map_diff trivial_expansion {got; expected}) (**** Unification ****) (* Return whether [t0] occurs in [ty]. Objects are also traversed. *) let deep_occur t0 ty = let rec occur_rec ty = - let ty = repr ty in - if ty.level >= t0.level then begin - if ty == t0 then raise Occur; - ty.level <- pivot_level - ty.level; + if get_level ty >= get_level t0 && try_mark_node ty then begin + if eq_type ty t0 then raise Occur; iter_type_expr occur_rec ty end in @@ -2183,30 +2205,6 @@ let deep_occur t0 ty = with Occur -> unmark_type ty; true -(* - 1. When unifying two non-abbreviated types, one type is made a link - to the other. When unifying an abbreviated type with a - non-abbreviated type, the non-abbreviated type is made a link to - the other one. When unifying to abbreviated types, these two - types are kept distincts, but they are made to (temporally) - expand to the same type. - 2. Abbreviations with at least one parameter are systematically - expanded. The overhead does not seem too high, and that way - abbreviations where some parameters does not appear in the - expansion, such as ['a t = int], are correctly handled. In - particular, for this example, unifying ['a t] with ['b t] keeps - ['a] and ['b] distincts. (Is it really important ?) - 3. Unifying an abbreviation ['a t = 'a] with ['a] should not yield - ['a t as 'a]. Indeed, the type variable would otherwise be lost. - This problem occurs for abbreviations expanding to a type - variable, but also to many other constrained abbreviations (for - instance, [(< x : 'a > -> unit) t = ]). The solution is - that, if an abbreviation is unified with some subpart of its - parameters, then the parameter actually does not get - abbreviated. It would be possible to check whether some - information is indeed lost, but it probably does not worth it. -*) - let gadt_equations_level = ref None let get_gadt_equations_level () = @@ -2222,47 +2220,46 @@ let reify env t = let fresh_constr_scope = get_gadt_equations_level () in let create_fresh_constr lev name = let name = match name with Some s -> "$'"^s | _ -> "$" in - let path = - Path.Pident - (Ident.create_scoped ~scope:fresh_constr_scope - (get_new_abstract_name name)) - in - let decl = new_declaration fresh_constr_scope None in - let new_env = Env.add_local_type path decl !env in - let t = newty2 lev (Tconstr (path,[],ref Mnil)) in + let decl = new_local_type () in + let (id, new_env) = + Env.enter_type (get_new_abstract_name name) decl !env + ~scope:fresh_constr_scope in + let path = Path.Pident id in + let t = newty2 ~level:lev (Tconstr (path,[],ref Mnil)) in env := new_env; path, t in let visited = ref TypeSet.empty in let rec iterator ty = - let ty = repr ty in if TypeSet.mem ty !visited then () else begin visited := TypeSet.add ty !visited; - match ty.desc with + match get_desc ty with Tvar o -> - let path, t = create_fresh_constr ty.level o in + let level = get_level ty in + let path, t = create_fresh_constr level o in link_type ty t; - if ty.level < fresh_constr_scope then - raise Trace.(Unify [escape (Constructor path)]) + if level < fresh_constr_scope then + raise_for Unify (Escape (escape (Constructor path))) | Tvariant r -> - let r = row_repr r in if not (static_row r) then begin if is_fixed r then iterator (row_more r) else - let m = r.row_more in - match m.desc with + let m = row_more r in + match get_desc m with Tvar o -> - let path, t = create_fresh_constr m.level o in + let level = get_level m in + let path, t = create_fresh_constr level o in let row = - let row_fixed = Some (Reified path) in - {r with row_fields=[]; row_fixed; row_more = t} in - link_type m (newty2 m.level (Tvariant row)); - if m.level < fresh_constr_scope then - raise Trace.(Unify [escape (Constructor path)]) + let fixed = Some (Reified path) in + create_row ~fields:[] ~more:t ~fixed + ~name:(row_name r) ~closed:(row_closed r) in + link_type m (newty2 ~level (Tvariant row)); + if level < fresh_constr_scope then + raise_for Unify (Escape (escape (Constructor path))) | _ -> assert false end; iter_row iterator r | Tconstr (p, _, _) when is_object_type p -> - iter_type_expr iterator (full_expand !env ty) + iter_type_expr iterator (full_expand ~may_forget_scope:false !env ty) | _ -> iter_type_expr iterator ty end @@ -2301,16 +2298,20 @@ let compatible_paths p1 p2 = (* Check for datatypes carefully; see PR#6348 *) let rec expands_to_datatype env ty = - let ty = repr ty in - match ty.desc with + match get_desc ty with Tconstr (p, _, _) -> begin try is_datatype (Env.find_type p env) || - expands_to_datatype env (try_expand_once env ty) + expands_to_datatype env (try_expand_safe env ty) with Not_found | Cannot_expand -> false end | _ -> false +(* [mcomp] tests if two types are "compatible" -- i.e., if they could ever + unify. (This is distinct from [eqtype], which checks if two types *are* + exactly the same.) This is used to decide whether GADT cases are + unreachable. It is broadly part of unification. *) + (* mcomp type_pairs subst env t1 t2 does not raise an exception if it is possible that t1 and t2 are actually equal, assuming the types in type_pairs are equal and @@ -2320,11 +2321,8 @@ let rec expands_to_datatype env ty = *) let rec mcomp type_pairs env t1 t2 = - if t1 == t2 then () else - let t1 = repr t1 in - let t2 = repr t2 in - if t1 == t2 then () else - match (t1.desc, t2.desc) with + if eq_type t1 t2 then () else + match (get_desc t1, get_desc t2) with | (Tvar _, _) | (_, Tvar _) -> () @@ -2334,11 +2332,10 @@ let rec mcomp type_pairs env t1 t2 = let t1' = expand_head_opt env t1 in let t2' = expand_head_opt env t2 in (* Expansion may have changed the representative of the types... *) - let t1' = repr t1' and t2' = repr t2' in - if t1' == t2' then () else + if eq_type t1' t2' then () else if not (TypePairs.mem type_pairs (t1', t2')) then begin TypePairs.add type_pairs (t1', t2'); - match (t1'.desc, t2'.desc) with + match (get_desc t1', get_desc t2') with | (Tvar _, _) | (_, Tvar _) -> () @@ -2350,10 +2347,15 @@ let rec mcomp type_pairs env t1 t2 = mcomp_list type_pairs env tl1 tl2 | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) -> mcomp_type_decl type_pairs env p1 p2 tl1 tl2 + | (Tconstr (_, [], _), _) when has_injective_univars env t2' -> + raise_unexplained_for Unify + | (_, Tconstr (_, [], _)) when has_injective_univars env t1' -> + raise_unexplained_for Unify | (Tconstr (p, _, _), _) | (_, Tconstr (p, _, _)) -> begin try let decl = Env.find_type p env in - if non_aliasable p decl || is_datatype decl then raise (Unify []) + if non_aliasable p decl || is_datatype decl then + raise Incompatible with Not_found -> () end (* @@ -2372,17 +2374,20 @@ let rec mcomp type_pairs env t1 t2 = | (Tpoly (t1, []), Tpoly (t2, [])) -> mcomp type_pairs env t1 t2 | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> - enter_poly env univar_pairs t1 tl1 t2 tl2 - (mcomp type_pairs env) + (try + enter_poly env univar_pairs + t1 tl1 t2 tl2 (mcomp type_pairs env) + with Escape _ -> raise Incompatible) | (Tunivar _, Tunivar _) -> - unify_univar t1' t2' !univar_pairs + (try unify_univar t1' t2' !univar_pairs + with Cannot_unify_universal_variables -> raise Incompatible) | (_, _) -> - raise (Unify []) + raise Incompatible end and mcomp_list type_pairs env tl1 tl2 = if List.length tl1 <> List.length tl2 then - raise (Unify []); + raise Incompatible; List.iter2 (mcomp type_pairs env) tl1 tl2 and mcomp_fields type_pairs env ty1 ty2 = @@ -2391,10 +2396,11 @@ and mcomp_fields type_pairs env ty1 ty2 = let (fields1, rest1) = flatten_fields ty1 in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in let has_present = - List.exists (fun (_, k, _) -> field_kind_repr k = Fpresent) in + List.exists (fun (_, k, _) -> field_kind_repr k = Fpublic) in mcomp type_pairs env rest1 rest2; - if has_present miss1 && (object_row ty2).desc = Tnil - || has_present miss2 && (object_row ty1).desc = Tnil then raise (Unify []); + if has_present miss1 && get_desc (object_row ty2) = Tnil + || has_present miss2 && get_desc (object_row ty1) = Tnil + then raise Incompatible; List.iter (function (_n, k1, t1, k2, t2) -> mcomp_kind k1 k2; @@ -2405,33 +2411,32 @@ and mcomp_kind k1 k2 = let k1 = field_kind_repr k1 in let k2 = field_kind_repr k2 in match k1, k2 with - (Fpresent, Fabsent) - | (Fabsent, Fpresent) -> raise (Unify []) - | _ -> () + (Fpublic, Fabsent) + | (Fabsent, Fpublic) -> raise Incompatible + | _ -> () and mcomp_row type_pairs env row1 row2 = - let row1 = row_repr row1 and row2 = row_repr row2 in - let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in + let r1, r2, pairs = merge_row_fields (row_fields row1) (row_fields row2) in let cannot_erase (_,f) = match row_field_repr f with Rpresent _ -> true | Rabsent | Reither _ -> false in - if row1.row_closed && List.exists cannot_erase r2 - || row2.row_closed && List.exists cannot_erase r1 then raise (Unify []); + if row_closed row1 && List.exists cannot_erase r2 + || row_closed row2 && List.exists cannot_erase r1 then raise Incompatible; List.iter (fun (_,f1,f2) -> match row_field_repr f1, row_field_repr f2 with - | Rpresent None, (Rpresent (Some _) | Reither (_, _::_, _, _) | Rabsent) - | Rpresent (Some _), (Rpresent None | Reither (true, _, _, _) | Rabsent) - | (Reither (_, _::_, _, _) | Rabsent), Rpresent None - | (Reither (true, _, _, _) | Rabsent), Rpresent (Some _) -> - raise (Unify []) + | Rpresent None, (Rpresent (Some _) | Reither (_, _::_, _) | Rabsent) + | Rpresent (Some _), (Rpresent None | Reither (true, _, _) | Rabsent) + | (Reither (_, _::_, _) | Rabsent), Rpresent None + | (Reither (true, _, _) | Rabsent), Rpresent (Some _) -> + raise Incompatible | Rpresent(Some t1), Rpresent(Some t2) -> mcomp type_pairs env t1 t2 - | Rpresent(Some t1), Reither(false, tl2, _, _) -> + | Rpresent(Some t1), Reither(false, tl2, _) -> List.iter (mcomp type_pairs env t1) tl2 - | Reither(false, tl1, _, _), Rpresent(Some t2) -> + | Reither(false, tl1, _), Rpresent(Some t2) -> List.iter (mcomp type_pairs env t2) tl1 | _ -> ()) pairs @@ -2449,13 +2454,13 @@ and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 = (fun i (t1,t2) -> if i then mcomp type_pairs env t1 t2) inj (List.combine tl1 tl2) end else if non_aliasable p1 decl && non_aliasable p2 decl' then - raise (Unify []) + raise Incompatible else match decl.type_kind, decl'.type_kind with | Type_record (lst,r), Type_record (lst',r') when r = r' -> mcomp_list type_pairs env tl1 tl2; mcomp_record_description type_pairs env lst lst' - | Type_variant v1, Type_variant v2 -> + | Type_variant (v1,r), Type_variant (v2,r') when r = r' -> mcomp_list type_pairs env tl1 tl2; mcomp_variant_description type_pairs env v1 v2 | Type_open, Type_open -> @@ -2463,14 +2468,14 @@ and mcomp_type_decl type_pairs env p1 p2 tl1 tl2 = | Type_abstract, Type_abstract -> () | Type_abstract, _ when not (non_aliasable p1 decl)-> () | _, Type_abstract when not (non_aliasable p2 decl') -> () - | _ -> raise (Unify []) + | _ -> raise Incompatible with Not_found -> () and mcomp_type_option type_pairs env t t' = match t, t' with None, None -> () | Some t, Some t' -> mcomp type_pairs env t t' - | _ -> raise (Unify []) + | _ -> raise Incompatible and mcomp_variant_description type_pairs env xs ys = let rec iter = fun x y -> @@ -2478,19 +2483,32 @@ and mcomp_variant_description type_pairs env xs ys = | c1 :: xs, c2 :: ys -> mcomp_type_option type_pairs env c1.cd_res c2.cd_res; begin match c1.cd_args, c2.cd_args with - | Cstr_tuple l1, Cstr_tuple l2 -> mcomp_list type_pairs env l1 l2 + | Cstr_tuple l1, Cstr_tuple l2 -> mcomp_tuple_description type_pairs env l1 l2 | Cstr_record l1, Cstr_record l2 -> mcomp_record_description type_pairs env l1 l2 - | _ -> raise (Unify []) + | _ -> raise Incompatible end; if Ident.name c1.cd_id = Ident.name c2.cd_id then iter xs ys - else raise (Unify []) + else raise Incompatible | [],[] -> () - | _ -> raise (Unify []) + | _ -> raise Incompatible in iter xs ys +and mcomp_tuple_description type_pairs env = + let rec iter x y = + match x, y with + | (ty1, gf1) :: xs, (ty2, gf2) :: ys -> + mcomp type_pairs env ty1 ty2; + if gf1 = gf2 + then iter xs ys + else raise Incompatible + | [], [] -> () + | _ -> raise Incompatible + in + iter + and mcomp_record_description type_pairs env = let rec iter x y = match x, y with @@ -2500,24 +2518,29 @@ and mcomp_record_description type_pairs env = l1.ld_mutable = l2.ld_mutable && l1.ld_global = l2.ld_global then iter xs ys - else raise (Unify []) + else raise Incompatible | [], [] -> () - | _ -> raise (Unify []) + | _ -> raise Incompatible in iter let mcomp env t1 t2 = mcomp (TypePairs.create 4) env t1 t2 +let mcomp_for tr_exn env t1 t2 = + try + mcomp env t1 t2 + with Incompatible -> raise_unexplained_for tr_exn + (* Real unification *) let find_lowest_level ty = let lowest = ref generic_level in let rec find ty = - let ty = repr ty in - if ty.level >= lowest_level then begin - if ty.level < !lowest then lowest := ty.level; - ty.level <- pivot_level - ty.level; + if not_marked_node ty then begin + let level = get_level ty in + if level < !lowest then lowest := level; + flip_mark_node ty; iter_type_expr find ty end in find ty; unmark_type ty; !lowest @@ -2528,12 +2551,15 @@ let find_expansion_scope env path = let add_gadt_equation env source destination = (* Format.eprintf "@[add_gadt_equation %s %a@]@." (Path.name source) !Btype.print_raw destination; *) - if local_non_recursive_abbrev !env source destination then begin + if has_free_univars !env destination then + occur_univar ~inj_only:true !env destination + else if local_non_recursive_abbrev !env source destination then begin let destination = duplicate_type destination in let expansion_scope = - max (Path.scope source) (get_gadt_equations_level ()) + Int.max (Path.scope source) (get_gadt_equations_level ()) in - let decl = new_declaration expansion_scope (Some destination) in + let decl = + new_local_type ~manifest_and_scope:(destination, expansion_scope) () in env := Env.add_local_type source decl !env; cleanup_abbrev () end @@ -2541,7 +2567,7 @@ let add_gadt_equation env source destination = let unify_eq_set = TypePairs.create 11 let order_type_pair t1 t2 = - if t1.id <= t2.id then (t1, t2) else (t2, t1) + if get_id t1 <= get_id t2 then (t1, t2) else (t2, t1) let add_type_equality t1 t2 = TypePairs.add unify_eq_set (order_type_pair t1 t2) @@ -2551,7 +2577,7 @@ let eq_package_path env p1 p2 = Path.same (normalize_package_path env p1) (normalize_package_path env p2) let nondep_type' = ref (fun _ _ _ -> assert false) -let package_subtype = ref (fun _ _ _ _ _ _ _ -> assert false) +let package_subtype = ref (fun _ _ _ _ _ -> assert false) exception Nondep_cannot_erase of Ident.t @@ -2573,7 +2599,7 @@ let nondep_instance env level id ty = (* Find the type paths nl1 in the module type mty2, and add them to the list (nl2, tl2). raise Not_found if impossible *) -let complete_type_list ?(allow_absent=false) env nl1 lv2 mty2 nl2 tl2 = +let complete_type_list ?(allow_absent=false) env fl1 lv2 mty2 fl2 = (* This is morally WRONG: we're adding a (dummy) module without a scope in the environment. However no operation which cares about levels/scopes is going to happen while this module exists. @@ -2586,102 +2612,132 @@ let complete_type_list ?(allow_absent=false) env nl1 lv2 mty2 nl2 tl2 = environments though. *) let id2 = Ident.create_local "Pkg" in let env' = Env.add_module id2 Mp_present mty2 env in - let rec complete nl1 ntl2 = - match nl1, ntl2 with - [], _ -> ntl2 - | n :: nl, (n2, _ as nt2) :: ntl' when n >= n2 -> - nt2 :: complete (if n = n2 then nl else nl1) ntl' - | n :: nl, _ -> + let rec complete fl1 fl2 = + match fl1, fl2 with + [], _ -> fl2 + | (n, _) :: nl, (n2, _ as nt2) :: ntl' when n >= n2 -> + nt2 :: complete (if n = n2 then nl else fl1) ntl' + | (n, _) :: nl, _ -> let lid = concat_longident (Longident.Lident "Pkg") n in match Env.find_type_by_name lid env' with | (_, {type_arity = 0; type_kind = Type_abstract; type_private = Public; type_manifest = Some t2}) -> begin match nondep_instance env' lv2 id2 t2 with - | t -> (n, t) :: complete nl ntl2 + | t -> (n, t) :: complete nl fl2 | exception Nondep_cannot_erase _ -> if allow_absent then - complete nl ntl2 + complete nl fl2 else raise Exit end | (_, {type_arity = 0; type_kind = Type_abstract; type_private = Public; type_manifest = None}) when allow_absent -> - complete nl ntl2 + complete nl fl2 | _ -> raise Exit | exception Not_found when allow_absent-> - complete nl ntl2 + complete nl fl2 in - match complete nl1 (List.combine nl2 tl2) with + match complete fl1 fl2 with | res -> res | exception Exit -> raise Not_found (* raise Not_found rather than Unify if the module types are incompatible *) -let unify_package env unify_list lv1 p1 n1 tl1 lv2 p2 n2 tl2 = - let ntl2 = complete_type_list env n1 lv2 (Mty_ident p2) n2 tl2 - and ntl1 = complete_type_list env n2 lv1 (Mty_ident p1) n1 tl1 in +let unify_package env unify_list lv1 p1 fl1 lv2 p2 fl2 = + let ntl2 = complete_type_list env fl1 lv2 (Mty_ident p2) fl2 + and ntl1 = complete_type_list env fl2 lv1 (Mty_ident p1) fl1 in unify_list (List.map snd ntl1) (List.map snd ntl2); if eq_package_path env p1 p2 - || !package_subtype env p1 n1 tl1 p2 n2 tl2 - && !package_subtype env p2 n2 tl2 p1 n1 tl1 then () else raise Not_found + || !package_subtype env p1 fl1 p2 fl2 + && !package_subtype env p2 fl2 p1 fl1 then () else raise Not_found -let unify_alloc_mode a b = - match Btype.Alloc_mode.equate a b with +let unify_alloc_mode_for tr_exn a b = + match Alloc_mode.equate a b with | Ok () -> () - | Error () -> raise (Unify []) + | Error () -> raise_unexplained_for tr_exn (* force unification in Reither when one side has a non-conjunctive type *) let rigid_variants = ref false let unify_eq t1 t2 = - t1 == t2 || - match !umode with - | Expression -> false - | Pattern -> - TypePairs.mem unify_eq_set (order_type_pair t1 t2) + eq_type t1 t2 + || (in_pattern_mode () + && TypePairs.mem unify_eq_set (order_type_pair t1 t2)) let unify1_var env t1 t2 = assert (is_Tvar t1); - occur env t1 t2; - occur_univar env t2; - let d1 = t1.desc in - link_type t1 t2; - try - update_level env t1.level t2; - update_scope t1.scope t2 - with Unify _ as e -> - t1.desc <- d1; - raise e + occur_for Unify env t1 t2; + match occur_univar_for Unify env t2 with + | () -> + begin + try + update_level env (get_level t1) t2; + update_scope (get_scope t1) t2; + with Escape e -> + raise_for Unify (Escape e) + end; + link_type t1 t2; + true + | exception Unify_trace _ when in_pattern_mode () -> + false -(* Can only be called when generate_equations is true *) -let record_equation t1 t2 = - match !equations_generation with - | Forbidden -> assert false - | Allowed { equated_types } -> TypePairs.add equated_types (t1, t2) +(* Called from unify3 *) +let unify3_var env t1' t2 t2' = + occur_for Unify !env t1' t2; + match occur_univar_for Unify !env t2 with + | () -> link_type t1' t2 + | exception Unify_trace _ when in_pattern_mode () -> + reify env t1'; + reify env t2'; + if can_generate_equations () then begin + occur_univar ~inj_only:true !env t2'; + record_equation t1' t2'; + end + +(* + 1. When unifying two non-abbreviated types, one type is made a link + to the other. When unifying an abbreviated type with a + non-abbreviated type, the non-abbreviated type is made a link to + the other one. When unifying to abbreviated types, these two + types are kept distincts, but they are made to (temporally) + expand to the same type. + 2. Abbreviations with at least one parameter are systematically + expanded. The overhead does not seem too high, and that way + abbreviations where some parameters does not appear in the + expansion, such as ['a t = int], are correctly handled. In + particular, for this example, unifying ['a t] with ['b t] keeps + ['a] and ['b] distincts. (Is it really important ?) + 3. Unifying an abbreviation ['a t = 'a] with ['a] should not yield + ['a t as 'a]. Indeed, the type variable would otherwise be lost. + This problem occurs for abbreviations expanding to a type + variable, but also to many other constrained abbreviations (for + instance, [(< x : 'a > -> unit) t = ]). The solution is + that, if an abbreviation is unified with some subpart of its + parameters, then the parameter actually does not get + abbreviated. It would be possible to check whether some + information is indeed lost, but it probably does not worth it. +*) let rec unify (env:Env.t ref) t1 t2 = (* First step: special cases (optimizations) *) - if t1 == t2 then () else - let t1 = repr t1 in - let t2 = repr t2 in if unify_eq t1 t2 then () else let reset_tracing = check_trace_gadt_instances !env in try type_changed := true; - begin match (t1.desc, t2.desc) with + begin match (get_desc t1, get_desc t2) with (Tvar _, Tconstr _) when deep_occur t1 t2 -> unify2 env t1 t2 | (Tconstr _, Tvar _) when deep_occur t2 t1 -> unify2 env t1 t2 | (Tvar _, _) -> - unify1_var !env t1 t2 + if unify1_var !env t1 t2 then () else unify2 env t1 t2 | (_, Tvar _) -> - unify1_var !env t2 t1 + if unify1_var !env t2 t1 then () else unify2 env t1 t2 | (Tunivar _, Tunivar _) -> - unify_univar t1 t2 !univar_pairs; - update_level !env t1.level t2; - update_scope t1.scope t2; + unify_univar_for Unify t1 t2 !univar_pairs; + update_level_for Unify !env (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; link_type t1 t2 | (Tconstr (p1, [], a1), Tconstr (p2, [], a2)) when Path.same p1 p2 (* && actual_mode !env = Old *) @@ -2690,8 +2746,8 @@ let rec unify (env:Env.t ref) t1 t2 = when any of the types has a cached expansion. *) && not (has_cached_expansion p1 !a1 || has_cached_expansion p2 !a2) -> - update_level !env t1.level t2; - update_scope t1.scope t2; + update_level_for Unify !env (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; link_type t1 t2 | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Env.has_local_constraints !env @@ -2699,9 +2755,9 @@ let rec unify (env:Env.t ref) t1 t2 = (* Do not use local constraints more than necessary *) begin try if find_expansion_scope !env p1 > find_expansion_scope !env p2 then - unify env t1 (try_expand_once !env t2) + unify env t1 (try_expand_safe !env t2) else - unify env (try_expand_once !env t1) t2 + unify env (try_expand_safe !env t1) t2 with Cannot_expand -> unify2 env t1 t2 end @@ -2709,9 +2765,9 @@ let rec unify (env:Env.t ref) t1 t2 = unify2 env t1 t2 end; reset_trace_gadt_instances reset_tracing; - with Unify trace -> + with Unify_trace trace -> reset_trace_gadt_instances reset_tracing; - raise( Unify (Trace.diff t1 t2 :: trace) ) + raise_trace_for Unify (Diff {got = t1; expected = t2} :: trace) and unify2 env t1 t2 = (* Second step: expansion of abbreviations *) @@ -2720,59 +2776,53 @@ and unify2 env t1 t2 = ignore (expand_head_unif !env t2); let t1' = expand_head_unif !env t1 in let t2' = expand_head_unif !env t2 in - let lv = min t1'.level t2'.level in - let scope = max t1'.scope t2'.scope in - update_level !env lv t2; - update_level !env lv t1; - update_scope scope t2; - update_scope scope t1; + let lv = Int.min (get_level t1') (get_level t2') in + let scope = Int.max (get_scope t1') (get_scope t2') in + update_level_for Unify !env lv t2; + update_level_for Unify !env lv t1; + update_scope_for Unify scope t2; + update_scope_for Unify scope t1; if unify_eq t1' t2' then () else - let t1 = repr t1 and t2 = repr t2 in let t1, t2 = if !Clflags.principal && (find_lowest_level t1' < lv || find_lowest_level t2' < lv) then (* Expand abbreviations hiding a lower level *) (* Should also do it for parameterized types, after unification... *) - (match t1.desc with Tconstr (_, [], _) -> t1' | _ -> t1), - (match t2.desc with Tconstr (_, [], _) -> t2' | _ -> t2) + (match get_desc t1 with Tconstr (_, [], _) -> t1' | _ -> t1), + (match get_desc t2 with Tconstr (_, [], _) -> t2' | _ -> t2) else (t1, t2) in if unify_eq t1 t1' || not (unify_eq t2 t2') then unify3 env t1 t1' t2 t2' else - try unify3 env t2 t2' t1 t1' with Unify trace -> - raise (Unify (Trace.swap trace)) + try unify3 env t2 t2' t1 t1' with Unify_trace trace -> + raise_trace_for Unify (swap_trace trace) and unify3 env t1 t1' t2 t2' = (* Third step: truly unification *) (* Assumes either [t1 == t1'] or [t2 != t2'] *) - let d1 = t1'.desc and d2 = t2'.desc in - let create_recursion = (t2 != t2') && (deep_occur t1' t2) in + let tt1' = Transient_expr.repr t1' in + let d1 = tt1'.desc and d2 = get_desc t2' in + let create_recursion = + (not (eq_type t2 t2')) && (deep_occur t1' t2) in begin match (d1, d2) with (* handle vars and univars specially *) (Tunivar _, Tunivar _) -> - unify_univar t1' t2' !univar_pairs; + unify_univar_for Unify t1' t2' !univar_pairs; link_type t1' t2' | (Tvar _, _) -> - occur !env t1' t2; - occur_univar !env t2; - link_type t1' t2; + unify3_var env t1' t2 t2' | (_, Tvar _) -> - occur !env t2' t1; - occur_univar !env t1; - link_type t2' t1; + unify3_var env t2' t1 t1' | (Tfield _, Tfield _) -> (* special case for GADTs *) unify_fields env t1' t2' | _ -> - begin match !umode with - | Expression -> - occur !env t1' t2'; - if is_self_type d1 (* PR#7711: do not abbreviate self type *) - then link_type t1' t2' - else link_type t1' t2 - | Pattern -> - add_type_equality t1' t2' + if in_pattern_mode () then + add_type_equality t1' t2' + else begin + occur_for Unify !env t1' t2; + link_type t1' t2 end; try begin match (d1, d2) with @@ -2780,27 +2830,27 @@ and unify3 env t1 t1' t2 t2' = Tarrow ((l2,a2,r2), t2, u2, c2)) when (l1 = l2 || - (!Clflags.classic || !umode = Pattern) && + (!Clflags.classic || in_pattern_mode ()) && not (is_optional l1 || is_optional l2)) -> - unify_alloc_mode a1 a2; - unify_alloc_mode r1 r2; + unify_alloc_mode_for Unify a1 a2; + unify_alloc_mode_for Unify r1 r2; unify env t1 t2; unify env u1 u2; - begin match commu_repr c1, commu_repr c2 with - Clink r, c2 -> set_commu r c2 - | c1, Clink r -> set_commu r c1 - | _ -> () + begin match is_commu_ok c1, is_commu_ok c2 with + | false, true -> set_commu_ok c1 + | true, false -> set_commu_ok c2 + | false, false -> link_commu ~inside:c1 c2 + | true, true -> () end | (Ttuple tl1, Ttuple tl2) -> unify_list env tl1 tl2 | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> - if !umode = Expression || !equations_generation = Forbidden then + if not (can_generate_equations ()) then unify_list env tl1 tl2 - else if !assume_injective then - set_mode_pattern ~generate:!equations_generation ~injective:false - ~allow_recursive:!allow_recursive_equation - (fun () -> unify_list env tl1 tl2) + else if can_assume_injective () then + without_assume_injective (fun () -> unify_list env tl1 tl2) else if in_current_module p1 (* || in_pervasives p1 *) - || List.exists (expands_to_datatype !env) [t1'; t1; t2] then + || List.exists (expands_to_datatype !env) [t1'; t1; t2] + then unify_list env tl1 tl2 else let inj = @@ -2811,13 +2861,13 @@ and unify3 env t1 t1' t2 t2' = List.iter2 (fun i (t1, t2) -> if i then unify env t1 t2 else - set_mode_pattern ~generate:Forbidden ~injective:false - ~allow_recursive:!allow_recursive_equation + without_generating_equations begin fun () -> let snap = snapshot () in - try unify env t1 t2 with Unify _ -> + try unify env t1 t2 with Unify_trace _ -> backtrack snap; - reify env t1; reify env t2 + reify env t1; + reify env t2 end) inj (List.combine tl1 tl2) | (Tconstr (path,[],_), @@ -2841,104 +2891,106 @@ and unify3 env t1 t1' t2 t2' = reify env t1'; record_equation t1' t2'; add_gadt_equation env path t1' - | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when !umode = Pattern -> + | (Tconstr (_,_,_), _) | (_, Tconstr (_,_,_)) when in_pattern_mode () -> reify env t1'; reify env t2'; if can_generate_equations () then ( - mcomp !env t1' t2'; + mcomp_for Unify !env t1' t2'; record_equation t1' t2' ) | (Tobject (fi1, nm1), Tobject (fi2, _)) -> unify_fields env fi1 fi2; (* Type [t2'] may have been instantiated by [unify_fields] *) (* XXX One should do some kind of unification... *) - begin match (repr t2').desc with + begin match get_desc t2' with Tobject (_, {contents = Some (_, va::_)}) when - (match (repr va).desc with + (match get_desc va with Tvar _|Tunivar _|Tnil -> true | _ -> false) -> () | Tobject (_, nm2) -> set_name nm2 !nm1 | _ -> () end | (Tvariant row1, Tvariant row2) -> - if !umode = Expression then + if not (in_pattern_mode ()) then unify_row env row1 row2 else begin let snap = snapshot () in try unify_row env row1 row2 - with Unify _ -> + with Unify_trace _ -> backtrack snap; reify env t1'; reify env t2'; if can_generate_equations () then ( - mcomp !env t1' t2'; + mcomp_for Unify !env t1' t2'; record_equation t1' t2' ) end | (Tfield(f,kind,_,rem), Tnil) | (Tnil, Tfield(f,kind,_,rem)) -> begin match field_kind_repr kind with - Fvar r when f <> dummy_method -> - set_kind r Fabsent; + Fprivate when f <> dummy_method -> + link_kind ~inside:kind field_absent; if d2 = Tnil then unify env rem t2' - else unify env (newty2 rem.level Tnil) rem + else unify env (newgenty Tnil) rem | _ -> if f = dummy_method then - raise (Unify Trace.[Obj Self_cannot_be_closed]) + raise_for Unify (Obj Self_cannot_be_closed) else if d1 = Tnil then - raise (Unify Trace.[Obj(Missing_field (First, f))]) + raise_for Unify (Obj (Missing_field(First, f))) else - raise (Unify Trace.[Obj(Missing_field (Second, f))]) + raise_for Unify (Obj (Missing_field(Second, f))) end | (Tnil, Tnil) -> () | (Tpoly (t1, []), Tpoly (t2, [])) -> unify env t1 t2 | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> - enter_poly !env univar_pairs t1 tl1 t2 tl2 (unify env) - | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) -> + enter_poly_for Unify !env univar_pairs t1 tl1 t2 tl2 (unify env) + | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> begin try unify_package !env (unify_list env) - t1.level p1 n1 tl1 t2.level p2 n2 tl2 + (get_level t1) p1 fl1 (get_level t2) p2 fl2 with Not_found -> - if !umode = Expression then raise (Unify []); - List.iter (reify env) (tl1 @ tl2); + if not (in_pattern_mode ()) then raise_unexplained_for Unify; + List.iter (fun (_n, ty) -> reify env ty) (fl1 @ fl2); (* if !generate_equations then List.iter2 (mcomp !env) tl1 tl2 *) end - | (Tnil, Tconstr _ ) -> raise (Unify Trace.[Obj(Abstract_row Second)]) - | (Tconstr _, Tnil ) -> raise (Unify Trace.[Obj(Abstract_row First)]) - | (_, _) -> raise (Unify []) + | (Tnil, Tconstr _ ) -> + raise_for Unify (Obj (Abstract_row Second)) + | (Tconstr _, Tnil ) -> + raise_for Unify (Obj (Abstract_row First)) + | (_, _) -> raise_unexplained_for Unify end; (* XXX Commentaires + changer "create_recursion" ||| Comments + change "create_recursion" *) if create_recursion then - match t2.desc with + match get_desc t2 with Tconstr (p, tl, abbrev) -> forget_abbrev abbrev p; let t2'' = expand_head_unif !env t2 in if not (closed_parameterized_type tl t2'') then - link_type (repr t2) (repr t2') + link_type t2 t2' | _ -> () (* t2 has already been expanded by update_level *) - with Unify trace -> - t1'.desc <- d1; - raise (Unify trace) + with Unify_trace trace -> + Transient_expr.set_desc tt1' d1; + raise_trace_for Unify trace end and unify_list env tl1 tl2 = if List.length tl1 <> List.length tl2 then - raise (Unify []); + raise_unexplained_for Unify; List.iter2 (unify env) tl1 tl2 (* Build a fresh row variable for unification *) and make_rowvar level use1 rest1 use2 rest2 = let set_name ty name = - match ty.desc with + match get_desc ty with Tvar None -> set_type_desc ty (Tvar name) | _ -> () in let name = - match rest1.desc, rest2.desc with + match get_desc rest1, get_desc rest2 with Tvar (Some _ as name1), Tvar (Some _ as name2) -> - if rest1.level <= rest2.level then name1 else name2 + if get_level rest1 <= get_level rest2 then name1 else name2 | Tvar (Some _ as name), _ -> if use2 then set_name rest2 name; name | _, Tvar (Some _ as name) -> @@ -2946,51 +2998,53 @@ and make_rowvar level use1 rest1 use2 rest2 = | _ -> None in if use1 then rest1 else - if use2 then rest2 else newvar2 ?name level + if use2 then rest2 else newty2 ~level (Tvar name) and unify_fields env ty1 ty2 = (* Optimization *) let (fields1, rest1) = flatten_fields ty1 and (fields2, rest2) = flatten_fields ty2 in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in - let l1 = (repr ty1).level and l2 = (repr ty2).level in - let va = make_rowvar (min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in - let d1 = rest1.desc and d2 = rest2.desc in + let l1 = get_level ty1 and l2 = get_level ty2 in + let va = make_rowvar (Int.min l1 l2) (miss2=[]) rest1 (miss1=[]) rest2 in + let tr1 = Transient_expr.repr rest1 and tr2 = Transient_expr.repr rest2 in + let d1 = tr1.desc and d2 = tr2.desc in try unify env (build_fields l1 miss1 va) rest2; unify env rest1 (build_fields l2 miss2 va); List.iter - (fun (n, k1, t1, k2, t2) -> + (fun (name, k1, t1, k2, t2) -> unify_kind k1 k2; try - if !trace_gadt_instances then begin - update_level !env va.level t1; - update_scope va.scope t1 + if !trace_gadt_instances && not (in_subst_mode ()) then begin + (* in_subst_mode: see PR#11771 *) + update_level_for Unify !env (get_level va) t1; + update_scope_for Unify (get_scope va) t1 end; unify env t1 t2 - with Unify trace -> - raise( Unify (Trace.incompatible_fields n t1 t2 :: trace) ) + with Unify_trace trace -> + raise_trace_for Unify + (incompatible_fields ~name ~got:t1 ~expected:t2 :: trace) ) pairs with exn -> - set_type_desc rest1 d1; - set_type_desc rest2 d2; + Transient_expr.set_desc tr1 d1; + Transient_expr.set_desc tr2 d2; raise exn and unify_kind k1 k2 = - let k1 = field_kind_repr k1 in - let k2 = field_kind_repr k2 in - if k1 == k2 then () else - match k1, k2 with - (Fvar r, (Fvar _ | Fpresent)) -> set_kind r k2 - | (Fpresent, Fvar r) -> set_kind r k1 - | (Fpresent, Fpresent) -> () - | _ -> assert false + match field_kind_repr k1, field_kind_repr k2 with + (Fprivate, (Fprivate | Fpublic)) -> link_kind ~inside:k1 k2 + | (Fpublic, Fprivate) -> link_kind ~inside:k2 k1 + | (Fpublic, Fpublic) -> () + | _ -> assert false and unify_row env row1 row2 = - let row1 = row_repr row1 and row2 = row_repr row2 in - let rm1 = row_more row1 and rm2 = row_more row2 in + let Row {fields = row1_fields; more = rm1; + closed = row1_closed; name = row1_name} = row_repr row1 in + let Row {fields = row2_fields; more = rm2; + closed = row2_closed; name = row2_name} = row_repr row2 in if unify_eq rm1 rm2 then () else - let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in + let r1, r2, pairs = merge_row_fields row1_fields row2_fields in if r1 <> [] && r2 <> [] then begin let ht = Hashtbl.create (List.length r1) in List.iter (fun (l,_) -> Hashtbl.add ht (hash_variant l) l) r1; @@ -3002,13 +3056,14 @@ and unify_row env row1 row2 = end; let fixed1 = fixed_explanation row1 and fixed2 = fixed_explanation row2 in let more = match fixed1, fixed2 with - | Some _, Some _ -> if rm2.level < rm1.level then rm2 else rm1 + | Some _, Some _ -> if get_level rm2 < get_level rm1 then rm2 else rm1 | Some _, None -> rm1 | None, Some _ -> rm2 - | None, None -> newty2 (min rm1.level rm2.level) (Tvar None) + | None, None -> + newty2 ~level:(Int.min (get_level rm1) (get_level rm2)) (Tvar None) in let fixed = merge_fixed_explanation fixed1 fixed2 - and closed = row1.row_closed || row2.row_closed in + and closed = row1_closed || row2_closed in let keep switch = List.for_all (fun (_,f1,f2) -> @@ -3019,97 +3074,100 @@ and unify_row env row1 row2 = let empty fields = List.for_all (fun (_,f) -> row_field_repr f = Rabsent) fields in (* Check whether we are going to build an empty type *) - if closed && (empty r1 || row2.row_closed) && (empty r2 || row1.row_closed) + if closed && (empty r1 || row2_closed) && (empty r2 || row1_closed) && List.for_all (fun (_,f1,f2) -> row_field_repr f1 = Rabsent || row_field_repr f2 = Rabsent) pairs - then raise Trace.( Unify [Variant No_intersection] ); + then raise_for Unify (Variant No_intersection); let name = - if row1.row_name <> None && (row1.row_closed || empty r2) && - (not row2.row_closed || keep (fun f1 f2 -> f1, f2) && empty r1) - then row1.row_name - else if row2.row_name <> None && (row2.row_closed || empty r1) && - (not row1.row_closed || keep (fun f1 f2 -> f2, f1) && empty r2) - then row2.row_name + if row1_name <> None && (row1_closed || empty r2) && + (not row2_closed || keep (fun f1 f2 -> f1, f2) && empty r1) + then row1_name + else if row2_name <> None && (row2_closed || empty r1) && + (not row1_closed || keep (fun f1 f2 -> f2, f1) && empty r2) + then row2_name else None in - let row0 = {row_fields = []; row_more = more; row_bound = (); - row_closed = closed; row_fixed = fixed; row_name = name} in - let set_more row rest = + let set_more pos row rest = let rest = if closed then - filter_row_fields row.row_closed rest + filter_row_fields (row_closed row) rest else rest in begin match fixed_explanation row with | None -> - if rest <> [] && row.row_closed then - let pos = if row == row1 then Trace.First else Trace.Second in - raise Trace.(Unify [Variant (No_tags(pos,rest))]) + if rest <> [] && row_closed row then + raise_for Unify (Variant (No_tags(pos,rest))) | Some fixed -> - let pos = if row == row1 then Trace.First else Trace.Second in - if closed && not row.row_closed then - raise Trace.(Unify [Variant(Fixed_row(pos,Cannot_be_closed,fixed))]) + if closed && not (row_closed row) then + raise_for Unify (Variant (Fixed_row(pos,Cannot_be_closed,fixed))) else if rest <> [] then - let case = Trace.Cannot_add_tags (List.map fst rest) in - raise Trace.(Unify [Variant(Fixed_row(pos,case,fixed))]) + let case = Cannot_add_tags (List.map fst rest) in + raise_for Unify (Variant (Fixed_row(pos,case,fixed))) end; (* The following test is not principal... should rather use Tnil *) let rm = row_more row in (*if !trace_gadt_instances && rm.desc = Tnil then () else*) - if !trace_gadt_instances then - update_level !env rm.level (newgenty (Tvariant row)); - if row_fixed row then - if more == rm then () else + if !trace_gadt_instances && not (in_subst_mode ()) then + (* in_subst_mode: see PR#11771 *) + update_level_for Unify !env (get_level rm) (newgenty (Tvariant row)); + if has_fixed_explanation row then + if eq_type more rm then () else if is_Tvar rm then link_type rm more else unify env rm more else - let ty = newgenty (Tvariant {row0 with row_fields = rest}) in - update_level !env rm.level ty; - update_scope rm.scope ty; + let ty = + newgenty (Tvariant + (create_row ~fields:rest ~more ~closed ~fixed ~name)) + in + update_level_for Unify !env (get_level rm) ty; + update_scope_for Unify (get_scope rm) ty; link_type rm ty in - let md1 = rm1.desc and md2 = rm2.desc in + let tm1 = Transient_expr.repr rm1 and tm2 = Transient_expr.repr rm2 in + let md1 = tm1.desc and md2 = tm2.desc in begin try - set_more row2 r1; - set_more row1 r2; + set_more Second row2 r1; + set_more First row1 r2; List.iter (fun (l,f1,f2) -> try unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 - with Unify trace -> - raise Trace.( Unify( Variant (Incompatible_types_for l) :: trace )) + with Unify_trace trace -> + raise_trace_for Unify (Variant (Incompatible_types_for l) :: trace) ) pairs; if static_row row1 then begin let rm = row_more row1 in - if is_Tvar rm then link_type rm (newty2 rm.level Tnil) + if is_Tvar rm then link_type rm (newty2 ~level:(get_level rm) Tnil) end with exn -> - set_type_desc rm1 md1; set_type_desc rm2 md2; raise exn + Transient_expr.set_desc tm1 md1; + Transient_expr.set_desc tm2 md2; + raise exn end and unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 = - let f1 = row_field_repr f1 and f2 = row_field_repr f2 in let if_not_fixed (pos,fixed) f = match fixed with | None -> f () | Some fix -> - let tr = Trace.[ Variant (Fixed_row (pos,Cannot_add_tags [l],fix)) ] in - raise (Unify tr) in - let first = Trace.First, fixed1 and second = Trace.Second, fixed2 in + let tr = [Variant(Fixed_row(pos,Cannot_add_tags [l],fix))] in + raise_trace_for Unify tr in + let first = First, fixed1 and second = Second, fixed2 in let either_fixed = match fixed1, fixed2 with | None, None -> false | _ -> true in if f1 == f2 then () else - match f1, f2 with + match row_field_repr f1, row_field_repr f2 with Rpresent(Some t1), Rpresent(Some t2) -> unify env t1 t2 | Rpresent None, Rpresent None -> () - | Reither(c1, tl1, m1, e1), Reither(c2, tl2, m2, e2) -> - if e1 == e2 then () else - if either_fixed && not (c1 || c2) + | Reither(c1, tl1, m1), Reither(c2, tl2, m2) -> + if eq_row_field_ext f1 f2 then () else + let no_arg = c1 || c2 and matched = m1 || m2 in + if either_fixed && not no_arg && List.length tl1 = List.length tl2 then begin (* PR#7496 *) - let f = Reither (c1 || c2, [], m1 || m2, ref None) in - set_row_field e1 f; set_row_field e2 f; + let f = rf_either [] ~no_arg ~matched in + link_row_field_ext ~inside:f1 f; link_row_field_ext ~inside:f2 f; List.iter2 (unify env) tl1 tl2 end else let redo = @@ -3117,93 +3175,83 @@ and unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 = !rigid_variants && (List.length tl1 = 1 || List.length tl2 = 1)) && begin match tl1 @ tl2 with [] -> false | t1 :: tl -> - if c1 || c2 then raise (Unify []); - List.iter (unify env t1) tl; - !e1 <> None || !e2 <> None + if no_arg then raise_unexplained_for Unify; + Types.changed_row_field_exts [f1;f2] (fun () -> + List.iter (unify env t1) tl + ) end in if redo then unify_row_field env fixed1 fixed2 rm1 rm2 l f1 f2 else - let tl1 = List.map repr tl1 and tl2 = List.map repr tl2 in - let rec remq tl = function [] -> [] - | ty :: tl' -> - if List.memq ty tl then remq tl tl' else ty :: remq tl tl' - in + let remq tl = + List.filter (fun ty -> not (List.exists (eq_type ty) tl)) in let tl1' = remq tl2 tl1 and tl2' = remq tl1 tl2 in (* PR#6744 *) - let split_univars = - List.partition - (fun ty -> try occur_univar !env ty; true with Unify _ -> false) in - let (tl1',tlu1) = split_univars tl1' - and (tl2',tlu2) = split_univars tl2' in + let (tlu1,tl1') = List.partition (has_free_univars !env) tl1' + and (tlu2,tl2') = List.partition (has_free_univars !env) tl2' in begin match tlu1, tlu2 with [], [] -> () | (tu1::tlu1), _ :: _ -> (* Attempt to merge all the types containing univars *) List.iter (unify env tu1) (tlu1@tlu2) - | (tu::_, []) | ([], tu::_) -> occur_univar !env tu + | (tu::_, []) | ([], tu::_) -> + occur_univar_for Unify !env tu end; (* Is this handling of levels really principal? *) - List.iter (fun ty -> - let rm = repr rm2 in - update_level !env rm.level ty; - update_scope rm.scope ty; - ) tl1'; - List.iter (fun ty -> - let rm = repr rm1 in - update_level !env rm.level ty; - update_scope rm.scope ty; - ) tl2'; - let e = ref None in - let f1' = Reither(c1 || c2, tl2', m1 || m2, e) - and f2' = Reither(c1 || c2, tl1', m1 || m2, e) in - set_row_field e1 f1'; set_row_field e2 f2'; - | Reither(_, _, false, e1), Rabsent -> - if_not_fixed first (fun () -> set_row_field e1 f2) - | Rabsent, Reither(_, _, false, e2) -> - if_not_fixed second (fun () -> set_row_field e2 f1) + let update_levels rm = + List.iter + (fun ty -> + update_level_for Unify !env (get_level rm) ty; + update_scope_for Unify (get_scope rm) ty) + in + update_levels rm2 tl1'; + update_levels rm1 tl2'; + let f1' = rf_either tl2' ~no_arg ~matched in + let f2' = rf_either tl1' ~use_ext_of:f1' ~no_arg ~matched in + link_row_field_ext ~inside:f1 f1'; link_row_field_ext ~inside:f2 f2'; + | Reither(_, _, false), Rabsent -> + if_not_fixed first (fun () -> link_row_field_ext ~inside:f1 f2) + | Rabsent, Reither(_, _, false) -> + if_not_fixed second (fun () -> link_row_field_ext ~inside:f2 f1) | Rabsent, Rabsent -> () - | Reither(false, tl, _, e1), Rpresent(Some t2) -> + | Reither(false, tl, _), Rpresent(Some t2) -> if_not_fixed first (fun () -> - set_row_field e1 f2; - let rm = repr rm1 in - update_level !env rm.level t2; - update_scope rm.scope t2; + let s = snapshot () in + link_row_field_ext ~inside:f1 f2; + update_level_for Unify !env (get_level rm1) t2; + update_scope_for Unify (get_scope rm1) t2; (try List.iter (fun t1 -> unify env t1 t2) tl - with exn -> e1 := None; raise exn) + with exn -> undo_first_change_after s; raise exn) ) - | Rpresent(Some t1), Reither(false, tl, _, e2) -> + | Rpresent(Some t1), Reither(false, tl, _) -> if_not_fixed second (fun () -> - set_row_field e2 f1; - let rm = repr rm2 in - update_level !env rm.level t1; - update_scope rm.scope t1; + let s = snapshot () in + link_row_field_ext ~inside:f2 f1; + update_level_for Unify !env (get_level rm2) t1; + update_scope_for Unify (get_scope rm2) t1; (try List.iter (unify env t1) tl - with exn -> e2 := None; raise exn) + with exn -> undo_first_change_after s; raise exn) ) - | Reither(true, [], _, e1), Rpresent None -> - if_not_fixed first (fun () -> set_row_field e1 f2) - | Rpresent None, Reither(true, [], _, e2) -> - if_not_fixed second (fun () -> set_row_field e2 f1) - | _ -> raise (Unify []) - + | Reither(true, [], _), Rpresent None -> + if_not_fixed first (fun () -> link_row_field_ext ~inside:f1 f2) + | Rpresent None, Reither(true, [], _) -> + if_not_fixed second (fun () -> link_row_field_ext ~inside:f2 f1) + | _ -> raise_unexplained_for Unify let unify env ty1 ty2 = let snap = Btype.snapshot () in try unify env ty1 ty2 with - Unify trace -> + Unify_trace trace -> undo_compress snap; - raise (Unify (expand_trace !env trace)) + raise (Unify (expand_to_unification_error !env trace)) -let unify_gadt ~equations_level:lev ~allow_recursive (env:Env.t ref) ty1 ty2 = +let unify_gadt ~equations_level:lev ~allow_recursive_equations + (env:Env.t ref) ty1 ty2 = try univar_pairs := []; gadt_equations_level := Some lev; let equated_types = TypePairs.create 0 in - set_mode_pattern - ~generate:(Allowed { equated_types }) - ~injective:true - ~allow_recursive + set_mode_pattern ~allow_recursive_equations ~equated_types (fun () -> unify env ty1 ty2); gadt_equations_level := None; TypePairs.clear unify_eq_set; @@ -3214,28 +3262,28 @@ let unify_gadt ~equations_level:lev ~allow_recursive (env:Env.t ref) ty1 ty2 = raise e let unify_var env t1 t2 = - let t1 = repr t1 and t2 = repr t2 in - if t1 == t2 then () else - match t1.desc, t2.desc with + if eq_type t1 t2 then () else + match get_desc t1, get_desc t2 with Tvar _, Tconstr _ when deep_occur t1 t2 -> unify (ref env) t1 t2 | Tvar _, _ -> let reset_tracing = check_trace_gadt_instances env in begin try - occur env t1 t2; - update_level env t1.level t2; - update_scope t1.scope t2; + occur_for Unify env t1 t2; + update_level_for Unify env (get_level t1) t2; + update_scope_for Unify (get_scope t1) t2; link_type t1 t2; reset_trace_gadt_instances reset_tracing; - with Unify trace -> + with Unify_trace trace -> reset_trace_gadt_instances reset_tracing; - let expanded_trace = expand_trace env @@ Trace.diff t1 t2 :: trace in - raise (Unify expanded_trace) + raise (Unify (expand_to_unification_error + env + (Diff { got = t1; expected = t2 } :: trace))) end | _ -> unify (ref env) t1 t2 -let _ = unify' := unify_var +let _ = unify_var' := unify_var let unify_pairs env ty1 ty2 pairs = univar_pairs := pairs; @@ -3256,83 +3304,448 @@ let expand_head_trace env t = (* Unify [t] and [l:'a -> 'b]. Return ['a] and ['b]. - In label mode, label mismatch is accepted when + In [-nolabels] mode, label mismatch is accepted when (1) the requested label is "" (2) the original label is not optional *) -let filter_arrow env t l = - let t = expand_head_trace env t in - match t.desc with +type filter_arrow_failure = + | Unification_error of unification_error + | Label_mismatch of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + } + | Not_a_function + +exception Filter_arrow_failed of filter_arrow_failure + +let filter_arrow env t l ~force_tpoly = + let function_type level = + let t1 = + if not force_tpoly then begin + assert (not (is_optional l)); + newvar2 level + end else begin + let t1 = + if is_optional l then + newty2 ~level + (Tconstr(Predef.path_option,[newvar2 level], ref Mnil)) + else + newvar2 level + in + newty2 ~level (Tpoly(t1, [])) + end + in + let t2 = newvar2 level in + let marg = Alloc_mode.newvar () in + let mret = Alloc_mode.newvar () in + let t' = newty2 ~level (Tarrow ((l,marg,mret), t1, t2, commu_ok)) in + t', marg, t1, mret, t2 + in + let t = + try expand_head_trace env t + with Unify_trace trace -> + let t', _, _, _, _ = function_type (get_level t) in + raise (Filter_arrow_failed + (Unification_error + (expand_to_unification_error + env + (Diff { got = t'; expected = t } :: trace)))) + in + match get_desc t with Tvar _ -> - let lv = t.level in - let t1 = newvar2 lv and t2 = newvar2 lv in - let marg = Btype.Alloc_mode.newvar () in - let mret = Btype.Alloc_mode.newvar () in - let t' = newty2 lv (Tarrow ((l,marg,mret), t1, t2, Cok)) in + let t', marg, t1, mret, t2 = function_type (get_level t) in link_type t t'; (marg, t1, mret, t2) - | Tarrow((l', arg, ret), t1, t2, _) - when (l = l' || !Clflags.classic && l = Nolabel && not (is_optional l)) -> - (arg, t1, ret, t2) + | Tarrow((l', marg, mret), t1, t2, _) -> + if l = l' || !Clflags.classic && l = Nolabel && not (is_optional l') + then (marg, t1, mret, t2) + else raise (Filter_arrow_failed + (Label_mismatch + { got = l; expected = l'; expected_type = t })) | _ -> - raise (Unify []) + raise (Filter_arrow_failed Not_a_function) + +exception Filter_mono_failed + +let filter_mono ty = + match get_desc ty with + | Tpoly(ty, []) -> ty + | Tpoly _ -> raise Filter_mono_failed + | _ -> assert false + +exception Filter_arrow_mono_failed + +let filter_arrow_mono env t l = + match filter_arrow env t l ~force_tpoly:true with + | exception Filter_arrow_failed _ -> raise Filter_arrow_mono_failed + | (marg, t1, mret, t2) -> + match filter_mono t1 with + | exception Filter_mono_failed -> raise Filter_arrow_mono_failed + | t1 -> (marg, t1, mret, t2) + +type filter_method_failure = + | Unification_error of unification_error + | Not_a_method + | Not_an_object of type_expr + +exception Filter_method_failed of filter_method_failure (* Used by [filter_method]. *) -let rec filter_method_field env name priv ty = - let ty = expand_head_trace env ty in - match ty.desc with - Tvar _ -> - let level = ty.level in +let rec filter_method_field env name ty = + let method_type ~level = let ty1 = newvar2 level and ty2 = newvar2 level in - let ty' = newty2 level (Tfield (name, - begin match priv with - Private -> Fvar (ref None) - | Public -> Fpresent - end, - ty1, ty2)) - in + let ty' = newty2 ~level (Tfield (name, field_public, ty1, ty2)) in + ty', ty1 + in + let ty = + try expand_head_trace env ty + with Unify_trace trace -> + let level = get_level ty in + let ty', _ = method_type ~level in + raise (Filter_method_failed + (Unification_error + (expand_to_unification_error + env + (Diff { got = ty; expected = ty' } :: trace)))) + in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + let ty', ty1 = method_type ~level in link_type ty ty'; ty1 | Tfield(n, kind, ty1, ty2) -> - let kind = field_kind_repr kind in - if (n = name) && (kind <> Fabsent) then begin - if priv = Public then - unify_kind kind Fpresent; + if n = name then begin + unify_kind kind field_public; ty1 end else - filter_method_field env name priv ty2 + filter_method_field env name ty2 | _ -> - raise (Unify []) + raise (Filter_method_failed Not_a_method) (* Unify [ty] and [< name : 'a; .. >]. Return ['a]. *) -let filter_method env name priv ty = - let ty = expand_head_trace env ty in - match ty.desc with - Tvar _ -> - let ty1 = newvar () in - let ty' = newobj ty1 in - update_level env ty.level ty'; - update_scope ty.scope ty'; +let filter_method env name ty = + let object_type ~level ~scope = + let ty1 = newvar2 level in + let ty' = newty3 ~level ~scope (Tobject (ty1, ref None)) in + let ty_meth = filter_method_field env name ty1 in + (ty', ty_meth) + in + let ty = + try expand_head_trace env ty + with Unify_trace trace -> + let level = get_level ty in + let scope = get_scope ty in + let ty', _ = object_type ~level ~scope in + raise (Filter_method_failed + (Unification_error + (expand_to_unification_error + env + (Diff { got = ty; expected = ty' } :: trace)))) + in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + let scope = get_scope ty in + let ty', ty_meth = object_type ~level ~scope in link_type ty ty'; - filter_method_field env name priv ty1 + ty_meth | Tobject(f, _) -> - filter_method_field env name priv f + filter_method_field env name f | _ -> - raise (Unify []) + raise (Filter_method_failed (Not_an_object ty)) + +exception Filter_method_row_failed + +let rec filter_method_row env name priv ty = + let ty = expand_head env ty in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + let field = newvar2 level in + let row = newvar2 level in + let kind, priv = + match priv with + | Private -> + let kind = field_private () in + kind, Mprivate kind + | Public -> + field_public, Mpublic + in + let ty' = newty2 ~level (Tfield (name, kind, field, row)) in + link_type ty ty'; + priv, field, row + | Tfield(n, kind, ty1, ty2) -> + if n = name then begin + let priv = + match priv with + | Public -> + unify_kind kind field_public; + Mpublic + | Private -> Mprivate kind + in + priv, ty1, ty2 + end else begin + let level = get_level ty in + let priv, field, row = filter_method_row env name priv ty2 in + let row = newty2 ~level (Tfield (n, kind, ty1, row)) in + priv, field, row + end + | Tnil -> + if name = Btype.dummy_method then raise Filter_method_row_failed + else begin + match priv with + | Public -> raise Filter_method_row_failed + | Private -> + let level = get_level ty in + let kind = field_absent in + Mprivate kind, newvar2 level, ty + end + | _ -> + raise Filter_method_row_failed -let check_filter_method env name priv ty = - ignore(filter_method env name priv ty) +(* Operations on class signatures *) -let filter_self_method env lab priv meths ty = - let ty' = filter_method env lab priv ty in - try - Meths.find lab !meths - with Not_found -> - let pair = (Ident.create_local lab, ty') in - meths := Meths.add lab pair !meths; - pair +let new_class_signature () = + let row = newvar () in + let self = newobj row in + { csig_self = self; + csig_self_row = row; + csig_vars = Vars.empty; + csig_meths = Meths.empty; } + +let add_dummy_method env ~scope sign = + let _, ty, row = + filter_method_row env dummy_method Private sign.csig_self_row + in + unify env ty (new_scoped_ty scope (Ttuple [])); + sign.csig_self_row <- row + +type add_method_failure = + | Unexpected_method + | Type_mismatch of Errortrace.unification_error + +exception Add_method_failed of add_method_failure + +let add_method env label priv virt ty sign = + let meths = sign.csig_meths in + let priv, virt = + match Meths.find label meths with + | (priv', virt', ty') -> begin + let priv = + match priv' with + | Mpublic -> Mpublic + | Mprivate k -> + match priv with + | Public -> + begin match field_kind_repr k with + | Fpublic -> () + | Fprivate -> link_kind ~inside:k field_public + | Fabsent -> assert false + end; + Mpublic + | Private -> priv' + in + let virt = + match virt' with + | Concrete -> Concrete + | Virtual -> virt + in + match unify env ty ty' with + | () -> priv, virt + | exception Unify trace -> + raise (Add_method_failed (Type_mismatch trace)) + end + | exception Not_found -> begin + let priv, ty', row = + match filter_method_row env label priv sign.csig_self_row with + | priv, ty', row -> + priv, ty', row + | exception Filter_method_row_failed -> + raise (Add_method_failed Unexpected_method) + in + match unify env ty ty' with + | () -> + sign.csig_self_row <- row; + priv, virt + | exception Unify trace -> + raise (Add_method_failed (Type_mismatch trace)) + end + in + let meths = Meths.add label (priv, virt, ty) meths in + sign.csig_meths <- meths + +type add_instance_variable_failure = + | Mutability_mismatch of mutable_flag + | Type_mismatch of Errortrace.unification_error + +exception Add_instance_variable_failed of add_instance_variable_failure + +let check_mutability mut mut' = + match mut, mut' with + | Mutable, Mutable -> () + | Immutable, Immutable -> () + | Mutable, Immutable | Immutable, Mutable -> + raise (Add_instance_variable_failed (Mutability_mismatch mut)) + +let add_instance_variable ~strict env label mut virt ty sign = + let vars = sign.csig_vars in + let virt = + match Vars.find label vars with + | (mut', virt', ty') -> + let virt = + match virt' with + | Concrete -> Concrete + | Virtual -> virt + in + if strict then begin + check_mutability mut mut'; + match unify env ty ty' with + | () -> () + | exception Unify trace -> + raise (Add_instance_variable_failed (Type_mismatch trace)) + end; + virt + | exception Not_found -> virt + in + let vars = Vars.add label (mut, virt, ty) vars in + sign.csig_vars <- vars + +type inherit_class_signature_failure = + | Self_type_mismatch of Errortrace.unification_error + | Method of label * add_method_failure + | Instance_variable of label * add_instance_variable_failure + +exception Inherit_class_signature_failed of inherit_class_signature_failure + +let unify_self_types env sign1 sign2 = + let self_type1 = sign1.csig_self in + let self_type2 = sign2.csig_self in + match unify env self_type1 self_type2 with + | () -> () + | exception Unify err -> begin + match err.trace with + | Errortrace.Diff _ :: Errortrace.Incompatible_fields {name; _} :: rem -> + let err = Errortrace.unification_error ~trace:rem in + let failure = Method (name, Type_mismatch err) in + raise (Inherit_class_signature_failed failure) + | _ -> + raise (Inherit_class_signature_failed (Self_type_mismatch err)) + end +(* Unify components of sign2 into sign1 *) +let inherit_class_signature ~strict env sign1 sign2 = + unify_self_types env sign1 sign2; + Meths.iter + (fun label (priv, virt, ty) -> + let priv = + match priv with + | Mpublic -> Public + | Mprivate kind -> + assert (field_kind_repr kind = Fabsent); + Private + in + match add_method env label priv virt ty sign1 with + | () -> () + | exception Add_method_failed failure -> + let failure = Method(label, failure) in + raise (Inherit_class_signature_failed failure)) + sign2.csig_meths; + Vars.iter + (fun label (mut, virt, ty) -> + match add_instance_variable ~strict env label mut virt ty sign1 with + | () -> () + | exception Add_instance_variable_failed failure -> + let failure = Instance_variable(label, failure) in + raise (Inherit_class_signature_failed failure)) + sign2.csig_vars + +let update_class_signature env sign = + let self = expand_head env sign.Types.csig_self in + let fields, row = flatten_fields (object_fields self) in + let meths, implicitly_public, implicitly_declared = + List.fold_left + (fun (meths, implicitly_public, implicitly_declared) (lab, k, ty) -> + if lab = dummy_method then + meths, implicitly_public, implicitly_declared + else begin + match Meths.find lab meths with + | priv, virt, ty' -> + let meths, implicitly_public = + match priv, field_kind_repr k with + | Mpublic, _ -> meths, implicitly_public + | Mprivate _, Fpublic -> + let meths = Meths.add lab (Mpublic, virt, ty') meths in + let implicitly_public = lab :: implicitly_public in + meths, implicitly_public + | Mprivate _, _ -> meths, implicitly_public + in + meths, implicitly_public, implicitly_declared + | exception Not_found -> + let meths, implicitly_declared = + match field_kind_repr k with + | Fpublic -> + let meths = Meths.add lab (Mpublic, Virtual, ty) meths in + let implicitly_declared = lab :: implicitly_declared in + meths, implicitly_declared + | Fprivate -> + let meths = + Meths.add lab (Mprivate k, Virtual, ty) meths + in + let implicitly_declared = lab :: implicitly_declared in + meths, implicitly_declared + | Fabsent -> meths, implicitly_declared + in + meths, implicitly_public, implicitly_declared + end) + (sign.csig_meths, [], []) fields + in + sign.csig_meths <- meths; + sign.csig_self_row <- row; + implicitly_public, implicitly_declared + +let hide_private_methods env sign = + let self = expand_head env sign.Types.csig_self in + let fields, _ = flatten_fields (object_fields self) in + List.iter + (fun (_, k, _) -> + match field_kind_repr k with + | Fprivate -> link_kind ~inside:k field_absent + | _ -> ()) + fields + +let close_class_signature env sign = + let rec close env ty = + let ty = expand_head env ty in + match get_desc ty with + | Tvar _ -> + let level = get_level ty in + link_type ty (newty2 ~level Tnil); true + | Tfield(lab, _, _, _) when lab = dummy_method -> + false + | Tfield(_, _, _, ty') -> close env ty' + | Tnil -> true + | _ -> assert false + in + let self = expand_head env sign.csig_self in + close env (object_fields self) + +let generalize_class_signature_spine env sign = + (* Generalize the spine of methods *) + let meths = sign.csig_meths in + Meths.iter (fun _ (_, _, ty) -> generalize_spine ty) meths; + let new_meths = + Meths.map + (fun (priv, virt, ty) -> (priv, virt, generic_instance ty)) + meths + in + (* But keep levels correct on the type of self *) + Meths.iter + (fun _ (_, _, ty) -> unify_var env (newvar ()) ty) + meths; + sign.csig_meths <- new_meths (***********************************) (* Matching between type schemes *) @@ -3344,21 +3757,19 @@ let filter_self_method env lab priv meths ty = *) let moregen_occur env level ty = let rec occur ty = - let ty = repr ty in - if ty.level > level then begin - if is_Tvar ty && ty.level >= generic_level - 1 then raise Occur; - ty.level <- pivot_level - ty.level; - iter_type_expr occur ty - end + let lv = get_level ty in + if lv <= level then () else + if is_Tvar ty && lv >= generic_level - 1 then raise Occur else + if try_mark_node ty then iter_type_expr occur ty in begin try occur ty; unmark_type ty with Occur -> - unmark_type ty; raise (Unify []) + unmark_type ty; raise_unexplained_for Moregen end; (* also check for free univars *) - occur_univar env ty; - update_level env level ty + occur_univar_for Moregen env ty; + update_level_for Moregen env level ty type moregen_pairs = { invariant_pairs : TypePairs.t; @@ -3405,29 +3816,28 @@ let relevant_pairs pairs v = let moregen_alloc_mode v a1 a2 = match match v with - | Invariant -> Btype.Alloc_mode.equate a1 a2 - | Covariant -> Btype.Alloc_mode.submode a1 a2 - | Contravariant -> Btype.Alloc_mode.submode a2 a1 + | Invariant -> Alloc_mode.equate a1 a2 + | Covariant -> Alloc_mode.submode a1 a2 + | Contravariant -> Alloc_mode.submode a2 a1 | Bivariant -> Ok () with | Ok () -> () - | Error () -> raise (Unify []) + | Error () -> raise_unexplained_for Moregen let may_instantiate inst_nongen t1 = - if inst_nongen then t1.level <> generic_level - 1 - else t1.level = generic_level + let level = get_level t1 in + if inst_nongen then level <> generic_level - 1 + else level = generic_level let rec moregen inst_nongen variance type_pairs env t1 t2 = - if t1 == t2 then () else - let t1 = repr t1 in - let t2 = repr t2 in - if t1 == t2 then () else + if eq_type t1 t2 then () else + try - match (t1.desc, t2.desc) with + match (get_desc t1, get_desc t2) with (Tvar _, _) when may_instantiate inst_nongen t1 -> - moregen_occur env t1.level t2; - update_scope t1.scope t2; - occur env t1 t2; + moregen_occur env (get_level t1) t2; + update_scope_for Moregen (get_scope t1) t2; + occur_for Moregen env t1 t2; link_type t1 t2 | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> () @@ -3435,15 +3845,14 @@ let rec moregen inst_nongen variance type_pairs env t1 t2 = let t1' = expand_head env t1 in let t2' = expand_head env t2 in (* Expansion may have changed the representative of the types... *) - let t1' = repr t1' and t2' = repr t2' in - if t1' == t2' then () else + if eq_type t1' t2' then () else let pairs = relevant_pairs type_pairs variance in if not (TypePairs.mem pairs (t1', t2')) then begin TypePairs.add pairs (t1', t2'); - match (t1'.desc, t2'.desc) with + match (get_desc t1', get_desc t2') with (Tvar _, _) when may_instantiate inst_nongen t1' -> - moregen_occur env t1'.level t2; - update_scope t1'.scope t2; + moregen_occur env (get_level t1') t2; + update_scope_for Moregen (get_scope t1') t2; link_type t1' t2 | (Tarrow ((l1,a1,r1), t1, u1, _), Tarrow ((l2,a2,r2), t2, u2, _)) when @@ -3468,36 +3877,40 @@ let rec moregen inst_nongen variance type_pairs env t1 t2 = | exception Not_found -> moregen_list inst_nongen Invariant type_pairs env tl1 tl2 end - | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) -> + | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> begin try - unify_package env - (moregen_list inst_nongen variance type_pairs env) - t1'.level p1 n1 tl1 t2'.level p2 n2 tl2 - with Not_found -> raise (Unify []) + unify_package env (moregen_list inst_nongen variance type_pairs env) + (get_level t1') p1 fl1 (get_level t2') p2 fl2 + with Not_found -> raise_unexplained_for Moregen end + | (Tnil, Tconstr _ ) -> raise_for Moregen (Obj (Abstract_row Second)) + | (Tconstr _, Tnil ) -> raise_for Moregen (Obj (Abstract_row First)) | (Tvariant row1, Tvariant row2) -> moregen_row inst_nongen variance type_pairs env row1 row2 | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) -> moregen_fields inst_nongen variance type_pairs env fi1 fi2 | (Tfield _, Tfield _) -> (* Actually unused *) - moregen_fields inst_nongen variance type_pairs env t1' t2' + moregen_fields inst_nongen variance type_pairs env + t1' t2' | (Tnil, Tnil) -> () | (Tpoly (t1, []), Tpoly (t2, [])) -> moregen inst_nongen variance type_pairs env t1 t2 | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> - enter_poly env univar_pairs t1 tl1 t2 tl2 + enter_poly_for Moregen env univar_pairs t1 tl1 t2 tl2 (moregen inst_nongen variance type_pairs env) | (Tunivar _, Tunivar _) -> - unify_univar t1' t2' !univar_pairs + unify_univar_for Moregen t1' t2' !univar_pairs | (_, _) -> - raise (Unify []) + raise_unexplained_for Moregen end - with Unify trace -> raise( Unify ( Trace.diff t1 t2 :: trace ) ) + with Moregen_trace trace -> + raise_trace_for Moregen (Diff {got = t1; expected = t2} :: trace) + and moregen_list inst_nongen variance type_pairs env tl1 tl2 = if List.length tl1 <> List.length tl2 then - raise (Unify []); + raise_unexplained_for Moregen; List.iter2 (moregen inst_nongen variance type_pairs env) tl1 tl2 and moregen_param_list inst_nongen variance type_pairs env vl tl1 tl2 = @@ -3507,101 +3920,152 @@ and moregen_param_list inst_nongen variance type_pairs env vl tl1 tl2 = let param_variance = compose_variance variance v in moregen inst_nongen param_variance type_pairs env t1 t2; moregen_param_list inst_nongen variance type_pairs env vl tl1 tl2 - | _, _, _ -> raise (Unify []) + | _, _, _ -> raise_unexplained_for Moregen and moregen_fields inst_nongen variance type_pairs env ty1 ty2 = let (fields1, rest1) = flatten_fields ty1 and (fields2, rest2) = flatten_fields ty2 in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in - if miss1 <> [] then raise (Unify []); + begin + match miss1 with + | (n, _, _) :: _ -> raise_for Moregen (Obj (Missing_field (Second, n))) + | [] -> () + end; moregen inst_nongen variance type_pairs env rest1 - (build_fields (repr ty2).level miss2 rest2); + (build_fields (get_level ty2) miss2 rest2); List.iter - (fun (n, k1, t1, k2, t2) -> + (fun (name, k1, t1, k2, t2) -> + (* The below call should never throw [Public_method_to_private_method] *) moregen_kind k1 k2; - try moregen inst_nongen variance type_pairs env t1 t2 - with Unify trace -> - let e = Trace.diff - (newty (Tfield(n, k1, t1, rest2))) - (newty (Tfield(n, k2, t2, rest2))) in - raise( Unify ( e :: trace ) ) + try moregen inst_nongen variance type_pairs env t1 t2 with Moregen_trace trace -> + raise_trace_for Moregen + (incompatible_fields ~name ~got:t1 ~expected:t2 :: trace) ) pairs and moregen_kind k1 k2 = - let k1 = field_kind_repr k1 in - let k2 = field_kind_repr k2 in - if k1 == k2 then () else - match k1, k2 with - (Fvar r, (Fvar _ | Fpresent)) -> set_kind r k2 - | (Fpresent, Fpresent) -> () - | _ -> raise (Unify []) + match field_kind_repr k1, field_kind_repr k2 with + (Fprivate, (Fprivate | Fpublic)) -> link_kind ~inside:k1 k2 + | (Fpublic, Fpublic) -> () + | (Fpublic, Fprivate) -> raise Public_method_to_private_method + | (Fabsent, _) | (_, Fabsent) -> assert false and moregen_row inst_nongen variance type_pairs env row1 row2 = - let row1 = row_repr row1 and row2 = row_repr row2 in - let rm1 = repr row1.row_more and rm2 = repr row2.row_more in - if rm1 == rm2 then () else + let Row {fields = row1_fields; more = rm1; closed = row1_closed} = + row_repr row1 in + let Row {fields = row2_fields; more = rm2; closed = row2_closed; + fixed = row2_fixed} = row_repr row2 in + if eq_type rm1 rm2 then () else let may_inst = - is_Tvar rm1 && may_instantiate inst_nongen rm1 || rm1.desc = Tnil in - let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in + is_Tvar rm1 && may_instantiate inst_nongen rm1 || get_desc rm1 = Tnil in + let r1, r2, pairs = merge_row_fields row1_fields row2_fields in let r1, r2 = - if row2.row_closed then + if row2_closed then filter_row_fields may_inst r1, filter_row_fields false r2 else r1, r2 in - if r1 <> [] || row1.row_closed && (not row2.row_closed || r2 <> []) - then raise (Unify []); - begin match rm1.desc, rm2.desc with + begin + if r1 <> [] then raise_for Moregen (Variant (No_tags (Second, r1))) + end; + if row1_closed then begin + match row2_closed, r2 with + | false, _ -> raise_for Moregen (Variant (Openness Second)) + | _, _ :: _ -> raise_for Moregen (Variant (No_tags (First, r2))) + | _, [] -> () + end; + let md1 = get_desc rm1 (* This lets us undo a following [link_type] *) in + begin match md1, get_desc rm2 with Tunivar _, Tunivar _ -> - unify_univar rm1 rm2 !univar_pairs + unify_univar_for Moregen rm1 rm2 !univar_pairs | Tunivar _, _ | _, Tunivar _ -> - raise (Unify []) + raise_unexplained_for Moregen | _ when static_row row1 -> () | _ when may_inst -> let ext = - newgenty (Tvariant {row2 with row_fields = r2; row_name = None}) + newgenty (Tvariant + (create_row ~fields:r2 ~more:rm2 ~name:None + ~fixed:row2_fixed ~closed:row2_closed)) in - moregen_occur env rm1.level ext; - update_scope rm1.scope ext; + moregen_occur env (get_level rm1) ext; + update_scope_for Moregen (get_scope rm1) ext; + (* This [link_type] has to be undone if the rest of the function fails *) link_type rm1 ext | Tconstr _, Tconstr _ -> moregen inst_nongen variance type_pairs env rm1 rm2 - | _ -> raise (Unify []) + | _ -> raise_unexplained_for Moregen end; - List.iter - (fun (_l,f1,f2) -> - let f1 = row_field_repr f1 and f2 = row_field_repr f2 in - if f1 == f2 then () else - match f1, f2 with - Rpresent(Some t1), Rpresent(Some t2) -> - moregen inst_nongen variance type_pairs env t1 t2 - | Rpresent None, Rpresent None -> () - | Reither(false, tl1, _, e1), Rpresent(Some t2) when may_inst -> - set_row_field e1 f2; - List.iter - (fun t1 -> moregen inst_nongen variance type_pairs env t1 t2) - tl1 - | Reither(c1, tl1, _, e1), Reither(c2, tl2, m2, e2) -> - if e1 != e2 then begin - if c1 && not c2 then raise(Unify []); - set_row_field e1 (Reither (c2, [], m2, e2)); - if List.length tl1 = List.length tl2 then - List.iter2 (moregen inst_nongen variance type_pairs env) tl1 tl2 - else match tl2 with - t2 :: _ -> - List.iter - (fun t1 -> moregen inst_nongen variance type_pairs env t1 t2) - tl1 - | [] -> - if tl1 <> [] then raise (Unify []) - end - | Reither(true, [], _, e1), Rpresent None when may_inst -> - set_row_field e1 f2 - | Reither(_, _, _, e1), Rabsent when may_inst -> - set_row_field e1 f2 - | Rabsent, Rabsent -> () - | _ -> raise (Unify [])) - pairs + try + List.iter + (fun (l,f1,f2) -> + if f1 == f2 then () else + match row_field_repr f1, row_field_repr f2 with + (* Both matching [Rpresent]s *) + | Rpresent(Some t1), Rpresent(Some t2) -> begin + try + moregen inst_nongen variance type_pairs env t1 t2 + with Moregen_trace trace -> + raise_trace_for Moregen + (Variant (Incompatible_types_for l) :: trace) + end + | Rpresent None, Rpresent None -> () + (* Both [Reither] *) + | Reither(c1, tl1, _), Reither(c2, tl2, m2) -> begin + try + if not (eq_row_field_ext f1 f2) then begin + if c1 && not c2 then raise_unexplained_for Moregen; + let f2' = + rf_either [] ~use_ext_of:f2 ~no_arg:c2 ~matched:m2 in + link_row_field_ext ~inside:f1 f2'; + if List.length tl1 = List.length tl2 then + List.iter2 (moregen inst_nongen variance type_pairs env) tl1 tl2 + else match tl2 with + | t2 :: _ -> + List.iter + (fun t1 -> moregen inst_nongen variance type_pairs env t1 t2) + tl1 + | [] -> if tl1 <> [] then raise_unexplained_for Moregen + end + with Moregen_trace trace -> + raise_trace_for Moregen + (Variant (Incompatible_types_for l) :: trace) + end + (* Generalizing [Reither] *) + | Reither(false, tl1, _), Rpresent(Some t2) when may_inst -> begin + try + link_row_field_ext ~inside:f1 f2; + List.iter + (fun t1 -> moregen inst_nongen variance type_pairs env t1 t2) + tl1 + with Moregen_trace trace -> + raise_trace_for Moregen + (Variant (Incompatible_types_for l) :: trace) + end + | Reither(true, [], _), Rpresent None when may_inst -> + link_row_field_ext ~inside:f1 f2 + | Reither(_, _, _), Rabsent when may_inst -> + link_row_field_ext ~inside:f1 f2 + (* Both [Rabsent]s *) + | Rabsent, Rabsent -> () + (* Mismatched constructor arguments *) + | Rpresent (Some _), Rpresent None + | Rpresent None, Rpresent (Some _) -> + raise_for Moregen (Variant (Incompatible_types_for l)) + (* Mismatched presence *) + | Reither _, Rpresent _ -> + raise_for Moregen + (Variant (Presence_not_guaranteed_for (First, l))) + | Rpresent _, Reither _ -> + raise_for Moregen + (Variant (Presence_not_guaranteed_for (Second, l))) + (* Missing tags *) + | Rabsent, (Rpresent _ | Reither _) -> + raise_for Moregen (Variant (No_tags (First, [l, f2]))) + | (Rpresent _ | Reither _), Rabsent -> + raise_for Moregen (Variant (No_tags (Second, [l, f1])))) + pairs + with exn -> + (* Undo [link_type] if we failed *) + set_type_desc rm1 md1; raise exn (* Non-generic variable can be instantiated only if [inst_nongen] is @@ -3620,78 +4084,101 @@ let moregeneral env inst_nongen pat_sch subj_sch = then copied with [duplicate_type]. That way, its levels won't be changed. *) - let subj = duplicate_type (instance subj_sch) in + let subj_inst = instance subj_sch in + let subj = duplicate_type subj_inst in current_level := generic_level; (* Duplicate generic variables *) let patt = instance pat_sch in - let res = - univar_pairs := []; - let type_pairs = fresh_moregen_pairs () in - match moregen inst_nongen Covariant type_pairs env patt subj with - | () -> true - | exception Unify _ -> false - in - current_level := old_level; - res - -let moregen inst_nongen type_pairs env patt subj = - univar_pairs := []; - moregen inst_nongen Invariant type_pairs env patt subj - + Misc.try_finally + (fun () -> + try + univar_pairs := []; + let type_pairs = fresh_moregen_pairs () in + moregen inst_nongen Covariant type_pairs env patt subj + with Moregen_trace trace -> + (* Moregen splits the generic level into two finer levels: + [generic_level] and [generic_level - 1]. In order to properly + detect and print weak variables when printing this error, we need to + merge them back together, by regeneralizing the levels of the types + after they were instantiated at [generic_level - 1] above. Because + [moregen] does some unification that we need to preserve for more + legible error messages, we have to manually perform the + regeneralization rather than backtracking. *) + current_level := generic_level - 2; + generalize subj_inst; + raise (Moregen (expand_to_moregen_error env trace))) + ~always:(fun () -> current_level := old_level) + +let is_moregeneral env inst_nongen pat_sch subj_sch = + match moregeneral env inst_nongen pat_sch subj_sch with + | () -> true + | exception Moregen _ -> false (* Alternative approach: "rigidify" a type scheme, and check validity after unification *) (* Simpler, no? *) let rec rigidify_rec vars ty = - let ty = repr ty in - if ty.level >= lowest_level then begin - ty.level <- pivot_level - ty.level; - match ty.desc with + if try_mark_node ty then + begin match get_desc ty with | Tvar _ -> - if not (List.memq ty !vars) then vars := ty :: !vars + if not (TypeSet.mem ty !vars) then vars := TypeSet.add ty !vars | Tvariant row -> - let row = row_repr row in - let more = repr row.row_more in - if is_Tvar more && not (row_fixed row) then begin - let more' = newty2 more.level more.desc in + let Row {more; name; closed} = row_repr row in + if is_Tvar more && not (has_fixed_explanation row) then begin + let more' = newty2 ~level:(get_level more) (get_desc more) in let row' = - {row with row_fixed=Some Rigid; row_fields=[]; row_more=more'} - in link_type more (newty2 ty.level (Tvariant row')) + create_row ~fixed:(Some Rigid) ~fields:[] ~more:more' + ~name ~closed + in link_type more (newty2 ~level:(get_level ty) (Tvariant row')) end; iter_row (rigidify_rec vars) row; (* only consider the row variable if the variant is not static *) - if not (static_row row) then rigidify_rec vars (row_more row) + if not (static_row row) then + rigidify_rec vars (row_more row) | _ -> iter_type_expr (rigidify_rec vars) ty - end + end let rigidify ty = - let vars = ref [] in + let vars = ref TypeSet.empty in rigidify_rec vars ty; unmark_type ty; - !vars + TypeSet.elements !vars let all_distinct_vars env vars = - let tyl = ref [] in + let tys = ref TypeSet.empty in List.for_all (fun ty -> let ty = expand_head env ty in - if List.memq ty !tyl then false else - (tyl := ty :: !tyl; is_Tvar ty)) + if TypeSet.mem ty !tys then false else + (tys := TypeSet.add ty !tys; is_Tvar ty)) vars -let matches env ty ty' = +let matches ~expand_error_trace env ty ty' = let snap = snapshot () in let vars = rigidify ty in cleanup_abbrev (); - let ok = - try unify env ty ty'; all_distinct_vars env vars - with Unify _ -> false - in - backtrack snap; - ok + match unify env ty ty' with + | () -> + if not (all_distinct_vars env vars) then begin + backtrack snap; + let diff = + if expand_error_trace + then expanded_diff env ~got:ty ~expected:ty' + else unexpanded_diff ~got:ty ~expected:ty' + in + raise (Matches_failure (env, unification_error ~trace:[diff])) + end; + backtrack snap + | exception Unify err -> + backtrack snap; + raise (Matches_failure (env, err)) +let does_match env ty ty' = + match matches ~expand_error_trace:false env ty ty' with + | () -> true + | exception Matches_failure (_, _) -> false (*********************************************) (* Equivalence between parameterized types *) @@ -3703,48 +4190,39 @@ let expand_head_rigid env ty = let ty' = expand_head env ty in rigid_variants := old; ty' -let normalize_subst subst = +let eqtype_subst type_pairs subst t1 t2 = if List.exists - (function {desc=Tlink _}, _ | _, {desc=Tlink _} -> true | _ -> false) + (fun (t,t') -> + let found1 = eq_type t1 t in + let found2 = eq_type t2 t' in + if found1 && found2 then true else + if found1 || found2 then raise_unexplained_for Equality else false) !subst - then subst := List.map (fun (t1,t2) -> repr t1, repr t2) !subst + then () + else begin + subst := (t1, t2) :: !subst; + TypePairs.add type_pairs (t1, t2) + end let rec eqtype rename type_pairs subst env t1 t2 = - if t1 == t2 then () else - let t1 = repr t1 in - let t2 = repr t2 in - if t1 == t2 then () else + if eq_type t1 t2 then () else try - match (t1.desc, t2.desc) with + match (get_desc t1, get_desc t2) with (Tvar _, Tvar _) when rename -> - begin try - normalize_subst subst; - if List.assq t1 !subst != t2 then raise (Unify []) - with Not_found -> - if List.exists (fun (_, t) -> t == t2) !subst then raise (Unify []); - subst := (t1, t2) :: !subst - end + eqtype_subst type_pairs subst t1 t2 | (Tconstr (p1, [], _), Tconstr (p2, [], _)) when Path.same p1 p2 -> () | _ -> let t1' = expand_head_rigid env t1 in let t2' = expand_head_rigid env t2 in (* Expansion may have changed the representative of the types... *) - let t1' = repr t1' and t2' = repr t2' in - if t1' == t2' then () else + if eq_type t1' t2' then () else if not (TypePairs.mem type_pairs (t1', t2')) then begin TypePairs.add type_pairs (t1', t2'); - match (t1'.desc, t2'.desc) with + match (get_desc t1', get_desc t2') with (Tvar _, Tvar _) when rename -> - begin try - normalize_subst subst; - if List.assq t1' !subst != t2' then raise (Unify []) - with Not_found -> - if List.exists (fun (_, t) -> t == t2') !subst - then raise (Unify []); - subst := (t1', t2') :: !subst - end + eqtype_subst type_pairs subst t1' t2' | (Tarrow ((l1,a1,r1), t1, u1, _), Tarrow ((l2,a2,r2), t2, u2, _)) when (l1 = l2 @@ -3758,35 +4236,41 @@ let rec eqtype rename type_pairs subst env t1 t2 = | (Tconstr (p1, tl1, _), Tconstr (p2, tl2, _)) when Path.same p1 p2 -> eqtype_list rename type_pairs subst env tl1 tl2 - | (Tpackage (p1, n1, tl1), Tpackage (p2, n2, tl2)) -> + | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> begin try unify_package env (eqtype_list rename type_pairs subst env) - t1'.level p1 n1 tl1 t2'.level p2 n2 tl2 - with Not_found -> raise (Unify []) + (get_level t1') p1 fl1 (get_level t2') p2 fl2 + with Not_found -> raise_unexplained_for Equality end + | (Tnil, Tconstr _ ) -> + raise_for Equality (Obj (Abstract_row Second)) + | (Tconstr _, Tnil ) -> + raise_for Equality (Obj (Abstract_row First)) | (Tvariant row1, Tvariant row2) -> eqtype_row rename type_pairs subst env row1 row2 | (Tobject (fi1, _nm1), Tobject (fi2, _nm2)) -> eqtype_fields rename type_pairs subst env fi1 fi2 | (Tfield _, Tfield _) -> (* Actually unused *) - eqtype_fields rename type_pairs subst env t1' t2' + eqtype_fields rename type_pairs subst env + t1' t2' | (Tnil, Tnil) -> () | (Tpoly (t1, []), Tpoly (t2, [])) -> eqtype rename type_pairs subst env t1 t2 | (Tpoly (t1, tl1), Tpoly (t2, tl2)) -> - enter_poly env univar_pairs t1 tl1 t2 tl2 + enter_poly_for Equality env univar_pairs t1 tl1 t2 tl2 (eqtype rename type_pairs subst env) | (Tunivar _, Tunivar _) -> - unify_univar t1' t2' !univar_pairs + unify_univar_for Equality t1' t2' !univar_pairs | (_, _) -> - raise (Unify []) + raise_unexplained_for Equality end - with Unify trace -> raise ( Unify (Trace.diff t1 t2 :: trace) ) + with Equality_trace trace -> + raise_trace_for Equality (Diff {got = t1; expected = t2} :: trace) and eqtype_list rename type_pairs subst env tl1 tl2 = if List.length tl1 <> List.length tl2 then - raise (Unify []); + raise_unexplained_for Equality; List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 and eqtype_fields rename type_pairs subst env ty1 ty2 = @@ -3794,74 +4278,123 @@ and eqtype_fields rename type_pairs subst env ty1 ty2 = let (fields2, rest2) = flatten_fields ty2 in (* First check if same row => already equal *) let same_row = - rest1 == rest2 || TypePairs.mem type_pairs (rest1,rest2) || - (rename && List.mem (rest1, rest2) !subst) + eq_type rest1 rest2 || TypePairs.mem type_pairs (rest1,rest2) in if same_row then () else (* Try expansion, needed when called from Includecore.type_manifest *) - match expand_head_rigid env rest2 with - {desc=Tobject(ty2,_)} -> eqtype_fields rename type_pairs subst env ty1 ty2 + match get_desc (expand_head_rigid env rest2) with + Tobject(ty2,_) -> eqtype_fields rename type_pairs subst env ty1 ty2 | _ -> let (pairs, miss1, miss2) = associate_fields fields1 fields2 in eqtype rename type_pairs subst env rest1 rest2; - if (miss1 <> []) || (miss2 <> []) then raise (Unify []); - List.iter - (function (n, k1, t1, k2, t2) -> - eqtype_kind k1 k2; - try eqtype rename type_pairs subst env t1 t2 with Unify trace -> - let e = Trace.diff - (newty (Tfield(n, k1, t1, rest2))) - (newty (Tfield(n, k2, t2, rest2))) in - raise ( Unify ( e :: trace ) ) - ) - pairs + match miss1, miss2 with + | ((n, _, _)::_, _) -> raise_for Equality (Obj (Missing_field (Second, n))) + | (_, (n, _, _)::_) -> raise_for Equality (Obj (Missing_field (First, n))) + | [], [] -> + List.iter + (function (name, k1, t1, k2, t2) -> + eqtype_kind k1 k2; + try + eqtype rename type_pairs subst env t1 t2; + with Equality_trace trace -> + raise_trace_for Equality + (incompatible_fields ~name ~got:t1 ~expected:t2 :: trace)) + pairs and eqtype_kind k1 k2 = let k1 = field_kind_repr k1 in let k2 = field_kind_repr k2 in match k1, k2 with - (Fvar _, Fvar _) - | (Fpresent, Fpresent) -> () - | _ -> raise (Unify []) + | (Fprivate, Fprivate) + | (Fpublic, Fpublic) -> () + | _ -> raise_unexplained_for Unify + (* It's probably not possible to hit this case with + real OCaml code *) and eqtype_row rename type_pairs subst env row1 row2 = (* Try expansion, needed when called from Includecore.type_manifest *) - match expand_head_rigid env (row_more row2) with - {desc=Tvariant row2} -> eqtype_row rename type_pairs subst env row1 row2 + match get_desc (expand_head_rigid env (row_more row2)) with + Tvariant row2 -> eqtype_row rename type_pairs subst env row1 row2 | _ -> - let row1 = row_repr row1 and row2 = row_repr row2 in - let r1, r2, pairs = merge_row_fields row1.row_fields row2.row_fields in - if row1.row_closed <> row2.row_closed - || not row1.row_closed && (r1 <> [] || r2 <> []) - || filter_row_fields false (r1 @ r2) <> [] - then raise (Unify []); + let r1, r2, pairs = merge_row_fields (row_fields row1) (row_fields row2) in + if row_closed row1 <> row_closed row2 then begin + raise_for Equality + (Variant (Openness (if row_closed row2 then First else Second))) + end; + if not (row_closed row1) then begin + match r1, r2 with + | _::_, _ -> raise_for Equality (Variant (No_tags (Second, r1))) + | _, _::_ -> raise_for Equality (Variant (No_tags (First, r2))) + | _, _ -> () + end; + begin + match filter_row_fields false r1 with + | [] -> (); + | _ :: _ as r1 -> raise_for Equality (Variant (No_tags (Second, r1))) + end; + begin + match filter_row_fields false r2 with + | [] -> () + | _ :: _ as r2 -> raise_for Equality (Variant (No_tags (First, r2))) + end; if not (static_row row1) then - eqtype rename type_pairs subst env row1.row_more row2.row_more; + eqtype rename type_pairs subst env (row_more row1) (row_more row2); List.iter - (fun (_,f1,f2) -> - match row_field_repr f1, row_field_repr f2 with - Rpresent(Some t1), Rpresent(Some t2) -> - eqtype rename type_pairs subst env t1 t2 - | Reither(c1, [], _, _), Reither(c2, [], _, _) when c1 = c2 -> - () - | Reither(c1, t1::tl1, _, _), Reither(c2, t2::tl2, _, _) when c1 = c2 -> - eqtype rename type_pairs subst env t1 t2; - if List.length tl1 = List.length tl2 then - (* if same length allow different types (meaning?) *) - List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 - else begin - (* otherwise everything must be equal *) - List.iter (eqtype rename type_pairs subst env t1) tl2; - List.iter (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1 - end - | Rpresent None, Rpresent None -> () - | Rabsent, Rabsent -> () - | _ -> raise (Unify [])) + (fun (l,f1,f2) -> + if f1 == f2 then () else + match row_field_repr f1, row_field_repr f2 with + (* Both matching [Rpresent]s *) + | Rpresent(Some t1), Rpresent(Some t2) -> begin + try + eqtype rename type_pairs subst env t1 t2 + with Equality_trace trace -> + raise_trace_for Equality + (Variant (Incompatible_types_for l) :: trace) + end + | Rpresent None, Rpresent None -> () + (* Both matching [Reither]s *) + | Reither(c1, [], _), Reither(c2, [], _) when c1 = c2 -> () + | Reither(c1, t1::tl1, _), Reither(c2, t2::tl2, _) + when c1 = c2 -> begin + try + eqtype rename type_pairs subst env t1 t2; + if List.length tl1 = List.length tl2 then + (* if same length allow different types (meaning?) *) + List.iter2 (eqtype rename type_pairs subst env) tl1 tl2 + else begin + (* otherwise everything must be equal *) + List.iter (eqtype rename type_pairs subst env t1) tl2; + List.iter + (fun t1 -> eqtype rename type_pairs subst env t1 t2) tl1 + end + with Equality_trace trace -> + raise_trace_for Equality + (Variant (Incompatible_types_for l) :: trace) + end + (* Both [Rabsent]s *) + | Rabsent, Rabsent -> () + (* Mismatched constructor arguments *) + | Rpresent (Some _), Rpresent None + | Rpresent None, Rpresent (Some _) + | Reither _, Reither _ -> + raise_for Equality (Variant (Incompatible_types_for l)) + (* Mismatched presence *) + | Reither _, Rpresent _ -> + raise_for Equality + (Variant (Presence_not_guaranteed_for (First, l))) + | Rpresent _, Reither _ -> + raise_for Equality + (Variant (Presence_not_guaranteed_for (Second, l))) + (* Missing tags *) + | Rabsent, (Rpresent _ | Reither _) -> + raise_for Equality (Variant (No_tags (First, [l, f2]))) + | (Rpresent _ | Reither _), Rabsent -> + raise_for Equality (Variant (No_tags (Second, [l, f1])))) pairs and eqtype_alloc_mode m1 m2 = (* FIXME implement properly *) - unify_alloc_mode m1 m2 + unify_alloc_mode_for Equality m1 m2 (* Must empty univar_pairs first *) let eqtype_list rename type_pairs subst env tl1 tl2 = @@ -3876,25 +4409,36 @@ let eqtype rename type_pairs subst env t1 t2 = (* Two modes: with or without renaming of variables *) let equal env rename tyl1 tyl2 = - try - eqtype_list rename (TypePairs.create 11) (ref []) env tyl1 tyl2; true - with - Unify _ -> false - + let subst = ref [] in + try eqtype_list rename (TypePairs.create 11) subst env tyl1 tyl2 + with Equality_trace trace -> + raise (Equality (expand_to_equality_error env trace !subst)) + +let is_equal env rename tyl1 tyl2 = + match equal env rename tyl1 tyl2 with + | () -> true + | exception Equality _ -> false + +let rec equal_private env params1 ty1 params2 ty2 = + match equal env true (params1 @ [ty1]) (params2 @ [ty2]) with + | () -> () + | exception (Equality _ as err) -> + match try_expand_safe_opt env (expand_head env ty1) with + | ty1' -> equal_private env params1 ty1' params2 ty2 + | exception Cannot_expand -> raise err (*************************) (* Class type matching *) (*************************) - type class_match_failure = CM_Virtual_class | CM_Parameter_arity_mismatch of int * int - | CM_Type_parameter_mismatch of Env.t * Unification_trace.t + | CM_Type_parameter_mismatch of Env.t * equality_error | CM_Class_type_mismatch of Env.t * class_type * class_type - | CM_Parameter_mismatch of Env.t * Unification_trace.t - | CM_Val_type_mismatch of string * Env.t * Unification_trace.t - | CM_Meth_type_mismatch of string * Env.t * Unification_trace.t + | CM_Parameter_mismatch of Env.t * moregen_error + | CM_Val_type_mismatch of string * Env.t * comparison_error + | CM_Meth_type_mismatch of string * Env.t * comparison_error | CM_Non_mutable_value of string | CM_Non_concrete_value of string | CM_Missing_value of string @@ -3907,271 +4451,238 @@ type class_match_failure = exception Failure of class_match_failure list +let match_class_sig_shape ~strict sign1 sign2 = + let errors = + Meths.fold + (fun lab (priv, vr, _) err -> + match Meths.find lab sign1.csig_meths with + | exception Not_found -> CM_Missing_method lab::err + | (priv', vr', _) -> + match priv', priv with + | Mpublic, Mprivate _ -> CM_Public_method lab::err + | Mprivate _, Mpublic when strict -> CM_Private_method lab::err + | _, _ -> + match vr', vr with + | Virtual, Concrete -> CM_Virtual_method lab::err + | _, _ -> err) + sign2.csig_meths [] + in + let errors = + Meths.fold + (fun lab (priv, vr, _) err -> + if Meths.mem lab sign2.csig_meths then err + else begin + let err = + match priv with + | Mpublic -> CM_Hide_public lab :: err + | Mprivate _ -> err + in + match vr with + | Virtual -> CM_Hide_virtual ("method", lab) :: err + | Concrete -> err + end) + sign1.csig_meths errors + in + let errors = + Vars.fold + (fun lab (mut, vr, _) err -> + match Vars.find lab sign1.csig_vars with + | exception Not_found -> CM_Missing_value lab::err + | (mut', vr', _) -> + match mut', mut with + | Immutable, Mutable -> CM_Non_mutable_value lab::err + | _, _ -> + match vr', vr with + | Virtual, Concrete -> CM_Non_concrete_value lab::err + | _, _ -> err) + sign2.csig_vars errors + in + Vars.fold + (fun lab (_,vr,_) err -> + if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then + CM_Hide_virtual ("instance variable", lab) :: err + else err) + sign1.csig_vars errors + let rec moregen_clty trace type_pairs env cty1 cty2 = try match cty1, cty2 with - Cty_constr (_, _, cty1), _ -> + | Cty_constr (_, _, cty1), _ -> moregen_clty true type_pairs env cty1 cty2 | _, Cty_constr (_, _, cty2) -> moregen_clty true type_pairs env cty1 cty2 | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when l1 = l2 -> - begin try moregen true type_pairs env ty1 ty2 with Unify trace -> - raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)]) + begin + try moregen true Covariant type_pairs env ty1 ty2 with Moregen_trace trace -> + raise (Failure [ + CM_Parameter_mismatch (env, expand_to_moregen_error env trace)]) end; moregen_clty false type_pairs env cty1' cty2' | Cty_signature sign1, Cty_signature sign2 -> - let ty1 = object_fields (repr sign1.csig_self) in - let ty2 = object_fields (repr sign2.csig_self) in - let (fields1, _rest1) = flatten_fields ty1 - and (fields2, _rest2) = flatten_fields ty2 in - let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in - List.iter - (fun (lab, _k1, t1, _k2, t2) -> - begin try moregen true type_pairs env t1 t2 with Unify trace -> - raise (Failure [CM_Meth_type_mismatch - (lab, env, expand_trace env trace)]) - end) - pairs; - Vars.iter - (fun lab (_mut, _v, ty) -> - let (_mut', _v', ty') = Vars.find lab sign1.csig_vars in - try moregen true type_pairs env ty' ty with Unify trace -> - raise (Failure [CM_Val_type_mismatch - (lab, env, expand_trace env trace)])) - sign2.csig_vars - | _ -> - raise (Failure []) + Meths.iter + (fun lab (_, _, ty) -> + match Meths.find lab sign1.csig_meths with + | exception Not_found -> + (* This function is only called after checking that + all methods in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match moregen true Covariant type_pairs env ty' ty with + | () -> () + | exception Moregen_trace trace -> + raise (Failure [ + CM_Meth_type_mismatch + (lab, + env, + Moregen_error + (expand_to_moregen_error env trace))])) + sign2.csig_meths; + Vars.iter + (fun lab (_, _, ty) -> + match Vars.find lab sign1.csig_vars with + | exception Not_found -> + (* This function is only called after checking that + all instance variables in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match moregen true Covariant type_pairs env ty' ty with + | () -> () + | exception Moregen_trace trace -> + raise (Failure [ + CM_Val_type_mismatch + (lab, + env, + Moregen_error + (expand_to_moregen_error env trace))])) + sign2.csig_vars + | _ -> + raise (Failure []) with Failure error when trace || error = [] -> raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error)) let match_class_types ?(trace=true) env pat_sch subj_sch = - let type_pairs = fresh_moregen_pairs () in - let old_level = !current_level in - current_level := generic_level - 1; - (* - Generic variables are first duplicated with [instance]. So, - their levels are lowered to [generic_level - 1]. The subject is - then copied with [duplicate_type]. That way, its levels won't be - changed. - *) - let (_, subj_inst) = instance_class [] subj_sch in - let subj = duplicate_class_type subj_inst in - current_level := generic_level; - (* Duplicate generic variables *) - let (_, patt) = instance_class [] pat_sch in - let res = - let sign1 = signature_of_class_type patt in - let sign2 = signature_of_class_type subj in - let t1 = repr sign1.csig_self in - let t2 = repr sign2.csig_self in - TypePairs.add type_pairs.invariant_pairs (t1, t2); - let (fields1, rest1) = flatten_fields (object_fields t1) - and (fields2, rest2) = flatten_fields (object_fields t2) in - let (pairs, miss1, miss2) = associate_fields fields1 fields2 in - let error = - List.fold_right - (fun (lab, k, _) err -> - let err = - let k = field_kind_repr k in - begin match k with - Fvar r -> set_kind r Fabsent; err - | _ -> CM_Hide_public lab::err - end - in - if lab = dummy_method || Concr.mem lab sign1.csig_concr then err - else CM_Hide_virtual ("method", lab) :: err) - miss1 [] - in - let missing_method = List.map (fun (m, _, _) -> m) miss2 in - let error = - (List.map (fun m -> CM_Missing_method m) missing_method) @ error - in - (* Always succeeds *) - moregen true type_pairs env rest1 rest2; - let error = - List.fold_right - (fun (lab, k1, _t1, k2, _t2) err -> - try moregen_kind k1 k2; err with - Unify _ -> CM_Public_method lab::err) - pairs error - in - let error = - Vars.fold - (fun lab (mut, vr, _ty) err -> - try - let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in - if mut = Mutable && mut' <> Mutable then - CM_Non_mutable_value lab::err - else if vr = Concrete && vr' <> Concrete then - CM_Non_concrete_value lab::err - else - err - with Not_found -> - CM_Missing_value lab::err) - sign2.csig_vars error - in - let error = - Vars.fold - (fun lab (_,vr,_) err -> - if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then - CM_Hide_virtual ("instance variable", lab) :: err - else err) - sign1.csig_vars error - in - let error = - List.fold_right - (fun e l -> - if List.mem e missing_method then l else CM_Virtual_method e::l) - (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr)) - error - in - match error with - [] -> - begin try - moregen_clty trace type_pairs env patt subj; - [] - with - Failure r -> r - end - | error -> - CM_Class_type_mismatch (env, patt, subj)::error - in - current_level := old_level; - res + let sign1 = signature_of_class_type pat_sch in + let sign2 = signature_of_class_type subj_sch in + let errors = match_class_sig_shape ~strict:false sign1 sign2 in + match errors with + | [] -> + let old_level = !current_level in + current_level := generic_level - 1; + (* + Generic variables are first duplicated with [instance]. So, + their levels are lowered to [generic_level - 1]. The subject is + then copied with [duplicate_type]. That way, its levels won't be + changed. + *) + let (_, subj_inst) = instance_class [] subj_sch in + let subj = duplicate_class_type subj_inst in + current_level := generic_level; + (* Duplicate generic variables *) + let (_, patt) = instance_class [] pat_sch in + let type_pairs = fresh_moregen_pairs () in + let sign1 = signature_of_class_type patt in + let sign2 = signature_of_class_type subj in + let self1 = sign1.csig_self in + let self2 = sign2.csig_self in + let row1 = sign1.csig_self_row in + let row2 = sign2.csig_self_row in + TypePairs.add type_pairs.invariant_pairs (self1, self2); + (* Always succeeds *) + moregen true Covariant type_pairs env row1 row2; + let res = + match moregen_clty trace type_pairs env patt subj with + | () -> [] + | exception Failure res -> + (* We've found an error. Moregen splits the generic level into two + finer levels: [generic_level] and [generic_level - 1]. In order + to properly detect and print weak variables when printing this + error, we need to merge them back together, by regeneralizing the + levels of the types after they were instantiated at + [generic_level - 1] above. Because [moregen] does some + unification that we need to preserve for more legible error + messages, we have to manually perform the regeneralization rather + than backtracking. *) + current_level := generic_level - 2; + generalize_class_type subj_inst; + res + in + current_level := old_level; + res + | errors -> + CM_Class_type_mismatch (env, pat_sch, subj_sch) :: errors -let rec equal_clty trace type_pairs subst env cty1 cty2 = +let equal_clsig trace type_pairs subst env sign1 sign2 = try - match cty1, cty2 with - Cty_constr (_, _, cty1), Cty_constr (_, _, cty2) -> - equal_clty true type_pairs subst env cty1 cty2 - | Cty_constr (_, _, cty1), _ -> - equal_clty true type_pairs subst env cty1 cty2 - | _, Cty_constr (_, _, cty2) -> - equal_clty true type_pairs subst env cty1 cty2 - | Cty_arrow (l1, ty1, cty1'), Cty_arrow (l2, ty2, cty2') when l1 = l2 -> - begin try eqtype true type_pairs subst env ty1 ty2 with Unify trace -> - raise (Failure [CM_Parameter_mismatch (env, expand_trace env trace)]) - end; - equal_clty false type_pairs subst env cty1' cty2' - | Cty_signature sign1, Cty_signature sign2 -> - let ty1 = object_fields (repr sign1.csig_self) in - let ty2 = object_fields (repr sign2.csig_self) in - let (fields1, _rest1) = flatten_fields ty1 - and (fields2, _rest2) = flatten_fields ty2 in - let (pairs, _miss1, _miss2) = associate_fields fields1 fields2 in - List.iter - (fun (lab, _k1, t1, _k2, t2) -> - begin try eqtype true type_pairs subst env t1 t2 with - Unify trace -> - raise (Failure [CM_Meth_type_mismatch - (lab, env, expand_trace env trace)]) - end) - pairs; - Vars.iter - (fun lab (_, _, ty) -> - let (_, _, ty') = Vars.find lab sign1.csig_vars in - try eqtype true type_pairs subst env ty' ty with Unify trace -> - raise (Failure [CM_Val_type_mismatch - (lab, env, expand_trace env trace)])) - sign2.csig_vars - | _ -> - raise - (Failure (if trace then [] - else [CM_Class_type_mismatch (env, cty1, cty2)])) + Meths.iter + (fun lab (_, _, ty) -> + match Meths.find lab sign1.csig_meths with + | exception Not_found -> + (* This function is only called after checking that + all methods in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match eqtype true type_pairs subst env ty' ty with + | () -> () + | exception Equality_trace trace -> + raise (Failure [ + CM_Meth_type_mismatch + (lab, + env, + Equality_error + (expand_to_equality_error env trace !subst))])) + sign2.csig_meths; + Vars.iter + (fun lab (_, _, ty) -> + match Vars.find lab sign1.csig_vars with + | exception Not_found -> + (* This function is only called after checking that + all instance variables in sign2 are present in sign1. *) + assert false + | (_, _, ty') -> + match eqtype true type_pairs subst env ty' ty with + | () -> () + | exception Equality_trace trace -> + raise (Failure [ + CM_Val_type_mismatch + (lab, + env, + Equality_error + (expand_to_equality_error env trace !subst))])) + sign2.csig_vars with Failure error when trace -> - raise (Failure (CM_Class_type_mismatch (env, cty1, cty2)::error)) + raise (Failure (CM_Class_type_mismatch + (env, Cty_signature sign1, Cty_signature sign2)::error)) let match_class_declarations env patt_params patt_type subj_params subj_type = - let type_pairs = TypePairs.create 53 in - let subst = ref [] in let sign1 = signature_of_class_type patt_type in let sign2 = signature_of_class_type subj_type in - let t1 = repr sign1.csig_self in - let t2 = repr sign2.csig_self in - TypePairs.add type_pairs (t1, t2); - let (fields1, rest1) = flatten_fields (object_fields t1) - and (fields2, rest2) = flatten_fields (object_fields t2) in - let (pairs, miss1, miss2) = associate_fields fields1 fields2 in - let error = - List.fold_right - (fun (lab, k, _) err -> - let err = - let k = field_kind_repr k in - begin match k with - Fvar _ -> err - | _ -> CM_Hide_public lab::err - end - in - if Concr.mem lab sign1.csig_concr then err - else CM_Hide_virtual ("method", lab) :: err) - miss1 [] - in - let missing_method = List.map (fun (m, _, _) -> m) miss2 in - let error = - (List.map (fun m -> CM_Missing_method m) missing_method) @ error - in - (* Always succeeds *) - eqtype true type_pairs subst env rest1 rest2; - let error = - List.fold_right - (fun (lab, k1, _t1, k2, _t2) err -> - let k1 = field_kind_repr k1 in - let k2 = field_kind_repr k2 in - match k1, k2 with - (Fvar _, Fvar _) - | (Fpresent, Fpresent) -> err - | (Fvar _, Fpresent) -> CM_Private_method lab::err - | (Fpresent, Fvar _) -> CM_Public_method lab::err - | _ -> assert false) - pairs error - in - let error = - Vars.fold - (fun lab (mut, vr, _ty) err -> - try - let (mut', vr', _ty') = Vars.find lab sign1.csig_vars in - if mut = Mutable && mut' <> Mutable then - CM_Non_mutable_value lab::err - else if vr = Concrete && vr' <> Concrete then - CM_Non_concrete_value lab::err - else - err - with Not_found -> - CM_Missing_value lab::err) - sign2.csig_vars error - in - let error = - Vars.fold - (fun lab (_,vr,_) err -> - if vr = Virtual && not (Vars.mem lab sign2.csig_vars) then - CM_Hide_virtual ("instance variable", lab) :: err - else err) - sign1.csig_vars error - in - let error = - List.fold_right - (fun e l -> - if List.mem e missing_method then l else CM_Virtual_method e::l) - (Concr.elements (Concr.diff sign2.csig_concr sign1.csig_concr)) - error - in - match error with - [] -> - begin try + let errors = match_class_sig_shape ~strict:true sign1 sign2 in + match errors with + | [] -> begin + try + let subst = ref [] in + let type_pairs = TypePairs.create 53 in + let self1 = sign1.csig_self in + let self2 = sign2.csig_self in + let row1 = sign1.csig_self_row in + let row2 = sign2.csig_self_row in + TypePairs.add type_pairs (self1, self2); + (* Always succeeds *) + eqtype true type_pairs subst env row1 row2; let lp = List.length patt_params in let ls = List.length subj_params in if lp <> ls then raise (Failure [CM_Parameter_arity_mismatch (lp, ls)]); List.iter2 (fun p s -> - try eqtype true type_pairs subst env p s with Unify trace -> - raise (Failure [CM_Type_parameter_mismatch - (env, expand_trace env trace)])) + try eqtype true type_pairs subst env p s with Equality_trace trace -> + raise (Failure + [CM_Type_parameter_mismatch + (env, expand_to_equality_error env trace !subst)])) patt_params subj_params; (* old code: equal_clty false type_pairs subst env patt_type subj_type; *) - equal_clty false type_pairs subst env - (Cty_signature sign1) (Cty_signature sign2); + equal_clsig false type_pairs subst env sign1 sign2; (* Use moregeneral for class parameters, need to recheck everything to keeps relationships (PR#4824) *) let clty_params = @@ -4179,9 +4690,8 @@ let match_class_declarations env patt_params patt_type subj_params subj_type = match_class_types ~trace:false env (clty_params patt_params patt_type) (clty_params subj_params subj_type) - with - Failure r -> r - end + with Failure r -> r + end | error -> error @@ -4205,7 +4715,13 @@ let pred_expand n = if n mod 2 = 0 && n > 0 then pred n else n let pred_enlarge n = if n mod 2 = 1 then pred n else n type change = Unchanged | Equiv | Changed -let collect l = List.fold_left (fun c1 (_, c2) -> max c1 c2) Unchanged l +let max_change c1 c2 = + match c1, c2 with + | _, Changed | Changed, _ -> Changed + | Equiv, _ | _, Equiv -> Equiv + | _ -> Unchanged + +let collect l = List.fold_left (fun c1 (_, c2) -> max_change c1 c2) Unchanged l let rec filter_visited = function [] -> [] @@ -4219,7 +4735,7 @@ let find_cltype_for_path env p = let cl_abbr = Env.find_hash_type p env in match cl_abbr.type_manifest with Some ty -> - begin match (repr ty).desc with + begin match get_desc ty with Tobject(_,{contents=Some(p',_)}) when Path.same p p' -> cl_abbr, ty | _ -> raise Not_found end @@ -4230,31 +4746,32 @@ let has_constr_row' env t = let build_submode posi m = if posi then begin - let m', changed = Btype.Alloc_mode.newvar_below m in + let m', changed = Alloc_mode.newvar_below m in let c = if changed then Changed else Unchanged in m', c end else begin - let m', changed = Btype.Alloc_mode.newvar_above m in + let m', changed = Alloc_mode.newvar_above m in let c = if changed then Changed else Unchanged in m', c end -let rec build_subtype env visited loops posi level t = - let t = repr t in - match t.desc with +let rec build_subtype env (visited : transient_expr list) + (loops : (int * type_expr) list) posi level t = + match get_desc t with Tvar _ -> if posi then try - let t' = List.assq t loops in + let t' = List.assq (get_id t) loops in warn := true; (t', Equiv) with Not_found -> (t, Unchanged) else (t, Unchanged) - | Tarrow((l,a,r) , t1, t2, _) -> - if memq_warn t visited then (t, Unchanged) else - let visited = t :: visited in + | Tarrow((l,a,r), t1, t2, _) -> + let tt = Transient_expr.repr t in + if memq_warn tt visited then (t, Unchanged) else + let visited = tt :: visited in let (t1', c1) = build_subtype env visited loops (not posi) level t1 in let (t2', c2) = build_subtype env visited loops posi level t2 in let (a', c3) = @@ -4263,12 +4780,14 @@ let rec build_subtype env visited loops posi level t = let (r', c4) = if level > 2 then build_submode posi r else r, Unchanged in - let c = max c1 (max c2 (max c3 c4)) in - if c > Unchanged then (newty (Tarrow((l,a',r'), t1', t2', Cok)), c) + let c = max_change c1 (max_change c2 (max_change c3 c4)) in + if c > Unchanged + then (newty (Tarrow((l,a',r'), t1', t2', commu_ok)), c) else (t, Unchanged) | Ttuple tlist -> - if memq_warn t visited then (t, Unchanged) else - let visited = t :: visited in + let tt = Transient_expr.repr t in + if memq_warn tt visited then (t, Unchanged) else + let visited = tt :: visited in let tlist' = List.map (build_subtype env visited loops posi level) tlist in @@ -4278,17 +4797,18 @@ let rec build_subtype env visited loops posi level t = | Tconstr(p, tl, abbrev) when level > 0 && generic_abbrev env p && safe_abbrev env t && not (has_constr_row' env t) -> - let t' = repr (expand_abbrev env t) in + let t' = expand_abbrev env t in let level' = pred_expand level in - begin try match t'.desc with + begin try match get_desc t' with Tobject _ when posi && not (opened_object t') -> let cl_abbr, body = find_cltype_for_path env p in let ty = - subst env !current_level Public abbrev None - cl_abbr.type_params tl body in - let ty = repr ty in + try + subst env !current_level Public abbrev None + cl_abbr.type_params tl body + with Cannot_subst -> assert false in let ty1, tl1 = - match ty.desc with + match get_desc ty with Tobject(ty1,{contents=Some(p',tl1)}) when Path.same p p' -> ty1, tl1 | _ -> raise Not_found @@ -4297,29 +4817,32 @@ let rec build_subtype env visited loops posi level t = as this occurrence might break the occur check. XXX not clear whether this correct anyway... *) if List.exists (deep_occur ty) tl1 then raise Not_found; - ty.desc <- Tvar None; + set_type_desc ty (Tvar None); let t'' = newvar () in - let loops = (ty, t'') :: loops in + let loops = (get_id ty, t'') :: loops in (* May discard [visited] as level is going down *) let (ty1', c) = - build_subtype env [t'] loops posi (pred_enlarge level') ty1 in + build_subtype env [Transient_expr.repr t'] + loops posi (pred_enlarge level') ty1 in assert (is_Tvar t''); let nm = if c > Equiv || deep_occur ty ty1' then None else Some(p,tl1) in - t''.desc <- Tobject (ty1', ref nm); + set_type_desc t'' (Tobject (ty1', ref nm)); (try unify_var env ty t with Unify _ -> assert false); - (t'', Changed) + ( t'', Changed) | _ -> raise Not_found with Not_found -> - let (t'',c) = build_subtype env visited loops posi level' t' in + let (t'',c) = + build_subtype env visited loops posi level' t' in if c > Unchanged then (t'',c) else (t, Unchanged) end | Tconstr(p, tl, _abbrev) -> (* Must check recursion on constructors, since we do not always expand them *) - if memq_warn t visited then (t, Unchanged) else - let visited = t :: visited in + let tt = Transient_expr.repr t in + if memq_warn tt visited then (t, Unchanged) else + let visited = tt :: visited in begin try let decl = Env.find_type p env in if level = 0 && generic_abbrev env p && safe_abbrev env t @@ -4344,50 +4867,51 @@ let rec build_subtype env visited loops posi level t = (t, Unchanged) end | Tvariant row -> - let row = row_repr row in - if memq_warn t visited || not (static_row row) then (t, Unchanged) else + let tt = Transient_expr.repr t in + if memq_warn tt visited || not (static_row row) then (t, Unchanged) else let level' = pred_enlarge level in let visited = - t :: if level' < level then [] else filter_visited visited in - let fields = filter_row_fields false row.row_fields in + tt :: if level' < level then [] else filter_visited visited in + let fields = filter_row_fields false (row_fields row) in let fields = List.map (fun (l,f as orig) -> match row_field_repr f with Rpresent None -> if posi then - (l, Reither(true, [], false, ref None)), Unchanged + (l, rf_either_of None), Unchanged else orig, Unchanged | Rpresent(Some t) -> let (t', c) = build_subtype env visited loops posi level' t in let f = if posi && level > 0 - then Reither(false, [t'], false, ref None) - else Rpresent(Some t') + then rf_either_of (Some t') + else rf_present (Some t') in (l, f), c | _ -> assert false) fields in let c = collect fields in let row = - { row_fields = List.map fst fields; row_more = newvar(); - row_bound = (); row_closed = posi; row_fixed = None; - row_name = if c > Unchanged then None else row.row_name } + create_row ~fields:(List.map fst fields) ~more:(newvar ()) + ~closed:posi ~fixed:None + ~name:(if c > Unchanged then None else row_name row) in (newty (Tvariant row), Changed) | Tobject (t1, _) -> - if memq_warn t visited || opened_object t1 then (t, Unchanged) else + let tt = Transient_expr.repr t in + if memq_warn tt visited || opened_object t1 then (t, Unchanged) else let level' = pred_enlarge level in let visited = - t :: if level' < level then [] else filter_visited visited in + tt :: if level' < level then [] else filter_visited visited in let (t1', c) = build_subtype env visited loops posi level' t1 in if c > Unchanged then (newty (Tobject (t1', ref None)), c) else (t, Unchanged) | Tfield(s, _, t1, t2) (* Always present *) -> let (t1', c1) = build_subtype env visited loops posi level t1 in let (t2', c2) = build_subtype env visited loops posi level t2 in - let c = max c1 c2 in - if c > Unchanged then (newty (Tfield(s, Fpresent, t1', t2')), c) + let c = max_change c1 c2 in + if c > Unchanged then (newty (Tfield(s, field_public, t1', t2')), c) else (t, Unchanged) | Tnil -> if posi then @@ -4430,34 +4954,43 @@ let enlarge_type env ty = let subtypes = TypePairs.create 17 -let subtype_error env trace = - raise (Subtype (expand_trace env (List.rev trace), [])) +let subtype_error ~env ~trace ~unification_trace = + raise (Subtype (Subtype.error + ~trace:(expand_subtype_trace env (List.rev trace)) + ~unification_trace)) let subtype_alloc_mode env trace a1 a2 = - match Btype.Alloc_mode.submode a1 a2 with + match Alloc_mode.submode a1 a2 with | Ok () -> () - | Error () -> subtype_error env trace + | Error () -> subtype_error ~env ~trace ~unification_trace:[] let rec subtype_rec env trace t1 t2 cstrs = - let t1 = repr t1 in - let t2 = repr t2 in - if t1 == t2 then cstrs else + if eq_type t1 t2 then cstrs else if TypePairs.mem subtypes (t1, t2) then cstrs else begin TypePairs.add subtypes (t1, t2); - match (t1.desc, t2.desc) with + match (get_desc t1, get_desc t2) with (Tvar _, _) | (_, Tvar _) -> (trace, t1, t2, !univar_pairs)::cstrs | (Tarrow((l1,a1,r1), t1, u1, _), - Tarrow((l2,a2,r2), t2, u2, _)) when - (l1 = l2 - || !Clflags.classic && not (is_optional l1 || is_optional l2)) -> - let cstrs = subtype_rec env (Trace.diff t2 t1::trace) t2 t1 cstrs in + Tarrow((l2,a2,r2), t2, u2, _)) when l1 = l2 + || !Clflags.classic && not (is_optional l1 || is_optional l2) -> + let cstrs = + subtype_rec + env + (Subtype.Diff {got = t2; expected = t1} :: trace) + t2 t1 + cstrs + in subtype_alloc_mode env trace a2 a1; subtype_alloc_mode env trace r1 r2; - subtype_rec env (Trace.diff u1 u2::trace) u1 u2 cstrs; + subtype_rec + env + (Subtype.Diff {got = u1; expected = u2} :: trace) + u1 u2 + cstrs | (Ttuple tl1, Ttuple tl2) -> subtype_list env trace tl1 tl2 cstrs | (Tconstr(p1, [], _), Tconstr(p2, [], _)) when Path.same p1 p2 -> @@ -4476,17 +5009,30 @@ let rec subtype_rec env trace t1 t2 cstrs = let (co, cn) = Variance.get_upper v in if co then if cn then - (trace, newty2 t1.level (Ttuple[t1]), - newty2 t2.level (Ttuple[t2]), !univar_pairs) :: cstrs - else subtype_rec env (Trace.diff t1 t2::trace) t1 t2 cstrs + (trace, newty2 ~level:(get_level t1) (Ttuple[t1]), + newty2 ~level:(get_level t2) (Ttuple[t2]), !univar_pairs) + :: cstrs + else + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs else - if cn then subtype_rec env (Trace.diff t2 t1::trace) t2 t1 cstrs + if cn + then + subtype_rec + env + (Subtype.Diff {got = t2; expected = t1} :: trace) + t2 t1 + cstrs else cstrs) cstrs decl.type_variance (List.combine tl1 tl2) with Not_found -> (trace, t1, t2, !univar_pairs)::cstrs end - | (Tconstr(p1, _, _), _) when generic_private_abbrev env p1 -> + | (Tconstr(p1, _, _), _) + when generic_private_abbrev env p1 && safe_abbrev_opt env t1 -> subtype_rec env trace (expand_abbrev_opt env t1) t2 cstrs (* | (_, Tconstr(p2, _, _)) when generic_private_abbrev false env p2 -> subtype_rec env trace t1 (expand_abbrev_opt env t2) cstrs *) @@ -4511,13 +5057,15 @@ let rec subtype_rec env trace t1 t2 cstrs = begin try enter_poly env univar_pairs u1 tl1 u2 tl2 (fun t1 t2 -> subtype_rec env trace t1 t2 cstrs) - with Unify _ -> + with Escape _ -> (trace, t1, t2, !univar_pairs)::cstrs end - | (Tpackage (p1, nl1, tl1), Tpackage (p2, nl2, tl2)) -> + | (Tpackage (p1, fl1), Tpackage (p2, fl2)) -> begin try - let ntl1 = complete_type_list env nl2 t1.level (Mty_ident p1) nl1 tl1 - and ntl2 = complete_type_list env nl1 t2.level (Mty_ident p2) nl2 tl2 + let ntl1 = + complete_type_list env fl2 (get_level t1) (Mty_ident p1) fl1 + and ntl2 = + complete_type_list env fl1 (get_level t2) (Mty_ident p2) fl2 ~allow_absent:true in let cstrs' = List.map @@ -4528,12 +5076,10 @@ let rec subtype_rec env trace t1 t2 cstrs = else begin (* need to check module subtyping *) let snap = Btype.snapshot () in - try - List.iter (fun (_, t1, t2, _) -> unify env t1 t2) cstrs'; - if !package_subtype env p1 nl1 tl1 p2 nl2 tl2 - then (Btype.backtrack snap; cstrs' @ cstrs) - else raise (Unify []) - with Unify _ -> + match List.iter (fun (_, t1, t2, _) -> unify env t1 t2) cstrs' with + | () when !package_subtype env p1 fl1 p2 fl2 -> + Btype.backtrack snap; cstrs' @ cstrs + | () | exception Unify _ -> Btype.backtrack snap; raise Not_found end with Not_found -> @@ -4545,9 +5091,14 @@ let rec subtype_rec env trace t1 t2 cstrs = and subtype_list env trace tl1 tl2 cstrs = if List.length tl1 <> List.length tl2 then - subtype_error env trace; + subtype_error ~env ~trace ~unification_trace:[]; List.fold_left2 - (fun cstrs t1 t2 -> subtype_rec env (Trace.diff t1 t2::trace) t1 t2 cstrs) + (fun cstrs t1 t2 -> + subtype_rec + env + (Subtype.Diff { got = t1; expected = t2 } :: trace) + t1 t2 + cstrs) cstrs tl1 tl2 and subtype_fields env trace ty1 ty2 cstrs = @@ -4556,63 +5107,93 @@ and subtype_fields env trace ty1 ty2 cstrs = let (fields2, rest2) = flatten_fields ty2 in let (pairs, miss1, miss2) = associate_fields fields1 fields2 in let cstrs = - if rest2.desc = Tnil then cstrs else + if get_desc rest2 = Tnil then cstrs else if miss1 = [] then - subtype_rec env (Trace.diff rest1 rest2::trace) rest1 rest2 cstrs + subtype_rec + env + (Subtype.Diff {got = rest1; expected = rest2} :: trace) + rest1 rest2 + cstrs else - (trace, build_fields (repr ty1).level miss1 rest1, rest2, + (trace, build_fields (get_level ty1) miss1 rest1, rest2, !univar_pairs) :: cstrs in let cstrs = if miss2 = [] then cstrs else - (trace, rest1, build_fields (repr ty2).level miss2 (newvar ()), + (trace, rest1, build_fields (get_level ty2) miss2 (newvar ()), !univar_pairs) :: cstrs in List.fold_left (fun cstrs (_, _k1, t1, _k2, t2) -> - (* These fields are always present *) - subtype_rec env (Trace.diff t1 t2::trace) t1 t2 cstrs) + (* These fields are always present *) + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs) cstrs pairs and subtype_row env trace row1 row2 cstrs = - let row1 = row_repr row1 and row2 = row_repr row2 in + let Row {fields = row1_fields; more = more1; closed = row1_closed} = + row_repr row1 in + let Row {fields = row2_fields; more = more2; closed = row2_closed} = + row_repr row2 in let r1, r2, pairs = - merge_row_fields row1.row_fields row2.row_fields in - let r1 = if row2.row_closed then filter_row_fields false r1 else r1 in - let r2 = if row1.row_closed then filter_row_fields false r2 else r2 in - let more1 = repr row1.row_more - and more2 = repr row2.row_more in - match more1.desc, more2.desc with + merge_row_fields row1_fields row2_fields in + let r1 = if row2_closed then filter_row_fields false r1 else r1 in + let r2 = if row1_closed then filter_row_fields false r2 else r2 in + match get_desc more1, get_desc more2 with Tconstr(p1,_,_), Tconstr(p2,_,_) when Path.same p1 p2 -> - subtype_rec env (Trace.diff more1 more2::trace) more1 more2 cstrs + subtype_rec + env + (Subtype.Diff {got = more1; expected = more2} :: trace) + more1 more2 + cstrs | (Tvar _|Tconstr _|Tnil), (Tvar _|Tconstr _|Tnil) - when row1.row_closed && r1 = [] -> + when row1_closed && r1 = [] -> List.fold_left (fun cstrs (_,f1,f2) -> match row_field_repr f1, row_field_repr f2 with - (Rpresent None|Reither(true,_,_,_)), Rpresent None -> + (Rpresent None|Reither(true,_,_)), Rpresent None -> cstrs | Rpresent(Some t1), Rpresent(Some t2) -> - subtype_rec env (Trace.diff t1 t2::trace) t1 t2 cstrs - | Reither(false, t1::_, _, _), Rpresent(Some t2) -> - subtype_rec env (Trace.diff t1 t2::trace) t1 t2 cstrs + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs + | Reither(false, t1::_, _), Rpresent(Some t2) -> + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs | Rabsent, _ -> cstrs | _ -> raise Exit) cstrs pairs | Tunivar _, Tunivar _ - when row1.row_closed = row2.row_closed && r1 = [] && r2 = [] -> + when row1_closed = row2_closed && r1 = [] && r2 = [] -> let cstrs = - subtype_rec env (Trace.diff more1 more2::trace) more1 more2 cstrs in + subtype_rec + env + (Subtype.Diff {got = more1; expected = more2} :: trace) + more1 more2 + cstrs + in List.fold_left (fun cstrs (_,f1,f2) -> match row_field_repr f1, row_field_repr f2 with Rpresent None, Rpresent None - | Reither(true,[],_,_), Reither(true,[],_,_) + | Reither(true,[],_), Reither(true,[],_) | Rabsent, Rabsent -> cstrs | Rpresent(Some t1), Rpresent(Some t2) - | Reither(false,[t1],_,_), Reither(false,[t2],_,_) -> - subtype_rec env (Trace.diff t1 t2::trace) t1 t2 cstrs + | Reither(false,[t1],_), Reither(false,[t2],_) -> + subtype_rec + env + (Subtype.Diff {got = t1; expected = t2} :: trace) + t1 t2 + cstrs | _ -> raise Exit) cstrs pairs | _ -> @@ -4622,15 +5203,16 @@ let subtype env ty1 ty2 = TypePairs.clear subtypes; univar_pairs := []; (* Build constraint set. *) - let cstrs = subtype_rec env [Trace.diff ty1 ty2] ty1 ty2 [] in + let cstrs = + subtype_rec env [Subtype.Diff {got = ty1; expected = ty2}] ty1 ty2 [] + in TypePairs.clear subtypes; (* Enforce constraints. *) function () -> List.iter (function (trace0, t1, t2, pairs) -> - try unify_pairs (ref env) t1 t2 pairs with Unify trace -> - raise (Subtype (expand_trace env (List.rev trace0), - List.tl trace))) + try unify_pairs (ref env) t1 t2 pairs with Unify {trace} -> + subtype_error ~env ~trace:trace0 ~unification_trace:(List.tl trace)) (List.rev cstrs) (*******************) @@ -4639,153 +5221,147 @@ let subtype env ty1 ty2 = (* Utility for printing. The resulting type is not used in computation. *) let rec unalias_object ty = - let ty = repr ty in - match ty.desc with + let level = get_level ty in + match get_desc ty with Tfield (s, k, t1, t2) -> - newty2 ty.level (Tfield (s, k, t1, unalias_object t2)) - | Tvar _ | Tnil -> - newty2 ty.level ty.desc + newty2 ~level (Tfield (s, k, t1, unalias_object t2)) + | Tvar _ | Tnil as desc -> + newty2 ~level desc | Tunivar _ -> ty | Tconstr _ -> - newvar2 ty.level + newvar2 level | _ -> assert false let unalias ty = - let ty = repr ty in - match ty.desc with + let level = get_level ty in + match get_desc ty with Tvar _ | Tunivar _ -> ty | Tvariant row -> - let row = row_repr row in - let more = row.row_more in - newty2 ty.level - (Tvariant {row with row_more = newty2 more.level more.desc}) + let Row {fields; more; name; fixed; closed} = row_repr row in + newty2 ~level + (Tvariant + (create_row ~fields ~name ~fixed ~closed ~more: + (newty2 ~level:(get_level more) (get_desc more)))) | Tobject (ty, nm) -> - newty2 ty.level (Tobject (unalias_object ty, nm)) - | _ -> - newty2 ty.level ty.desc + newty2 ~level (Tobject (unalias_object ty, nm)) + | desc -> + newty2 ~level desc (* Return the arity (as for curried functions) of the given type. *) let rec arity ty = - match (repr ty).desc with + match get_desc ty with Tarrow(_, _t1, t2, _) -> 1 + arity t2 | _ -> 0 -(* Check whether an abbreviation expands to itself. *) -let cyclic_abbrev env id ty = - let rec check_cycle seen ty = - let ty = repr ty in - match ty.desc with - Tconstr (p, _tl, _abbrev) -> - p = Path.Pident id || List.memq ty seen || - begin try - check_cycle (ty :: seen) (expand_abbrev_opt env ty) - with - Cannot_expand -> false - | Unify _ -> true - end - | _ -> - false - in check_cycle [] ty - -(* Ensure all mode variables are fully determined *) -let remove_mode_variables ty = - let visited = ref TypeSet.empty in - let rec go ty = - let ty = repr ty in - if TypeSet.mem ty !visited then () else begin - visited := TypeSet.add ty !visited; - match ty.desc with - | Tarrow ((_,marg,mret),targ,tret,_) -> - let _ = Btype.Alloc_mode.constrain_lower marg in - let _ = Btype.Alloc_mode.constrain_lower mret in - go targ; go tret - | _ -> iter_type_expr go ty - end - in go ty - (* Check for non-generalizable type variables *) -exception Non_closed0 +exception Nongen let visited = ref TypeSet.empty -let rec closed_schema_rec env ty = - let ty = repr ty in +let rec nongen_schema_rec env ty = if TypeSet.mem ty !visited then () else begin visited := TypeSet.add ty !visited; - match ty.desc with - Tvar _ when ty.level <> generic_level -> - raise Non_closed0 + match get_desc ty with + Tvar _ when get_level ty <> generic_level -> + raise Nongen | Tconstr _ -> let old = !visited in - begin try iter_type_expr (closed_schema_rec env) ty - with Non_closed0 -> try + begin try iter_type_expr (nongen_schema_rec env) ty + with Nongen -> try visited := old; - closed_schema_rec env (try_expand_head try_expand_safe env ty) + nongen_schema_rec env (try_expand_head try_expand_safe env ty) with Cannot_expand -> - raise Non_closed0 + raise Nongen end | Tfield(_, kind, t1, t2) -> - if field_kind_repr kind = Fpresent then - closed_schema_rec env t1; - closed_schema_rec env t2 + if field_kind_repr kind = Fpublic then + nongen_schema_rec env t1; + nongen_schema_rec env t2 | Tvariant row -> - let row = row_repr row in - iter_row (closed_schema_rec env) row; - if not (static_row row) then closed_schema_rec env row.row_more + iter_row (nongen_schema_rec env) row; + if not (static_row row) then nongen_schema_rec env (row_more row) | _ -> - iter_type_expr (closed_schema_rec env) ty + iter_type_expr (nongen_schema_rec env) ty end (* Return whether all variables of type [ty] are generic. *) -let closed_schema env ty = +let nongen_schema env ty = + remove_mode_variables ty; visited := TypeSet.empty; try - closed_schema_rec env ty; - visited := TypeSet.empty; - true - with Non_closed0 -> + nongen_schema_rec env ty; visited := TypeSet.empty; false + with Nongen -> + visited := TypeSet.empty; + true + +(* Check that all type variables are generalizable *) +(* Use Env.empty to prevent expansion of recursively defined object types; + cf. typing-poly/poly.ml *) +let rec nongen_class_type = function + | Cty_constr (_, params, _) -> + List.exists (nongen_schema Env.empty) params + | Cty_signature sign -> + nongen_schema Env.empty sign.csig_self + || nongen_schema Env.empty sign.csig_self_row + || Meths.exists + (fun _ (_, _, ty) -> nongen_schema Env.empty ty) + sign.csig_meths + || Vars.exists + (fun _ (_, _, ty) -> nongen_schema Env.empty ty) + sign.csig_vars + | Cty_arrow (_, ty, cty) -> + nongen_schema Env.empty ty + || nongen_class_type cty + +let nongen_class_declaration cty = + List.exists (nongen_schema Env.empty) cty.cty_params + || nongen_class_type cty.cty_type + (* Normalize a type before printing, saving... *) (* Cannot use mark_type because deep_occur uses it too *) let rec normalize_type_rec visited ty = - let ty = repr ty in if not (TypeSet.mem ty !visited) then begin visited := TypeSet.add ty !visited; let tm = row_of_type ty in begin if not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm then - match tm.desc with (* PR#7348 *) + match get_desc tm with (* PR#7348 *) Tconstr (Path.Pdot(m,i), tl, _abbrev) -> let i' = String.sub i 0 (String.length i - 4) in set_type_desc ty (Tconstr(Path.Pdot(m,i'), tl, ref Mnil)) | _ -> assert false - else match ty.desc with + else match get_desc ty with | Tvariant row -> - let row = row_repr row in + let Row {fields = orig_fields; more; name; fixed; closed} = + row_repr row in let fields = List.map - (fun (l,f0) -> - let f = row_field_repr f0 in l, - match f with Reither(b, ty::(_::_ as tyl), m, e) -> + (fun (l,f) -> + l, + match row_field_repr f with Reither(b, ty::(_::_ as tyl), m) -> let tyl' = List.fold_left (fun tyl ty -> - if List.exists - (fun ty' -> equal Env.empty false [ty] [ty']) tyl - then tyl else ty::tyl) + if List.exists + (fun ty' -> is_equal Env.empty false [ty] [ty']) + tyl + then tyl + else ty::tyl) [ty] tyl in - if f != f0 || List.length tyl' < List.length tyl then - Reither(b, List.rev tyl', m, e) + if List.length tyl' <= List.length tyl then + rf_either (List.rev tyl') ~use_ext_of:f ~no_arg:b ~matched:m else f | _ -> f) - row.row_fields in + orig_fields in let fields = List.sort (fun (p,_) (q,_) -> compare p q) - (List.filter (fun (_,fi) -> fi <> Rabsent) fields) in - set_type_desc ty (Tvariant {row with row_fields = fields}) + (List.filter (fun (_,fi) -> row_field_repr fi <> Rabsent) fields) in + set_type_desc ty (Tvariant + (create_row ~fields ~more ~name ~fixed ~closed)) | Tobject (fi, nm) -> begin match !nm with | None -> () @@ -4793,25 +5369,23 @@ let rec normalize_type_rec visited ty = if deep_occur ty (newgenty (Ttuple l)) then (* The abbreviation may be hiding something, so remove it *) set_name nm None - else let v' = repr v in - begin match v'.desc with - | Tvar _ | Tunivar _ -> - if v' != v then set_name nm (Some (n, v' :: l)) - | Tnil -> - set_type_desc ty (Tconstr (n, l, ref Mnil)) - | _ -> set_name nm None + else + begin match get_desc v with + | Tvar _ | Tunivar _ -> () + | Tnil -> set_type_desc ty (Tconstr (n, l, ref Mnil)) + | _ -> set_name nm None end | _ -> fatal_error "Ctype.normalize_type_rec" end; - let fi = repr fi in - if fi.level < lowest_level then () else + let level = get_level fi in + if level < lowest_level then () else let fields, row = flatten_fields fi in - let fi' = build_fields fi.level fields row in - set_type_desc fi fi'.desc + let fi' = build_fields level fields row in + set_type_desc fi (get_desc fi') | _ -> () end; - iter_type_expr (normalize_type_rec visited) ty + iter_type_expr (normalize_type_rec visited) ty; end let normalize_type ty = @@ -4836,41 +5410,45 @@ let clear_hash () = TypeHash.clear nondep_hash; TypeHash.clear nondep_variants let rec nondep_type_rec ?(expand_private=false) env ids ty = - let expand_abbrev env t = - if expand_private then expand_abbrev_opt env t else expand_abbrev env t + let try_expand env t = + if expand_private then try_expand_safe_opt env t + else try_expand_safe env t in - match ty.desc with + match get_desc ty with Tvar _ | Tunivar _ -> ty - | Tlink ty -> nondep_type_rec env ids ty | _ -> try TypeHash.find nondep_hash ty with Not_found -> - let ty' = newgenvar () in (* Stub *) + let ty' = newgenstub ~scope:(get_scope ty) in TypeHash.add nondep_hash ty ty'; - ty'.desc <- - begin match ty.desc with - | Tconstr(p, tl, _abbrev) -> - begin match Path.find_free_opt ids p with - | Some id -> - begin try - Tlink (nondep_type_rec ~expand_private env ids - (expand_abbrev env (newty2 ty.level ty.desc))) - (* - The [Tlink] is important. The expanded type may be a - variable, or may not be completely copied yet - (recursive type), so one cannot just take its - description. - *) - with Cannot_expand | Unify _ -> - raise (Nondep_cannot_erase id) - end - | None -> - Tconstr(p, List.map (nondep_type_rec env ids) tl, ref Mnil) + match + match get_desc ty with + | Tconstr(p, tl, _abbrev) as desc -> + begin try + (* First, try keeping the same type constructor p *) + match Path.find_free_opt ids p with + | Some id -> + raise (Nondep_cannot_erase id) + | None -> + Tconstr(p, List.map (nondep_type_rec env ids) tl, ref Mnil) + with (Nondep_cannot_erase _) as exn -> + (* If that doesn't work, try expanding abbrevs *) + try Tlink (nondep_type_rec ~expand_private env ids + (try_expand env (newty2 ~level:(get_level ty) desc))) + (* + The [Tlink] is important. The expanded type may be a + variable, or may not be completely copied yet + (recursive type), so one cannot just take its + description. + *) + with Cannot_expand -> raise exn end - | Tpackage(p, nl, tl) when Path.exists_free ids p -> + | Tpackage(p, fl) when Path.exists_free ids p -> let p' = normalize_package_path env p in begin match Path.find_free_opt ids p' with | Some id -> raise (Nondep_cannot_erase id) - | None -> Tpackage (p', nl, List.map (nondep_type_rec env ids) tl) + | None -> + let nondep_field_rec (n, ty) = (n, nondep_type_rec env ids ty) in + Tpackage (p', List.map nondep_field_rec fl) end | Tobject (t1, name) -> Tobject (nondep_type_rec env ids t1, @@ -4880,8 +5458,7 @@ let rec nondep_type_rec ?(expand_private=false) env ids ty = if Path.exists_free ids p then None else Some (p, List.map (nondep_type_rec env ids) tl))) | Tvariant row -> - let row = row_repr row in - let more = repr row.row_more in + let more = row_more row in (* We must keep sharing according to the row variable *) begin try let ty2 = TypeHash.find nondep_variants more in @@ -4892,18 +5469,25 @@ let rec nondep_type_rec ?(expand_private=false) env ids ty = (* Register new type first for recursion *) TypeHash.add nondep_variants more ty'; let static = static_row row in - let more' = if static then newgenty Tnil else more in + let more' = + if static then newgenty Tnil else nondep_type_rec env ids more + in (* Return a new copy *) let row = copy_row (nondep_type_rec env ids) true row true more' in - match row.row_name with + match row_name row with Some (p, _tl) when Path.exists_free ids p -> - Tvariant {row with row_name = None} + Tvariant (set_row_name row None) | _ -> Tvariant row end - | _ -> copy_type_desc (nondep_type_rec env ids) ty.desc - end; - ty' + | desc -> copy_type_desc (nondep_type_rec env ids) desc + with + | desc -> + Transient_expr.set_stub_desc ty' desc; + ty' + | exception e -> + TypeHash.remove nondep_hash ty; + raise e let nondep_type env id ty = try @@ -4953,7 +5537,7 @@ let nondep_type_decl env mid is_covariant decl = type_loc = decl.type_loc; type_attributes = decl.type_attributes; type_immediate = decl.type_immediate; - type_unboxed = decl.type_unboxed; + type_unboxed_default = decl.type_unboxed_default; type_uid = decl.type_uid; } with Nondep_cannot_erase _ as exn -> @@ -4971,7 +5555,7 @@ let nondep_extension_constructor env ids ext = newgenty (Tconstr(ext.ext_type_path, ext.ext_type_params, ref Mnil)) in let ty' = nondep_type_rec env ids ty in - match (repr ty').desc with + match get_desc ty' with Tconstr(p, tl, _) -> p, tl | _ -> raise (Nondep_cannot_erase id) end @@ -5001,13 +5585,13 @@ let nondep_extension_constructor env ids ext = (* Preserve sharing inside class types. *) let nondep_class_signature env id sign = { csig_self = nondep_type_rec env id sign.csig_self; + csig_self_row = nondep_type_rec env id sign.csig_self_row; csig_vars = Vars.map (function (m, v, t) -> (m, v, nondep_type_rec env id t)) sign.csig_vars; - csig_concr = sign.csig_concr; - csig_inher = - List.map (fun (p,tl) -> (p, List.map (nondep_type_rec env id) tl)) - sign.csig_inher } + csig_meths = + Meths.map (function (p, v, t) -> (p, v, nondep_type_rec env id t)) + sign.csig_meths } let rec nondep_class_type env ids = function @@ -5058,21 +5642,19 @@ let nondep_cltype_declaration env ids decl = (* collapse conjunctive types in class parameters *) let rec collapse_conj env visited ty = - let ty = repr ty in - if List.memq ty visited then () else - let visited = ty :: visited in - match ty.desc with + let id = get_id ty in + if List.memq id visited then () else + let visited = id :: visited in + match get_desc ty with Tvariant row -> - let row = row_repr row in List.iter (fun (_l,fi) -> match row_field_repr fi with - Reither (c, t1::(_::_ as tl), m, e) -> - List.iter (unify env t1) tl; - set_row_field e (Reither (c, [t1], m, ref None)) + Reither (_c, t1::(_::_ as tl), _m) -> + List.iter (unify env t1) tl | _ -> ()) - row.row_fields; + (row_fields row); iter_row (collapse_conj env visited) row | _ -> iter_type_expr (collapse_conj env visited) ty @@ -5083,23 +5665,15 @@ let collapse_conj_params env params = let same_constr env t1 t2 = let t1 = expand_head env t1 in let t2 = expand_head env t2 in - match t1.desc, t2.desc with + match get_desc t1, get_desc t2 with | Tconstr (p1, _, _), Tconstr (p2, _, _) -> Path.same p1 p2 | _ -> false let () = Env.same_constr := same_constr -let is_immediate = function - | Type_immediacy.Unknown -> false - | Type_immediacy.Always -> true - | Type_immediacy.Always_on_64bits -> - (* In bytecode, we don't know at compile time whether we are - targeting 32 or 64 bits. *) - !Clflags.native_code && Sys.word_size = 64 - let immediacy env typ = - match (repr typ).desc with + match get_desc typ with | Tconstr(p, _args, _abbrev) -> begin try let type_decl = Env.find_type p env in @@ -5110,19 +5684,16 @@ let immediacy env typ = Maybe we should emit a warning. *) end | Tvariant row -> - let row = Btype.row_repr row in (* if all labels are devoid of arguments, not a pointer *) if - not row.row_closed + not (row_closed row) || List.exists - (function - | _, (Rpresent (Some _) | Reither (false, _, _, _)) -> true - | _ -> false) - row.row_fields + (fun (_, f) -> match row_field_repr f with + | Rpresent (Some _) | Reither (false, _, _) -> true + | _ -> false) + (row_fields row) then Type_immediacy.Unknown else Type_immediacy.Always | _ -> Type_immediacy.Unknown - -let maybe_pointer_type env typ = not (is_immediate (immediacy env typ)) diff --git a/ocaml/typing/ctype.mli b/ocaml/typing/ctype.mli index 2ee7678df38..84c24e17163 100644 --- a/ocaml/typing/ctype.mli +++ b/ocaml/typing/ctype.mli @@ -18,89 +18,20 @@ open Asttypes open Types -module TypePairs : sig - type t - val create: int -> t - val clear: t -> unit - val add: t -> type_expr * type_expr -> unit - val mem: t -> type_expr * type_expr -> bool - val iter: (type_expr * type_expr -> unit) -> t -> unit -end - -module Unification_trace: sig - (** Unification traces are used to explain unification errors - when printing error messages *) - - type position = First | Second - type desc = { t: type_expr; expanded: type_expr option } - type 'a diff = { got: 'a; expected: 'a} - - (** Scope escape related errors *) - type 'a escape = - | Constructor of Path.t - | Univ of type_expr - (** The type_expr argument of [Univ] is always a [Tunivar _], - we keep a [type_expr] to track renaming in {!Printtyp} *) - | Self - | Module_type of Path.t - | Equation of 'a - - (** Errors for polymorphic variants *) - - type fixed_row_case = - | Cannot_be_closed - | Cannot_add_tags of string list - - type variant = - | No_intersection - | No_tags of position * (Asttypes.label * row_field) list - | Incompatible_types_for of string - | Fixed_row of position * fixed_row_case * fixed_explanation - (** Fixed row types, e.g. ['a. [> `X] as 'a] *) - - type obj = - | Missing_field of position * string - | Abstract_row of position - | Self_cannot_be_closed - - type 'a elt = - | Diff of 'a diff - | Variant of variant - | Obj of obj - | Escape of {context: type_expr option; kind:'a escape} - | Incompatible_fields of {name:string; diff: type_expr diff } - | Rec_occur of type_expr * type_expr - - type t = desc elt list - - val diff: type_expr -> type_expr -> desc elt - - (** [map_diff f {expected;got}] is [{expected=f expected; got=f got}] *) - val map_diff: ('a -> 'b) -> 'a diff -> 'b diff - - (** [flatten f trace] flattens all elements of type {!desc} in - [trace] to either [f x.t expanded] if [x.expanded=Some expanded] - or [f x.t x.t] otherwise *) - val flatten: (type_expr -> type_expr -> 'a) -> t -> 'a elt list - - (** Switch [expected] and [got] *) - val swap: t -> t - - (** [explain trace f] calls [f] on trace elements starting from the end - until [f ~prev elt] is [Some _], returns that - or [None] if the end of the trace is reached. *) - val explain: - 'a elt list -> - (prev:'a elt option -> 'a elt -> 'b option) -> - 'b option - -end - -exception Unify of Unification_trace.t +exception Unify of Errortrace.unification_error +exception Equality of Errortrace.equality_error +exception Moregen of Errortrace.moregen_error +exception Subtype of Errortrace.Subtype.error + +exception Escape of type_expr Errortrace.escape + exception Tags of label * label -exception Subtype of Unification_trace.t * Unification_trace.t exception Cannot_expand exception Cannot_apply +exception Matches_failure of Env.t * Errortrace.unification_error + (* Raised from [matches], hence the odd name *) +exception Incompatible + (* Raised from [mcomp] *) val init_def: int -> unit (* Set the initial variable level *) @@ -124,6 +55,7 @@ val set_levels: levels -> unit val create_scope : unit -> int val newty: type_desc -> type_expr +val new_scoped_ty: int -> type_desc -> type_expr val newvar: ?name:string -> unit -> type_expr val newvar2: ?name:string -> int -> type_expr (* Return a fresh variable *) @@ -132,12 +64,10 @@ val new_global_var: ?name:string -> unit -> type_expr (as type variables ['a] in type constraints). *) val newobj: type_expr -> type_expr val newconstr: Path.t -> type_expr list -> type_expr +val newmono : type_expr -> type_expr val none: type_expr (* A dummy type expression *) -val repr: type_expr -> type_expr - (* Return the canonical representative of a type. *) - val object_fields: type_expr -> type_expr val flatten_fields: type_expr -> (string * field_kind * type_expr) list * type_expr @@ -166,13 +96,9 @@ val associate_fields: (string * field_kind * type_expr) list * (string * field_kind * type_expr) list val opened_object: type_expr -> bool -val close_object: type_expr -> bool -val row_variable: type_expr -> type_expr - (* Return the row variable of an open object type *) val set_object_name: - Ident.t -> type_expr -> type_expr list -> type_expr -> unit + Ident.t -> type_expr list -> type_expr -> unit val remove_object_name: type_expr -> unit -val hide_private_methods: type_expr -> unit val find_cltype_for_path: Env.t -> Path.t -> type_declaration * type_expr val sort_row_fields: (label * row_field) list -> (label * row_field) list @@ -188,22 +114,31 @@ val generalize: type_expr -> unit val lower_contravariant: Env.t -> type_expr -> unit (* Lower level of type variables inside contravariant branches; to be used before generalize for expansive expressions *) +val lower_variables_only: Env.t -> int -> type_expr -> unit + (* Lower all variables to the given level *) val generalize_structure: type_expr -> unit - (* Same, but variables are only lowered to !current_level *) -val generalize_spine: type_expr -> unit - (* Special function to generalize a method during inference *) + (* Generalize the structure of a type, lowering variables + to !current_level *) +val generalize_class_type : class_type -> unit + (* Generalize the components of a class type *) +val generalize_class_type_structure : class_type -> unit + (* Generalize the structure of the components of a class type *) +val generalize_class_signature_spine : Env.t -> class_signature -> unit + (* Special function to generalize methods during inference *) val correct_levels: type_expr -> type_expr (* Returns a copy with decreasing levels *) val limited_generalize: type_expr -> type_expr -> unit (* Only generalize some part of the type Make the remaining of the type non-generalizable *) +val limited_generalize_class_type: type_expr -> class_type -> unit + (* Same, but for class types *) val fully_generic: type_expr -> bool val check_scope_escape : Env.t -> int -> type_expr -> unit (* [check_scope_escape env lvl ty] ensures that [ty] could be raised to the level [lvl] without any scope escape. - Raises [Unify] otherwise *) + Raises [Escape] otherwise *) val instance: ?partial:bool -> type_expr -> type_expr (* Take an instance of a type scheme *) @@ -214,11 +149,14 @@ val generic_instance: type_expr -> type_expr (* Same as instance, but new nodes at generic_level *) val instance_list: type_expr list -> type_expr list (* Take an instance of a list of type schemes *) +val new_local_type: + ?loc:Location.t -> + ?manifest_and_scope:(type_expr * int) -> unit -> type_declaration val existential_name: constructor_description -> type_expr -> string val instance_constructor: ?in_pattern:Env.t ref * int -> - constructor_description -> type_expr list * type_expr - (* Same, for a constructor *) + constructor_description -> (type_expr * global_flag) list * type_expr * type_expr list + (* Same, for a constructor. Also returns existentials. *) val instance_parameterized_type: ?keep_names:bool -> type_expr list -> type_expr -> type_expr list * type_expr @@ -230,6 +168,7 @@ val generic_instance_declaration: type_declaration -> type_declaration (* Same as instance_declaration, but new nodes at generic_level *) val instance_class: type_expr list -> class_type -> type_expr list * class_type + val instance_poly: ?keep_names:bool -> bool -> type_expr list -> type_expr -> type_expr list * type_expr @@ -250,68 +189,123 @@ val apply: the parameters [pi] and returns the corresponding instance of [t]. Exception [Cannot_apply] is raised in case of failure. *) +val try_expand_once_opt: Env.t -> type_expr -> type_expr +val try_expand_safe_opt: Env.t -> type_expr -> type_expr + val expand_head_once: Env.t -> type_expr -> type_expr val expand_head: Env.t -> type_expr -> type_expr -val try_expand_once_opt: Env.t -> type_expr -> type_expr val expand_head_opt: Env.t -> type_expr -> type_expr (** The compiler's own version of [expand_head] necessary for type-based optimisations. *) -val full_expand: Env.t -> type_expr -> type_expr -val extract_concrete_typedecl: - Env.t -> type_expr -> Path.t * Path.t * type_declaration - (* Return the original path of the types, and the first concrete - type declaration found expanding it. - Raise [Not_found] if none appears or not a type constructor. *) +(** Expansion of types for error traces; lives here instead of in [Errortrace] + because the expansion machinery lives here. *) + +(** Create an [Errortrace.Diff] by expanding the two types *) +val expanded_diff : + Env.t -> + got:type_expr -> expected:type_expr -> + (Errortrace.expanded_type, 'variant) Errortrace.elt + +(** Create an [Errortrace.Diff] by *duplicating* the two types, so that each + one's expansion is identical to itself. Despite the name, does create + [Errortrace.expanded_type]s. *) +val unexpanded_diff : + got:type_expr -> expected:type_expr -> + (Errortrace.expanded_type, 'variant) Errortrace.elt -val enforce_constraints: Env.t -> type_expr -> unit +val full_expand: may_forget_scope:bool -> Env.t -> type_expr -> type_expr + +type typedecl_extraction_result = + | Typedecl of Path.t * Path.t * type_declaration + (* The original path of the types, and the first concrete + type declaration found expanding it. *) + | Has_no_typedecl + | May_have_typedecl + +val extract_concrete_typedecl: + Env.t -> type_expr -> typedecl_extraction_result val unify: Env.t -> type_expr -> type_expr -> unit (* Unify the two types given. Raise [Unify] if not possible. *) val unify_gadt: - equations_level:int -> allow_recursive:bool -> - Env.t ref -> type_expr -> type_expr -> TypePairs.t + equations_level:int -> allow_recursive_equations:bool -> + Env.t ref -> type_expr -> type_expr -> Btype.TypePairs.t (* Unify the two types given and update the environment with the local constraints. Raise [Unify] if not possible. Returns the pairs of types that have been equated. *) val unify_var: Env.t -> type_expr -> type_expr -> unit (* Same as [unify], but allow free univars when first type is a variable. *) -val unify_alloc_mode: alloc_mode -> alloc_mode -> unit -val filter_arrow: Env.t -> type_expr -> arg_label -> +val filter_arrow: Env.t -> type_expr -> arg_label -> force_tpoly:bool -> alloc_mode * type_expr * alloc_mode * type_expr - (* A special case of unification (with l:'a -> 'b). *) -val filter_method: Env.t -> string -> private_flag -> type_expr -> type_expr - (* A special case of unification (with {m : 'a; 'b}). *) -val check_filter_method: Env.t -> string -> private_flag -> type_expr -> unit - (* A special case of unification (with {m : 'a; 'b}), returning unit. *) + (* A special case of unification (with l:'a -> 'b). If + [force_poly] is false then the usual invariant that the + argument type be a [Tpoly] node is not enforced. Raises + [Filter_arrow_failed] instead of [Unify]. *) +val filter_mono: type_expr -> type_expr + (* A special case of unification (with Tpoly('a, [])). Can + only be called on [Tpoly] nodes. Raises [Filter_mono_failed] + instead of [Unify] *) +val filter_arrow_mono: Env.t -> type_expr -> arg_label -> + alloc_mode * type_expr * alloc_mode * type_expr + (* A special case of unification. Composition of [filter_arrow] + with [filter_mono] on the argument type. Raises + [Filter_arrow_mono_failed] instead of [Unify] *) +val filter_method: Env.t -> string -> type_expr -> type_expr + (* A special case of unification (with {m : 'a; 'b}). Raises + [Filter_method_failed] instead of [Unify]. *) val occur_in: Env.t -> type_expr -> type_expr -> bool val deep_occur: type_expr -> type_expr -> bool -val filter_self_method: - Env.t -> string -> private_flag -> (Ident.t * type_expr) Meths.t ref -> - type_expr -> Ident.t * type_expr -val moregeneral: Env.t -> bool -> type_expr -> type_expr -> bool +val moregeneral: Env.t -> bool -> type_expr -> type_expr -> unit (* Check if the first type scheme is more general than the second. *) - +val is_moregeneral: Env.t -> bool -> type_expr -> type_expr -> bool val rigidify: type_expr -> type_expr list (* "Rigidify" a type and return its type variable *) val all_distinct_vars: Env.t -> type_expr list -> bool (* Check those types are all distinct type variables *) -val matches: Env.t -> type_expr -> type_expr -> bool +val matches: expand_error_trace:bool -> Env.t -> type_expr -> type_expr -> unit (* Same as [moregeneral false], implemented using the two above - functions and backtracking. Ignore levels *) + functions and backtracking. Ignore levels. The [expand_error_trace] + flag controls whether the error raised performs expansion; this + should almost always be [true]. *) +val does_match: Env.t -> type_expr -> type_expr -> bool + (* Same as [matches], but returns a [bool] *) val reify_univars : Env.t -> Types.type_expr -> Types.type_expr (* Replaces all the variables of a type by a univar. *) +(* Exceptions for special cases of unify *) + +type filter_arrow_failure = + | Unification_error of Errortrace.unification_error + | Label_mismatch of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + } + | Not_a_function + +exception Filter_arrow_failed of filter_arrow_failure + +exception Filter_mono_failed +exception Filter_arrow_mono_failed + +type filter_method_failure = + | Unification_error of Errortrace.unification_error + | Not_a_method + | Not_an_object of type_expr + +exception Filter_method_failed of filter_method_failure + type class_match_failure = CM_Virtual_class | CM_Parameter_arity_mismatch of int * int - | CM_Type_parameter_mismatch of Env.t * Unification_trace.t + | CM_Type_parameter_mismatch of Env.t * Errortrace.equality_error | CM_Class_type_mismatch of Env.t * class_type * class_type - | CM_Parameter_mismatch of Env.t * Unification_trace.t - | CM_Val_type_mismatch of string * Env.t * Unification_trace.t - | CM_Meth_type_mismatch of string * Env.t * Unification_trace.t + | CM_Parameter_mismatch of Env.t * Errortrace.moregen_error + | CM_Val_type_mismatch of string * Env.t * Errortrace.comparison_error + | CM_Meth_type_mismatch of string * Env.t * Errortrace.comparison_error | CM_Non_mutable_value of string | CM_Non_concrete_value of string | CM_Missing_value of string @@ -321,13 +315,22 @@ type class_match_failure = | CM_Public_method of string | CM_Private_method of string | CM_Virtual_method of string + val match_class_types: ?trace:bool -> Env.t -> class_type -> class_type -> class_match_failure list (* Check if the first class type is more general than the second. *) -val equal: Env.t -> bool -> type_expr list -> type_expr list -> bool +val equal: Env.t -> bool -> type_expr list -> type_expr list -> unit (* [equal env [x1...xn] tau [y1...yn] sigma] checks whether the parameterized types [/\x1.../\xn.tau] and [/\y1.../\yn.sigma] are equivalent. *) +val is_equal : Env.t -> bool -> type_expr list -> type_expr list -> bool +val equal_private : + Env.t -> type_expr list -> type_expr -> + type_expr list -> type_expr -> unit +(* [equal_private env t1 params1 t2 params2] checks that [t1::params1] + equals [t2::params2] but it is allowed to expand [t1] if it is a + private abbreviations. *) + val match_class_declarations: Env.t -> type_expr list -> class_type -> type_expr list -> class_type -> class_match_failure list @@ -341,6 +344,46 @@ val subtype: Env.t -> type_expr -> type_expr -> unit -> unit enforce and returns a function that enforces this constraints. *) +(* Operations on class signatures *) + +val new_class_signature : unit -> class_signature +val add_dummy_method : Env.t -> scope:int -> class_signature -> unit + +type add_method_failure = + | Unexpected_method + | Type_mismatch of Errortrace.unification_error + +exception Add_method_failed of add_method_failure + +val add_method : Env.t -> + label -> private_flag -> virtual_flag -> type_expr -> class_signature -> unit + +type add_instance_variable_failure = + | Mutability_mismatch of mutable_flag + | Type_mismatch of Errortrace.unification_error + +exception Add_instance_variable_failed of add_instance_variable_failure + +val add_instance_variable : strict:bool -> Env.t -> + label -> mutable_flag -> virtual_flag -> type_expr -> class_signature -> unit + +type inherit_class_signature_failure = + | Self_type_mismatch of Errortrace.unification_error + | Method of label * add_method_failure + | Instance_variable of label * add_instance_variable_failure + +exception Inherit_class_signature_failed of inherit_class_signature_failure + +val inherit_class_signature : strict:bool -> Env.t -> + class_signature -> class_signature -> unit + +val update_class_signature : + Env.t -> class_signature -> label list * label list + +val hide_private_methods : Env.t -> class_signature -> unit + +val close_class_signature : Env.t -> class_signature -> bool + exception Nondep_cannot_erase of Ident.t val nondep_type: Env.t -> Ident.t list -> type_expr -> type_expr @@ -362,32 +405,32 @@ val nondep_cltype_declaration: Env.t -> Ident.t list -> class_type_declaration -> class_type_declaration (* Same for class type declarations. *) (*val correct_abbrev: Env.t -> Path.t -> type_expr list -> type_expr -> unit*) -val cyclic_abbrev: Env.t -> Ident.t -> type_expr -> bool val is_contractive: Env.t -> Path.t -> bool val normalize_type: type_expr -> unit val remove_mode_variables: type_expr -> unit (* Ensure mode variables are fully determined *) -val closed_schema: Env.t -> type_expr -> bool +val nongen_schema: Env.t -> type_expr -> bool (* Check whether the given type scheme contains no non-generic - type variables *) + type variables, and ensure mode variables are fully determined *) + +val nongen_class_declaration: class_declaration -> bool + (* Check whether the given class type contains no non-generic + type variables, and ensures mode variables are fully determined. + Uses the empty environment. *) val free_variables: ?env:Env.t -> type_expr -> type_expr list (* If env present, then check for incomplete definitions too *) val closed_type_decl: type_declaration -> type_expr option val closed_extension_constructor: extension_constructor -> type_expr option -type closed_class_failure = - CC_Method of type_expr * bool * string * type_expr - | CC_Value of type_expr * bool * string * type_expr val closed_class: - type_expr list -> class_signature -> closed_class_failure option + type_expr list -> class_signature -> + (type_expr * bool * string * type_expr) option (* Check whether all type variables are bound *) val unalias: type_expr -> type_expr -val signature_of_class_type: class_type -> class_signature -val self_type: class_type -> type_expr -val class_type_arity: class_type -> int + val arity: type_expr -> int (* Return the arity (as for curried functions) of the given type. *) @@ -400,12 +443,10 @@ val reset_reified_var_counter: unit -> unit val immediacy : Env.t -> type_expr -> Type_immediacy.t -val maybe_pointer_type : Env.t -> type_expr -> bool - (* True if type is possibly pointer, false if definitely not a pointer *) - (* Stubs *) val package_subtype : - (Env.t -> Path.t -> Longident.t list -> type_expr list -> - Path.t -> Longident.t list -> type_expr list -> bool) ref + (Env.t -> Path.t -> (Longident.t * type_expr) list -> + Path.t -> (Longident.t * type_expr) list -> bool) ref +(* Raises [Incompatible] *) val mcomp : Env.t -> type_expr -> type_expr -> unit diff --git a/ocaml/typing/datarepr.ml b/ocaml/typing/datarepr.ml index d88304072f3..071534a9826 100644 --- a/ocaml/typing/datarepr.ml +++ b/ocaml/typing/datarepr.ml @@ -24,24 +24,20 @@ open Btype let free_vars ?(param=false) ty = let ret = ref TypeSet.empty in let rec loop ty = - let ty = repr ty in - if ty.level >= lowest_level then begin - ty.level <- pivot_level - ty.level; - match ty.desc with + if try_mark_node ty then + match get_desc ty with | Tvar _ -> ret := TypeSet.add ty !ret | Tvariant row -> - let row = row_repr row in iter_row loop row; if not (static_row row) then begin - match row.row_more.desc with + match get_desc (row_more row) with | Tvar _ when param -> ret := TypeSet.add ty !ret - | _ -> loop row.row_more + | _ -> loop (row_more row) end (* XXX: What about Tobject ? *) | _ -> iter_type_expr loop ty - end in loop ty; unmark_type ty; @@ -52,7 +48,7 @@ let newgenconstr path tyl = newgenty (Tconstr (path, tyl, ref Mnil)) let constructor_existentials cd_args cd_res = let tyl = match cd_args with - | Cstr_tuple l -> l + | Cstr_tuple l -> List.map (fun (ty, _) -> ty) l | Cstr_record l -> List.map (fun l -> l.ld_type) l in let existentials = @@ -72,11 +68,6 @@ let constructor_args ~current_unit priv cd_args cd_res path rep = | Cstr_record lbls -> let arg_vars_set = free_vars ~param:true (newgenty (Ttuple tyl)) in let type_params = TypeSet.elements arg_vars_set in - let type_unboxed = - match rep with - | Record_unboxed _ -> unboxed_true_default_false - | _ -> unboxed_false_default_false - in let arity = List.length type_params in let tdecl = { @@ -92,21 +83,20 @@ let constructor_args ~current_unit priv cd_args cd_res path rep = type_loc = Location.none; type_attributes = []; type_immediate = Unknown; - type_unboxed; + type_unboxed_default = false; type_uid = Uid.mk ~current_unit; } in existentials, - [ newgenconstr path type_params ], + [ newgenconstr path type_params, Unrestricted ], Some tdecl -let constructor_descrs ~current_unit ty_path decl cstrs = +let constructor_descrs ~current_unit ty_path decl cstrs rep = let ty_res = newgenconstr ty_path decl.type_params in - let num_consts = ref 0 and num_nonconsts = ref 0 and num_normal = ref 0 in + let num_consts = ref 0 and num_nonconsts = ref 0 in List.iter - (fun {cd_args; cd_res; _} -> - if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts; - if cd_res = None then incr num_normal) + (fun {cd_args; _} -> + if cd_args = Cstr_tuple [] then incr num_consts else incr num_nonconsts) cstrs; let rec describe_constructors idx_const idx_nonconst = function [] -> [] @@ -117,20 +107,22 @@ let constructor_descrs ~current_unit ty_path decl cstrs = | None -> ty_res in let (tag, descr_rem) = - match cd_args with - | _ when decl.type_unboxed.unboxed -> + match cd_args, rep with + | _, Variant_unboxed -> assert (rem = []); (Cstr_unboxed, []) - | Cstr_tuple [] -> (Cstr_constant idx_const, - describe_constructors (idx_const+1) idx_nonconst rem) - | _ -> (Cstr_block idx_nonconst, - describe_constructors idx_const (idx_nonconst+1) rem) in + | Cstr_tuple [], Variant_regular -> + (Cstr_constant idx_const, + describe_constructors (idx_const+1) idx_nonconst rem) + | _, Variant_regular -> + (Cstr_block idx_nonconst, + describe_constructors idx_const (idx_nonconst+1) rem) in let cstr_name = Ident.name cd_id in let existentials, cstr_args, cstr_inlined = let representation = - if decl.type_unboxed.unboxed - then Record_unboxed true - else Record_inlined idx_nonconst + match rep with + | Variant_unboxed -> Record_unboxed true + | Variant_regular -> Record_inlined idx_nonconst in constructor_args ~current_unit decl.type_private cd_args cd_res (Path.Pdot (ty_path, cstr_name)) representation @@ -144,7 +136,6 @@ let constructor_descrs ~current_unit ty_path decl cstrs = cstr_tag = tag; cstr_consts = !num_consts; cstr_nonconsts = !num_nonconsts; - cstr_normal = !num_normal; cstr_private = decl.type_private; cstr_generalized = cd_res <> None; cstr_loc = cd_loc; @@ -174,7 +165,6 @@ let extension_descr ~current_unit path_ext ext = cstr_consts = -1; cstr_nonconsts = -1; cstr_private = ext.ext_private; - cstr_normal = -1; cstr_generalized = ext.ext_ret_type <> None; cstr_loc = ext.ext_loc; cstr_attributes = ext.ext_attributes; @@ -182,8 +172,10 @@ let extension_descr ~current_unit path_ext ext = cstr_uid = ext.ext_uid; } -let none = {desc = Ttuple []; level = -1; scope = Btype.generic_level; id = -1} - (* Clearly ill-formed type *) +let none = + create_expr (Ttuple []) ~level:(-1) ~scope:Btype.generic_level ~id:(-1) + (* Clearly ill-formed type *) + let dummy_label = { lbl_name = ""; lbl_res = none; lbl_arg = none; lbl_mut = Immutable; lbl_global = Unrestricted; @@ -236,7 +228,8 @@ let find_constr_by_tag tag cstrlist = let constructors_of_type ~current_unit ty_path decl = match decl.type_kind with - | Type_variant cstrs -> constructor_descrs ~current_unit ty_path decl cstrs + | Type_variant (cstrs,rep) -> + constructor_descrs ~current_unit ty_path decl cstrs rep | Type_record _ | Type_abstract | Type_open -> [] let labels_of_type ty_path decl = @@ -245,16 +238,3 @@ let labels_of_type ty_path decl = label_descrs (newgenconstr ty_path decl.type_params) labels rep decl.type_private | Type_variant _ | Type_abstract | Type_open -> [] - -(* Set row_name in Env, cf. GPR#1204/1329 *) -let set_row_name decl path = - match decl.type_manifest with - None -> () - | Some ty -> - let ty = repr ty in - match ty.desc with - Tvariant row when static_row row -> - let row = {(row_repr row) with - row_name = Some (path, decl.type_params)} in - ty.desc <- Tvariant row - | _ -> () diff --git a/ocaml/typing/datarepr.mli b/ocaml/typing/datarepr.mli index e3962e3a073..67b32a4c3cb 100644 --- a/ocaml/typing/datarepr.mli +++ b/ocaml/typing/datarepr.mli @@ -19,14 +19,14 @@ open Types val extension_descr: - current_unit:string -> Path.t -> extension_constructor -> + current_unit:Compilation_unit.t option -> Path.t -> extension_constructor -> constructor_description val labels_of_type: Path.t -> type_declaration -> (Ident.t * label_description) list val constructors_of_type: - current_unit:string -> Path.t -> type_declaration -> + current_unit:Compilation_unit.t option -> Path.t -> type_declaration -> (Ident.t * constructor_description) list @@ -43,7 +43,3 @@ val constructor_existentials : - the types of the constructor's arguments - the existential variables introduced by the constructor *) - - -(* Set the polymorphic variant row_name field *) -val set_row_name : type_declaration -> Path.t -> unit diff --git a/ocaml/typing/env.ml b/ocaml/typing/env.ml index c85487f6bfe..85d482fcd79 100644 --- a/ocaml/typing/env.ml +++ b/ocaml/typing/env.ml @@ -21,7 +21,6 @@ open Asttypes open Longident open Path open Types -open Btype open Local_store @@ -41,34 +40,100 @@ let value_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 let type_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 let module_declarations : unit usage_tbl ref = s_table Types.Uid.Tbl.create 16 -type constructor_usage = Positive | Pattern | Privatize +let uid_to_loc : Location.t Types.Uid.Tbl.t ref = + s_table Types.Uid.Tbl.create 16 + +let register_uid uid loc = Types.Uid.Tbl.add !uid_to_loc uid loc + +let get_uid_to_loc_tbl () = !uid_to_loc + +type constructor_usage = Positive | Pattern | Exported_private | Exported type constructor_usages = - { - mutable cu_positive: bool; - mutable cu_pattern: bool; - mutable cu_privatize: bool; - } -let add_constructor_usage ~rebind priv cu usage = - let private_or_rebind = - match priv with - | Asttypes.Private -> true - | Asttypes.Public -> rebind - in - if private_or_rebind then begin - cu.cu_positive <- true - end else begin - match usage with - | Positive -> cu.cu_positive <- true - | Pattern -> cu.cu_pattern <- true - | Privatize -> cu.cu_privatize <- true - end + { + mutable cu_positive: bool; + mutable cu_pattern: bool; + mutable cu_exported_private: bool; + } +let add_constructor_usage cu usage = + match usage with + | Positive -> cu.cu_positive <- true + | Pattern -> cu.cu_pattern <- true + | Exported_private -> cu.cu_exported_private <- true + | Exported -> + cu.cu_positive <- true; + cu.cu_pattern <- true; + cu.cu_exported_private <- true let constructor_usages () = - {cu_positive = false; cu_pattern = false; cu_privatize = false} + {cu_positive = false; cu_pattern = false; cu_exported_private = false} + +let constructor_usage_complaint ~rebind priv cu + : Warnings.constructor_usage_warning option = + match priv, rebind with + | Asttypes.Private, _ | _, true -> + if cu.cu_positive || cu.cu_pattern || cu.cu_exported_private then None + else Some Unused + | Asttypes.Public, false -> begin + match cu.cu_positive, cu.cu_pattern, cu.cu_exported_private with + | true, _, _ -> None + | false, false, false -> Some Unused + | false, true, _ -> Some Not_constructed + | false, false, true -> Some Only_exported_private + end let used_constructors : constructor_usage usage_tbl ref = s_table Types.Uid.Tbl.create 16 +type label_usage = + Projection | Mutation | Construct | Exported_private | Exported +type label_usages = + { + mutable lu_projection: bool; + mutable lu_mutation: bool; + mutable lu_construct: bool; + } +let add_label_usage lu usage = + match usage with + | Projection -> lu.lu_projection <- true; + | Mutation -> lu.lu_mutation <- true + | Construct -> lu.lu_construct <- true + | Exported_private -> + lu.lu_projection <- true + | Exported -> + lu.lu_projection <- true; + lu.lu_mutation <- true; + lu.lu_construct <- true + +let is_mutating_label_usage = function + | Mutation -> true + | (Projection | Construct | Exported_private | Exported) -> false + +let label_usages () = + {lu_projection = false; lu_mutation = false; lu_construct = false} + +let label_usage_complaint priv mut lu + : Warnings.field_usage_warning option = + match priv, mut with + | Asttypes.Private, _ -> + if lu.lu_projection then None + else Some Unused + | Asttypes.Public, Asttypes.Immutable -> begin + match lu.lu_projection, lu.lu_construct with + | true, _ -> None + | false, false -> Some Unused + | false, true -> Some Not_read + end + | Asttypes.Public, Asttypes.Mutable -> begin + match lu.lu_projection, lu.lu_mutation, lu.lu_construct with + | true, true, _ -> None + | false, false, false -> Some Unused + | false, _, _ -> Some Not_read + | true, false, _ -> Some Not_mutated + end + +let used_labels : label_usage usage_tbl ref = + s_table Types.Uid.Tbl.create 16 + (** Map indexed by the name of module components. *) module NameMap = String.Map @@ -98,8 +163,26 @@ type summary = | Env_value_unbound of summary * string * value_unbound_reason | Env_module_unbound of summary * string * module_unbound_reason +let map_summary f = function + Env_empty -> Env_empty + | Env_value (s, id, d) -> Env_value (f s, id, d) + | Env_type (s, id, d) -> Env_type (f s, id, d) + | Env_extension (s, id, d) -> Env_extension (f s, id, d) + | Env_module (s, id, p, d) -> Env_module (f s, id, p, d) + | Env_modtype (s, id, d) -> Env_modtype (f s, id, d) + | Env_class (s, id, d) -> Env_class (f s, id, d) + | Env_cltype (s, id, d) -> Env_cltype (f s, id, d) + | Env_open (s, p) -> Env_open (f s, p) + | Env_functor_arg (s, id) -> Env_functor_arg (f s, id) + | Env_constraints (s, m) -> Env_constraints (f s, m) + | Env_copy_types s -> Env_copy_types (f s) + | Env_persistent (s, id) -> Env_persistent (f s, id) + | Env_value_unbound (s, u, r) -> Env_value_unbound (f s, u, r) + | Env_module_unbound (s, u, r) -> Env_module_unbound (f s, u, r) + type address = - | Aident of Ident.t + | Aunit of Compilation_unit.t + | Alocal of Ident.t | Adot of address * int module TycompTbl = @@ -122,6 +205,9 @@ module TycompTbl = bindings for each name, as in comp_labels and comp_constrs. *) + root: Path.t; + (** Only used to check removal of open *) + using: (string -> ('a * 'a) option -> unit) option; (** A callback to be applied when a component is used from this "open". This is used to detect unused "opens". The @@ -136,7 +222,7 @@ module TycompTbl = let add id x tbl = {tbl with current = Ident.add id x tbl.current} - let add_open slot wrap components next = + let add_open slot wrap root components next = let using = match slot with | None -> None @@ -144,9 +230,17 @@ module TycompTbl = in { current = Ident.empty; - opened = Some {using; components; next}; + opened = Some {using; components; root; next}; } + let remove_last_open rt tbl = + match tbl.opened with + | Some {root; next; _} when Path.same rt root -> + { next with current = + Ident.fold_all Ident.add tbl.current next.current } + | _ -> + assert false + let rec find_same id tbl = try Ident.find_same id tbl.current with Not_found as exn -> @@ -171,7 +265,7 @@ module TycompTbl = (Ident.find_all name tbl.current) @ match tbl.opened with | None -> [] - | Some {using; next; components} -> + | Some {using; next; components; root = _} -> let rest = find_all ~mark name next in let using = if mark then using else None in match NameMap.find name components with @@ -185,7 +279,7 @@ module TycompTbl = let rec fold_name f tbl acc = let acc = Ident.fold_name (fun _id d -> f d) tbl.current acc in match tbl.opened with - | Some {using = _; next; components} -> + | Some {using = _; next; components; root = _} -> acc |> NameMap.fold (fun _name -> List.fold_right f) @@ -290,6 +384,14 @@ module IdTbl = layer = Open {using; root; components; next}; } + let remove_last_open rt tbl = + match tbl.layer with + | Open {root; next; _} when Path.same rt root -> + { next with current = + Ident.fold_all Ident.add tbl.current next.current } + | _ -> + assert false + let add_lock mode next = { current = Ident.empty; layer = Lock {mode; next} } @@ -426,8 +528,10 @@ module IdTbl = end -type type_descriptions = - constructor_description list * label_description list +type type_descr_kind = + (label_description, constructor_description) type_kind + +type type_descriptions = type_descr_kind let in_signature_flag = 0x01 @@ -453,7 +557,7 @@ and module_components = comps: (components_maker, (module_components_repr, module_components_failure) result) - EnvLazy.t; + Lazy_backtrack.t; } and components_maker = { @@ -462,6 +566,7 @@ and components_maker = { cm_path: Path.t; cm_addr: address_lazy; cm_mty: Subst.Lazy.modtype; + cm_shape: Shape.t; } and module_components_repr = @@ -487,6 +592,7 @@ and functor_components = { fcomp_arg: functor_parameter; (* Formal parameter and argument signature *) fcomp_res: module_type; (* Result signature *) + fcomp_shape: Shape.t; fcomp_cache: (Path.t, module_components) Hashtbl.t; (* For memoization *) fcomp_subst_cache: (Path.t, module_type) Hashtbl.t } @@ -495,12 +601,13 @@ and address_unforced = | Projection of { parent : address_lazy; pos : int; } | ModAlias of { env : t; path : Path.t; } -and address_lazy = (address_unforced, address) EnvLazy.t +and address_lazy = (address_unforced, address) Lazy_backtrack.t and value_data = { vda_description : value_description; vda_address : address_lazy; - vda_mode : Value_mode.t } + vda_mode : Value_mode.t; + vda_shape : Shape.t } and value_entry = | Val_bound of value_data @@ -508,31 +615,39 @@ and value_entry = and constructor_data = { cda_description : constructor_description; - cda_address : address_lazy option; } + cda_address : address_lazy option; + cda_shape: Shape.t; } and label_data = label_description and type_data = { tda_declaration : type_declaration; - tda_descriptions : type_descriptions; } + tda_descriptions : type_descriptions; + tda_shape : Shape.t; } and module_data = { mda_declaration : Subst.Lazy.module_decl; mda_components : module_components; - mda_address : address_lazy; } + mda_address : address_lazy; + mda_shape: Shape.t; } and module_entry = | Mod_local of module_data | Mod_persistent | Mod_unbound of module_unbound_reason -and modtype_data = Subst.Lazy.modtype_declaration +and modtype_data = + { mtda_declaration : Subst.Lazy.modtype_declaration; + mtda_shape : Shape.t; } and class_data = { clda_declaration : class_declaration; - clda_address : address_lazy } + clda_address : address_lazy; + clda_shape : Shape.t } -and cltype_data = class_type_declaration +and cltype_data = + { cltda_declaration : class_type_declaration; + cltda_shape : Shape.t } let empty_structure = Structure_comps { @@ -583,11 +698,6 @@ let error err = raise (Error err) let lookup_error loc env err = error (Lookup_error(loc, env, err)) -let copy_local ~from env = - { env with - local_constraints = from.local_constraints; - flags = from.flags } - let same_constr = ref (fun _ _ _ -> assert false) let check_well_formed_module = ref (fun _ -> assert false) @@ -674,14 +784,21 @@ let components_of_module_maker' = (module_components_repr, module_components_failure) result) let components_of_functor_appl' = - ref ((fun ~loc:_ _f _env _p1 _p2 -> assert false) : - loc:Location.t -> functor_components -> t -> - Path.t -> Path.t -> module_components) + ref ((fun ~loc:_ ~f_path:_ ~f_comp:_ ~arg:_ _env -> assert false) : + loc:Location.t -> f_path:Path.t -> f_comp:functor_components -> + arg:Path.t -> t -> module_components) let check_functor_application = (* to be filled by Includemod *) - ref ((fun ~errors:_ ~loc:_ _env _mty1 _path1 _mty2 _path2 -> assert false) : - errors:bool -> loc:Location.t -> t -> module_type -> - Path.t -> module_type -> Path.t -> unit) + ref ((fun ~errors:_ ~loc:_ + ~lid_whole_app:_ ~f0_path:_ ~args:_ + ~arg_path:_ ~arg_mty:_ ~param_mty:_ + _env + -> assert false) : + errors:bool -> loc:Location.t -> + lid_whole_app:Longident.t -> + f0_path:Path.t -> args:(Path.t * Types.module_type) list -> + arg_path:Path.t -> arg_mty:module_type -> param_mty:module_type -> + t -> unit) let strengthen = (* to be filled with Mtype.strengthen *) ref ((fun ~aliasable:_ _env _mty _path -> assert false) : @@ -695,26 +812,38 @@ let md md_type = (* Print addresses *) let rec print_address ppf = function - | Aident id -> Format.fprintf ppf "%s" (Ident.name id) + | Aunit cu -> Format.fprintf ppf "%s" (Compilation_unit.full_path_as_string cu) + | Alocal id -> Format.fprintf ppf "%s" (Ident.name id) | Adot(a, pos) -> Format.fprintf ppf "%a.[%i]" print_address a pos -(* The name of the compilation unit currently compiled. - "" if outside a compilation unit. *) +type address_head = + | AHunit of Compilation_unit.t + | AHlocal of Ident.t + +let rec address_head = function + | Aunit cu -> AHunit cu + | Alocal id -> AHlocal id + | Adot (a, _) -> address_head a + +(* The name of the compilation unit currently compiled. *) module Current_unit_name : sig - val get : unit -> modname - val set : modname -> unit - val is : modname -> bool + val get : unit -> Compilation_unit.t option + val set : Compilation_unit.t option -> unit + val is : string -> bool val is_ident : Ident.t -> bool val is_path : Path.t -> bool end = struct - let current_unit = - ref "" let get () = - !current_unit - let set name = - current_unit := name + Compilation_unit.get_current () + let set comp_unit = + Compilation_unit.set_current comp_unit + let get_name () = + Option.map Compilation_unit.name (get ()) let is name = - !current_unit = name + let current_name_string = + Option.map Compilation_unit.Name.to_string (get_name ()) + in + Option.equal String.equal current_name_string (Some name) let is_ident id = Ident.is_global id && is (Ident.name id) let is_path = function @@ -770,16 +899,17 @@ let add_persistent_structure id env = { env with modules; summary } end -let components_of_module ~alerts ~uid env ps path addr mty = +let components_of_module ~alerts ~uid env ps path addr mty shape = { alerts; uid; - comps = EnvLazy.create { + comps = Lazy_backtrack.create { cm_env = env; cm_prefixing_subst = ps; cm_path = path; cm_addr = addr; cm_mty = mty; + cm_shape = shape; } } @@ -787,7 +917,7 @@ let sign_of_cmi ~freshen { Persistent_env.Persistent_signature.cmi; _ } = let name = cmi.cmi_name in let sign = cmi.cmi_sign in let flags = cmi.cmi_flags in - let id = Ident.create_persistent name in + let id = Ident.create_persistent (Compilation_unit.name_as_string name) in let path = Pident id in let alerts = List.fold_left (fun acc -> function Alerts s -> s | _ -> acc) @@ -798,13 +928,16 @@ let sign_of_cmi ~freshen { Persistent_env.Persistent_signature.cmi; _ } = { md_type = Mty_signature sign; md_loc = Location.none; md_attributes = []; - md_uid = Uid.of_compilation_unit_id id; + md_uid = Uid.of_compilation_unit_id name; } in - let mda_address = EnvLazy.create_forced (Aident id) in + let mda_address = Lazy_backtrack.create_forced (Aunit name) in let mda_declaration = Subst.(Lazy.module_decl Make_local identity (Lazy.of_module_decl md)) in + let mda_shape = + Shape.for_persistent_unit (name |> Compilation_unit.full_path_as_string) + in let mda_components = let mty = Subst.Lazy.of_modtype (Mty_signature sign) in let mty = @@ -815,12 +948,13 @@ let sign_of_cmi ~freshen { Persistent_env.Persistent_signature.cmi; _ } = in components_of_module ~alerts ~uid:md.md_uid empty Subst.identity - path mda_address mty + path mda_address mty mda_shape in { mda_declaration; mda_components; mda_address; + mda_shape; } let read_sign_of_cmi = sign_of_cmi ~freshen:true @@ -861,10 +995,12 @@ let reset_declaration_caches () = Types.Uid.Tbl.clear !type_declarations; Types.Uid.Tbl.clear !module_declarations; Types.Uid.Tbl.clear !used_constructors; + Types.Uid.Tbl.clear !used_labels; + Types.Uid.Tbl.clear !uid_to_loc; () let reset_cache ~preserve_persistent_env = - Current_unit_name.set ""; + Compilation_unit.set_current None; if not preserve_persistent_env then Persistent_env.clear !persistent_env; reset_declaration_caches (); @@ -880,9 +1016,9 @@ let reset_cache_toplevel () = let get_components_res c = match Persistent_env.can_load_cmis !persistent_env with | Persistent_env.Can_load_cmis -> - EnvLazy.force !components_of_module_maker' c.comps + Lazy_backtrack.force !components_of_module_maker' c.comps | Persistent_env.Cannot_load_cmis log -> - EnvLazy.force_logged log !components_of_module_maker' c.comps + Lazy_backtrack.force_logged log !components_of_module_maker' c.comps let get_components c = match get_components_res c with @@ -911,9 +1047,18 @@ let modtype_of_functor_appl fcomp p1 p2 = Hashtbl.add fcomp.fcomp_subst_cache p2 mty; mty -let check_functor_appl ~errors ~loc env p1 f arg p2 md = - if not (Hashtbl.mem f.fcomp_cache p2) then - !check_functor_application ~errors ~loc env md.md_type p2 arg p1 +let check_functor_appl + ~errors ~loc ~lid_whole_app ~f0_path ~args + ~f_comp + ~arg_path ~arg_mty ~param_mty + env = + if not (Hashtbl.mem f_comp.fcomp_cache arg_path) then + !check_functor_application + ~errors ~loc ~lid_whole_app ~f0_path ~args + ~arg_path ~arg_mty ~param_mty + env + +let modname_of_ident id = Ident.name id |> Compilation_unit.Name.of_string (* Lookup by identifier *) @@ -921,7 +1066,7 @@ let find_ident_module id env = match find_same_module id env.modules with | Mod_local data -> data | Mod_unbound _ -> raise Not_found - | Mod_persistent -> find_pers_mod (Ident.name id) + | Mod_persistent -> find_pers_mod (id |> modname_of_ident) let rec find_module_components path env = match path with @@ -929,10 +1074,10 @@ let rec find_module_components path env = | Pdot(p, s) -> let sc = find_structure_components p env in (NameMap.find s sc.comp_modules).mda_components - | Papply(p1, p2) -> - let fc = find_functor_components p1 env in + | Papply(f_path, arg) -> + let f_comp = find_functor_components f_path env in let loc = Location.(in_file !input_name) in - !components_of_functor_appl' ~loc fc env p1 p2 + !components_of_functor_appl' ~loc ~f_path ~f_comp ~arg env and find_structure_components path env = match get_components (find_module_components path env) with @@ -1002,10 +1147,10 @@ let find_type_full path env = let find_modtype_lazy path env = match path with - | Pident id -> IdTbl.find_same id env.modtypes + | Pident id -> (IdTbl.find_same id env.modtypes).mtda_declaration | Pdot(p, s) -> let sc = find_structure_components p env in - NameMap.find s sc.comp_modtypes + (NameMap.find s sc.comp_modtypes).mtda_declaration | Papply _ -> raise Not_found let find_modtype path env = @@ -1021,10 +1166,10 @@ let find_class_full path env = let find_cltype path env = match path with - | Pident id -> IdTbl.find_same id env.cltypes + | Pident id -> (IdTbl.find_same id env.cltypes).cltda_declaration | Pdot(p, s) -> let sc = find_structure_components p env in - NameMap.find s sc.comp_cltypes + (NameMap.find s sc.comp_cltypes).cltda_declaration | Papply _ -> raise Not_found let find_value path env = @@ -1044,27 +1189,44 @@ let type_of_cstr path = function let labels = List.map snd (Datarepr.labels_of_type path decl) in - { tda_declaration = decl; tda_descriptions = ([], labels) } - | _ -> - assert false + begin match decl.type_kind with + | Type_record (_, repr) -> + { + tda_declaration = decl; + tda_descriptions = Type_record (labels, repr); + tda_shape = Shape.leaf decl.type_uid; + } + | _ -> assert false + end + | _ -> assert false -let find_type_full path env = +let find_type_data path env = match Path.constructor_typath path with | Regular p -> begin match Path.Map.find p env.local_constraints with | decl -> - { tda_declaration = decl; tda_descriptions = [], [] } + { + tda_declaration = decl; + tda_descriptions = Type_abstract; + tda_shape = Shape.leaf decl.type_uid; + } | exception Not_found -> find_type_full p env end | Cstr (ty_path, s) -> + (* This case corresponds to an inlined record *) let tda = try find_type_full ty_path env with Not_found -> assert false in - let (cstrs, _) = tda.tda_descriptions in let cstr = - try List.find (fun cstr -> cstr.cstr_name = s) cstrs - with Not_found -> assert false + begin match tda.tda_descriptions with + | Type_variant (cstrs, _) -> begin + try + List.find (fun cstr -> cstr.cstr_name = s) cstrs + with Not_found -> assert false + end + | Type_record _ | Type_abstract | Type_open -> assert false + end in type_of_cstr path cstr | LocalExt id -> @@ -1088,24 +1250,27 @@ let find_type_full path env = | _ -> assert false let find_type p env = - (find_type_full p env).tda_declaration + (find_type_data p env).tda_declaration let find_type_descrs p env = - (find_type_full p env).tda_descriptions + (find_type_data p env).tda_descriptions let rec find_module_address path env = match path with - | Pident id -> get_address (find_ident_module id env).mda_address + | Pident id -> find_ident_module_address id env | Pdot(p, s) -> let c = find_structure_components p env in get_address (NameMap.find s c.comp_modules).mda_address | Papply _ -> raise Not_found +and find_ident_module_address id env = + get_address (find_ident_module id env).mda_address + and force_address = function | Projection { parent; pos } -> Adot(get_address parent, pos) | ModAlias { env; path } -> find_module_address path env and get_address a = - EnvLazy.force force_address a + Lazy_backtrack.force force_address a let find_value_address path env = get_address (find_value_full path env).vda_address @@ -1155,13 +1320,59 @@ let reset_probes () = probes := String.Set.empty let add_probe name = probes := String.Set.add name !probes let has_probe name = String.Set.mem name !probes +let find_shape env (ns : Shape.Sig_component_kind.t) id = + match ns with + | Type -> + (IdTbl.find_same id env.types).tda_shape + | Extension_constructor -> + (TycompTbl.find_same id env.constrs).cda_shape + | Value -> + begin match IdTbl.find_same id env.values with + | Val_bound x -> x.vda_shape + | Val_unbound _ -> raise Not_found + end + | Module -> + begin match IdTbl.find_same id env.modules with + | Mod_local { mda_shape; _ } -> mda_shape + | Mod_persistent -> Shape.for_persistent_unit (Ident.name id) + | Mod_unbound _ -> + (* Only present temporarily while approximating the environment for + recursive modules. + [find_shape] is only ever called after the environment gets + properly populated. *) + assert false + | exception Not_found + when Ident.is_global id && not (Current_unit_name.is_ident id) -> + Shape.for_persistent_unit (Ident.name id) + end + | Module_type -> + (IdTbl.find_same id env.modtypes).mtda_shape + | Class -> + (IdTbl.find_same id env.classes).clda_shape + | Class_type -> + (IdTbl.find_same id env.cltypes).cltda_shape + +let shape_of_path ~namespace env = + Shape.of_path ~namespace ~find_shape:(find_shape env) + +let shape_or_leaf uid = function + | None -> Shape.leaf uid + | Some shape -> shape + let required_globals = s_ref [] let reset_required_globals () = required_globals := [] let get_required_globals () = !required_globals -let add_required_global id = - if Ident.is_global_or_predef id && not !Clflags.transparent_modules - && not (List.exists (Ident.same id) !required_globals) - then required_globals := id :: !required_globals +let add_required_unit cu = + if not (List.exists (Compilation_unit.equal cu) !required_globals) + then required_globals := cu :: !required_globals +let add_required_ident id env = + if not !Clflags.transparent_modules && Ident.is_global id then + let address = find_ident_module_address id env in + match address_head address with + | AHlocal _ -> () + | AHunit cu -> add_required_unit cu +let add_required_global path env = + add_required_ident (Path.head path) env let rec normalize_module_path lax env = function | Pident id as path when lax && Ident.is_global id -> @@ -1182,10 +1393,11 @@ and expand_module_path lax env path = try match find_module_lazy ~alias:true path env with {mdl_type=MtyL_alias path1} -> let path' = normalize_module_path lax env path1 in - if lax || !Clflags.transparent_modules then path' else - let id = Path.head path in - if Ident.is_global_or_predef id && not (Ident.same id (Path.head path')) - then add_required_global id; + if not (lax || !Clflags.transparent_modules) then begin + let id = Path.head path in + if Ident.is_global_or_predef id && not (Ident.same id (Path.head path')) + then add_required_global (Pident id) env + end; path' | _ -> path with Not_found when lax @@ -1298,10 +1510,10 @@ let make_copy_of_types env0 = let memo = Hashtbl.create 16 in let copy t = try - Hashtbl.find memo t.id + Hashtbl.find memo (get_id t) with Not_found -> let t2 = Subst.type_expr Subst.identity t in - Hashtbl.add memo t.id t2; + Hashtbl.add memo (get_id t) t2; t2 in let f = function @@ -1315,7 +1527,7 @@ let make_copy_of_types env0 = IdTbl.map f env0.values in (fun env -> - if env.values != env0.values then fatal_error "Env.make_copy_of_types"; + (*if env.values != env0.values then fatal_error "Env.make_copy_of_types";*) {env with values; summary = Env_copy_types env.summary} ) @@ -1332,7 +1544,7 @@ let rec scrape_alias_for_visit env mty = match path with | Pident id when Ident.is_global id - && not (Persistent_env.looked_up !persistent_env (Ident.name id)) -> + && not (Persistent_env.looked_up !persistent_env (id |> modname_of_ident)) -> false | path -> (* PR#6600: find_module may raise Not_found *) try @@ -1346,7 +1558,7 @@ let iter_env wrap proj1 proj2 f env () = let rec iter_components path path' mcomps = let cont () = let visit = - match EnvLazy.get_arg mcomps.comps with + match Lazy_backtrack.get_arg mcomps.comps with | None -> true | Some { cm_mty; _ } -> scrape_alias_for_visit env cm_mty @@ -1372,7 +1584,7 @@ let iter_env wrap proj1 proj2 f env () = | Mod_local data -> iter_components (Pident id) path data.mda_components | Mod_persistent -> - let modname = Ident.name id in + let modname = modname_of_ident id in match Persistent_env.find_in_cache !persistent_env modname with | None -> () | Some data -> @@ -1395,8 +1607,8 @@ let same_types env1 env2 = let used_persistent () = Persistent_env.fold !persistent_env - (fun s _m r -> Concr.add s r) - Concr.empty + (fun s _m r -> Compilation_unit.Name.Set.add s r) + Compilation_unit.Name.Set.empty let find_all_comps wrap proj s (p, mda) = match get_components mda.mda_components with @@ -1524,27 +1736,30 @@ let add_to_tbl id decl tbl = let decls = try NameMap.find id tbl with Not_found -> [] in NameMap.add id (decl :: decls) tbl +let primitive_address_error = + Invalid_argument "Primitives don't have addresses" + let value_declaration_address (_ : t) id decl = match decl.val_kind with - | Val_prim _ -> EnvLazy.create_failed Not_found - | _ -> EnvLazy.create_forced (Aident id) + | Val_prim _ -> Lazy_backtrack.create_failed primitive_address_error + | _ -> Lazy_backtrack.create_forced (Alocal id) let extension_declaration_address (_ : t) id (_ : extension_constructor) = - EnvLazy.create_forced (Aident id) + Lazy_backtrack.create_forced (Alocal id) let class_declaration_address (_ : t) id (_ : class_declaration) = - EnvLazy.create_forced (Aident id) + Lazy_backtrack.create_forced (Alocal id) let module_declaration_address env id presence md = match presence with | Mp_absent -> begin let open Subst.Lazy in match md.mdl_type with - | MtyL_alias path -> EnvLazy.create (ModAlias {env; path}) + | MtyL_alias path -> Lazy_backtrack.create (ModAlias {env; path}) | _ -> assert false end | Mp_present -> - EnvLazy.create_forced (Aident id) + Lazy_backtrack.create_forced (Alocal id) let is_identchar c = (* This should be kept in sync with the [identchar_latin1] character class @@ -1558,7 +1773,7 @@ let is_identchar c = let rec components_of_module_maker {cm_env; cm_prefixing_subst; - cm_path; cm_addr; cm_mty} : _ result = + cm_path; cm_addr; cm_mty; cm_shape} : _ result = match scrape_alias cm_env cm_mty with MtyL_signature sg -> let c = @@ -1578,7 +1793,7 @@ let rec components_of_module_maker Projection { parent = cm_addr; pos = !pos } in incr pos; - EnvLazy.create addr + Lazy_backtrack.create addr in List.iter (fun ((item : Subst.Lazy.signature_item), path) -> match item with @@ -1586,41 +1801,59 @@ let rec components_of_module_maker let decl' = Subst.value_description sub decl in let addr = match decl.val_kind with - | Val_prim _ -> EnvLazy.create_failed Not_found + | Val_prim _ -> Lazy_backtrack.create_failed primitive_address_error | _ -> next_address () in - let vda = { vda_description = decl'; - vda_address = addr; - vda_mode = Value_mode.global } in + let vda_shape = Shape.proj cm_shape (Shape.Item.value id) in + let vda = + { vda_description = decl'; vda_address = addr; + vda_mode = Value_mode.global; vda_shape } + in c.comp_values <- NameMap.add (Ident.name id) vda c.comp_values; | SigL_type(id, decl, _, _) -> let final_decl = Subst.type_declaration sub decl in - Datarepr.set_row_name final_decl + Btype.set_static_row_name final_decl (Subst.type_path sub (Path.Pident id)); - let constructors = - List.map snd - (Datarepr.constructors_of_type ~current_unit:(get_unit_name ()) - path final_decl) + let descrs = + match decl.type_kind with + | Type_variant (_,repr) -> + let cstrs = List.map snd + (Datarepr.constructors_of_type path final_decl + ~current_unit:(get_unit_name ())) + in + List.iter + (fun descr -> + let cda_shape = Shape.leaf descr.cstr_uid in + let cda = { + cda_description = descr; + cda_address = None; + cda_shape } + in + c.comp_constrs <- + add_to_tbl descr.cstr_name cda c.comp_constrs + ) cstrs; + Type_variant (cstrs, repr) + | Type_record (_, repr) -> + let lbls = List.map snd + (Datarepr.labels_of_type path final_decl) + in + List.iter + (fun descr -> + c.comp_labels <- + add_to_tbl descr.lbl_name descr c.comp_labels) + lbls; + Type_record (lbls, repr) + | Type_abstract -> Type_abstract + | Type_open -> Type_open in - let labels = - List.map snd (Datarepr.labels_of_type path final_decl) in + let shape = Shape.proj cm_shape (Shape.Item.type_ id) in let tda = { tda_declaration = final_decl; - tda_descriptions = (constructors, labels); } + tda_descriptions = descrs; + tda_shape = shape; } in c.comp_types <- NameMap.add (Ident.name id) tda c.comp_types; - List.iter - (fun descr -> - let cda = { cda_description = descr; cda_address = None } in - c.comp_constrs <- - add_to_tbl descr.cstr_name cda c.comp_constrs) - constructors; - List.iter - (fun descr -> - c.comp_labels <- - add_to_tbl descr.lbl_name descr c.comp_labels) - labels; - env := store_type_infos id decl !env + env := store_type_infos ~tda_shape:shape id decl !env | SigL_typext(id, ext, _, _) -> let ext' = Subst.extension_constructor sub ext in let descr = @@ -1628,7 +1861,12 @@ let rec components_of_module_maker ext' in let addr = next_address () in - let cda = { cda_description = descr; cda_address = Some addr } in + let cda_shape = + Shape.proj cm_shape (Shape.Item.extension_constructor id) + in + let cda = + { cda_description = descr; cda_address = Some addr; cda_shape } + in c.comp_constrs <- add_to_tbl (Ident.name id) cda c.comp_constrs | SigL_module(id, pres, md, _, _) -> let md' = @@ -1642,7 +1880,7 @@ let rec components_of_module_maker | Mp_absent -> begin match md.mdl_type with | MtyL_alias path -> - EnvLazy.create (ModAlias {env = !env; path}) + Lazy_backtrack.create (ModAlias {env = !env; path}) | _ -> assert false end | Mp_present -> next_address () @@ -1650,20 +1888,22 @@ let rec components_of_module_maker let alerts = Builtin_attributes.alerts_of_attrs md.mdl_attributes in + let shape = Shape.proj cm_shape (Shape.Item.module_ id) in let comps = components_of_module ~alerts ~uid:md.mdl_uid !env - sub path addr md.mdl_type + sub path addr md.mdl_type shape in let mda = { mda_declaration = md'; mda_components = comps; - mda_address = addr } + mda_address = addr; + mda_shape = shape; } in c.comp_modules <- NameMap.add (Ident.name id) mda c.comp_modules; env := store_module ~update_summary:false ~check:None - id addr pres md !env + id addr pres md shape !env | SigL_modtype(id, decl, _) -> let final_decl = (* The prefixed items get the same scope as [cm_path], which is @@ -1671,18 +1911,30 @@ let rec components_of_module_maker Subst.Lazy.modtype_decl (Rescope (Path.scope cm_path)) sub decl in + let shape = Shape.proj cm_shape (Shape.Item.module_type id) in + let mtda = + { mtda_declaration = final_decl; + mtda_shape = shape; } + in c.comp_modtypes <- - NameMap.add (Ident.name id) final_decl c.comp_modtypes; - env := store_modtype ~update_summary:false id decl !env + NameMap.add (Ident.name id) mtda c.comp_modtypes; + env := store_modtype ~update_summary:false id decl shape !env | SigL_class(id, decl, _, _) -> let decl' = Subst.class_declaration sub decl in let addr = next_address () in - let clda = { clda_declaration = decl'; clda_address = addr } in + let shape = Shape.proj cm_shape (Shape.Item.class_ id) in + let clda = + { clda_declaration = decl'; + clda_address = addr; + clda_shape = shape; } + in c.comp_classes <- NameMap.add (Ident.name id) clda c.comp_classes | SigL_class_type(id, decl, _, _) -> let decl' = Subst.cltype_declaration sub decl in + let shape = Shape.proj cm_shape (Shape.Item.class_type id) in + let cltda = { cltda_declaration = decl'; cltda_shape = shape } in c.comp_cltypes <- - NameMap.add (Ident.name id) decl' c.comp_cltypes) + NameMap.add (Ident.name id) cltda c.comp_cltypes) items_and_paths; Ok (Structure_comps c) | MtyL_functor(arg, ty_res) -> @@ -1698,6 +1950,7 @@ let rec components_of_module_maker | Named (param, ty_arg) -> Named (param, force_modtype (modtype scoping sub ty_arg))); fcomp_res = force_modtype (modtype scoping sub ty_res); + fcomp_shape = cm_shape; fcomp_cache = Hashtbl.create 17; fcomp_subst_cache = Hashtbl.create 17 }) | MtyL_ident _ -> Error No_components_abstract @@ -1730,87 +1983,156 @@ and check_value_name name loc = error (Illegal_value_name(loc, name)) done -and store_value ?check mode id addr decl env = +and store_value ?check mode id addr decl shape env = check_value_name (Ident.name id) decl.val_loc; + Builtin_attributes.mark_alerts_used decl.val_attributes; Option.iter (fun f -> check_usage decl.val_loc id decl.val_uid f !value_declarations) check; - let vda = { vda_description = decl; vda_address = addr; vda_mode = mode } in + let vda = + { vda_description = decl; + vda_address = addr; + vda_mode = mode; + vda_shape = shape } + in { env with values = IdTbl.add id (Val_bound vda) env.values; summary = Env_value(env.summary, id, decl) } -and store_type ~check id info env = +and store_constructor ~check type_decl type_id cstr_id cstr env = + if check && not type_decl.type_loc.Location.loc_ghost + && Warnings.is_active (Warnings.Unused_constructor ("", Unused)) + then begin + let ty_name = Ident.name type_id in + let name = cstr.cstr_name in + let loc = cstr.cstr_loc in + let k = cstr.cstr_uid in + let priv = type_decl.type_private in + if not (Types.Uid.Tbl.mem !used_constructors k) then begin + let used = constructor_usages () in + Types.Uid.Tbl.add !used_constructors k + (add_constructor_usage used); + if not (ty_name = "" || ty_name.[0] = '_') + then + !add_delayed_check_forward + (fun () -> + Option.iter + (fun complaint -> + if not (is_in_signature env) then + Location.prerr_warning loc + (Warnings.Unused_constructor(name, complaint))) + (constructor_usage_complaint ~rebind:false priv used)); + end; + end; + Builtin_attributes.mark_alerts_used cstr.cstr_attributes; + Builtin_attributes.mark_warn_on_literal_pattern_used + cstr.cstr_attributes; + let cda_shape = Shape.leaf cstr.cstr_uid in + { env with + constrs = + TycompTbl.add cstr_id + { cda_description = cstr; cda_address = None; cda_shape } env.constrs; + } + +and store_label ~check type_decl type_id lbl_id lbl env = + if check && not type_decl.type_loc.Location.loc_ghost + && Warnings.is_active (Warnings.Unused_field ("", Unused)) + then begin + let ty_name = Ident.name type_id in + let priv = type_decl.type_private in + let name = lbl.lbl_name in + let loc = lbl.lbl_loc in + let mut = lbl.lbl_mut in + let k = lbl.lbl_uid in + if not (Types.Uid.Tbl.mem !used_labels k) then + let used = label_usages () in + Types.Uid.Tbl.add !used_labels k + (add_label_usage used); + if not (ty_name = "" || ty_name.[0] = '_' || name.[0] = '_') + then !add_delayed_check_forward + (fun () -> + Option.iter + (fun complaint -> + if not (is_in_signature env) then + Location.prerr_warning + loc (Warnings.Unused_field(name, complaint))) + (label_usage_complaint priv mut used)) + end; + Builtin_attributes.mark_alerts_used lbl.lbl_attributes; + { env with + labels = TycompTbl.add lbl_id lbl env.labels; + } + +and store_type ~check id info shape env = let loc = info.type_loc in if check then check_usage loc id info.type_uid (fun s -> Warnings.Unused_type_declaration s) !type_declarations; - let path = Pident id in - let constructors = - Datarepr.constructors_of_type path info - ~current_unit:(get_unit_name ()) + let descrs, env = + let path = Pident id in + match info.type_kind with + | Type_variant (_,repr) -> + let constructors = Datarepr.constructors_of_type path info + ~current_unit:(get_unit_name ()) + in + Type_variant (List.map snd constructors, repr), + List.fold_left + (fun env (cstr_id, cstr) -> + store_constructor ~check info id cstr_id cstr env) + env constructors + | Type_record (_, repr) -> + let labels = Datarepr.labels_of_type path info in + Type_record (List.map snd labels, repr), + List.fold_left + (fun env (lbl_id, lbl) -> + store_label ~check info id lbl_id lbl env) + env labels + | Type_abstract -> Type_abstract, env + | Type_open -> Type_open, env in - let labels = Datarepr.labels_of_type path info in - let descrs = (List.map snd constructors, List.map snd labels) in - let tda = { tda_declaration = info; tda_descriptions = descrs } in - if check && not loc.Location.loc_ghost && - Warnings.is_active (Warnings.Unused_constructor ("", false, false)) - then begin - let ty_name = Ident.name id in - let priv = info.type_private in - List.iter - begin fun (_, cstr) -> - let name = cstr.cstr_name in - let loc = cstr.cstr_loc in - let k = cstr.cstr_uid in - if not (Types.Uid.Tbl.mem !used_constructors k) then - let used = constructor_usages () in - Types.Uid.Tbl.add !used_constructors k - (add_constructor_usage ~rebind:false priv used); - if not (ty_name = "" || ty_name.[0] = '_') - then !add_delayed_check_forward - (fun () -> - if not (is_in_signature env) && not used.cu_positive then - Location.prerr_warning loc - (Warnings.Unused_constructor - (name, used.cu_pattern, used.cu_privatize))) - end - constructors - end; + let tda = + { tda_declaration = info; + tda_descriptions = descrs; + tda_shape = shape } + in + Builtin_attributes.mark_alerts_used info.type_attributes; { env with - constrs = - List.fold_right - (fun (id, descr) constrs -> - let cda = { cda_description = descr; cda_address = None } in - TycompTbl.add id cda constrs) - constructors env.constrs; - labels = - List.fold_right - (fun (id, descr) labels -> TycompTbl.add id descr labels) - labels env.labels; types = IdTbl.add id tda env.types; summary = Env_type(env.summary, id, info) } -and store_type_infos id info env = +and store_type_infos ~tda_shape id info env = (* Simplified version of store_type that doesn't compute and store constructor and label infos, but simply record the arity and manifest-ness of the type. Used in components_of_module to keep track of type abbreviations (e.g. type t = float) in the computation of label representations. *) - let tda = { tda_declaration = info; tda_descriptions = [], [] } in + let tda = + { + tda_declaration = info; + tda_descriptions = Type_abstract; + tda_shape + } + in { env with types = IdTbl.add id tda env.types; summary = Env_type(env.summary, id, info) } -and store_extension ~check ~rebind id addr ext env = +and store_extension ~check ~rebind id addr ext shape env = let loc = ext.ext_loc in let cstr = Datarepr.extension_descr ~current_unit:(get_unit_name ()) (Pident id) ext in - let cda = { cda_description = cstr; cda_address = Some addr } in + let cda = + { cda_description = cstr; + cda_address = Some addr; + cda_shape = shape } + in + Builtin_attributes.mark_alerts_used ext.ext_attributes; + Builtin_attributes.mark_alerts_used cstr.cstr_attributes; + Builtin_attributes.mark_warn_on_literal_pattern_used cstr.cstr_attributes; if check && not loc.Location.loc_ghost && - Warnings.is_active (Warnings.Unused_extension ("", false, false, false)) + Warnings.is_active (Warnings.Unused_extension ("", false, Unused)) then begin let priv = ext.ext_private in let is_exception = Path.same ext.ext_type_path Predef.path_exn in @@ -1819,15 +2141,16 @@ and store_extension ~check ~rebind id addr ext env = if not (Types.Uid.Tbl.mem !used_constructors k) then begin let used = constructor_usages () in Types.Uid.Tbl.add !used_constructors k - (add_constructor_usage ~rebind priv used); + (add_constructor_usage used); !add_delayed_check_forward - (fun () -> - if not (is_in_signature env) && not used.cu_positive then - Location.prerr_warning loc - (Warnings.Unused_extension - (name, is_exception, used.cu_pattern, used.cu_privatize) - ) - ) + (fun () -> + Option.iter + (fun complaint -> + if not (is_in_signature env) then + Location.prerr_warning loc + (Warnings.Unused_extension + (name, is_exception, complaint))) + (constructor_usage_complaint ~rebind priv used)) end; end; { env with @@ -1835,7 +2158,7 @@ and store_extension ~check ~rebind id addr ext env = summary = Env_extension(env.summary, id, ext) } and store_module ?(update_summary=true) ~check - id addr presence md env = + id addr presence md shape env = let open Subst.Lazy in let loc = md.mdl_loc in Option.iter @@ -1843,12 +2166,13 @@ and store_module ?(update_summary=true) ~check let alerts = Builtin_attributes.alerts_of_attrs md.mdl_attributes in let comps = components_of_module ~alerts ~uid:md.mdl_uid - env Subst.identity (Pident id) addr md.mdl_type + env Subst.identity (Pident id) addr md.mdl_type shape in let mda = { mda_declaration = md; mda_components = comps; - mda_address = addr } + mda_address = addr; + mda_shape = shape } in let summary = if not update_summary then env.summary @@ -1857,53 +2181,67 @@ and store_module ?(update_summary=true) ~check modules = IdTbl.add id (Mod_local mda) env.modules; summary } -and store_modtype ?(update_summary=true) id info env = +and store_modtype ?(update_summary=true) id info shape env = + Builtin_attributes.mark_alerts_used info.Subst.Lazy.mtdl_attributes; + let mtda = { mtda_declaration = info; mtda_shape = shape } in let summary = if not update_summary then env.summary else Env_modtype (env.summary, id, Subst.Lazy.force_modtype_decl info) in { env with - modtypes = IdTbl.add id info env.modtypes; + modtypes = IdTbl.add id mtda env.modtypes; summary } -and store_class id addr desc env = - let clda = { clda_declaration = desc; clda_address = addr } in +and store_class id addr desc shape env = + Builtin_attributes.mark_alerts_used desc.cty_attributes; + let clda = + { clda_declaration = desc; + clda_address = addr; + clda_shape = shape; } + in { env with classes = IdTbl.add id clda env.classes; summary = Env_class(env.summary, id, desc) } -and store_cltype id desc env = +and store_cltype id desc shape env = + Builtin_attributes.mark_alerts_used desc.clty_attributes; + let cltda = { cltda_declaration = desc; cltda_shape = shape } in { env with - cltypes = IdTbl.add id desc env.cltypes; + cltypes = IdTbl.add id cltda env.cltypes; summary = Env_cltype(env.summary, id, desc) } let scrape_alias env mty = scrape_alias env mty (* Compute the components of a functor application in a path. *) -let components_of_functor_appl ~loc f env p1 p2 = +let components_of_functor_appl ~loc ~f_path ~f_comp ~arg env = try - Hashtbl.find f.fcomp_cache p2 + let c = Hashtbl.find f_comp.fcomp_cache arg in + c with Not_found -> - let p = Papply(p1, p2) in + let p = Papply(f_path, arg) in let sub = - match f.fcomp_arg with + match f_comp.fcomp_arg with | Unit | Named (None, _) -> Subst.identity - | Named (Some param, _) -> Subst.add_module param p2 Subst.identity + | Named (Some param, _) -> Subst.add_module param arg Subst.identity in (* we have to apply eagerly instead of passing sub to [components_of_module] because of the call to [check_well_formed_module]. *) - let mty = Subst.modtype (Rescope (Path.scope p)) sub f.fcomp_res in - let addr = EnvLazy.create_failed Not_found in + let mty = Subst.modtype (Rescope (Path.scope p)) sub f_comp.fcomp_res in + let addr = Lazy_backtrack.create_failed Not_found in !check_well_formed_module env loc ("the signature of " ^ Path.name p) mty; + let shape_arg = + shape_of_path ~namespace:Shape.Sig_component_kind.Module env arg + in + let shape = Shape.app f_comp.fcomp_shape ~arg:shape_arg in let comps = components_of_module ~alerts:Misc.Stdlib.String.Map.empty ~uid:Uid.internal_not_actually_unique (*???*) - env Subst.identity p addr (Subst.Lazy.of_modtype mty) + env Subst.identity p addr (Subst.Lazy.of_modtype mty) shape in - Hashtbl.add f.fcomp_cache p2 comps; + Hashtbl.add f_comp.fcomp_cache arg comps; comps (* Define forward functions *) @@ -1919,18 +2257,21 @@ let add_functor_arg id env = functor_args = Ident.add id () env.functor_args; summary = Env_functor_arg (env.summary, id)} -let add_value ?check ?(mode = Value_mode.global) id desc env = +let add_value ?check ?shape ?(mode = Value_mode.global) id desc env = let addr = value_declaration_address env id desc in - store_value ?check mode id addr desc env + let shape = shape_or_leaf desc.val_uid shape in + store_value ?check mode id addr desc shape env -let add_type ~check id info env = - store_type ~check id info env +let add_type ~check ?shape id info env = + let shape = shape_or_leaf info.type_uid shape in + store_type ~check id info shape env -and add_extension ~check ~rebind id ext env = +and add_extension ~check ?shape ~rebind id ext env = let addr = extension_declaration_address env id ext in - store_extension ~check ~rebind id addr ext env + let shape = shape_or_leaf ext.ext_uid shape in + store_extension ~check ~rebind id addr ext shape env -and add_module_declaration ?(arg=false) ~check id presence md env = +and add_module_declaration ?(arg=false) ?shape ~check id presence md env = let check = if not check then None @@ -1941,29 +2282,45 @@ and add_module_declaration ?(arg=false) ~check id presence md env = in let md = Subst.Lazy.of_module_decl md in let addr = module_declaration_address env id presence md in - let env = store_module ~check id addr presence md env in + let shape = shape_or_leaf md.mdl_uid shape in + let env = store_module ~check id addr presence md shape env in if arg then add_functor_arg id env else env and add_module_declaration_lazy ~update_summary id presence md env = let addr = module_declaration_address env id presence md in - let env = store_module ~update_summary ~check:None id addr presence md env in + let shape = Shape.leaf md.Subst.Lazy.mdl_uid in + let env = + store_module ~update_summary ~check:None id addr presence md shape env + in env -and add_modtype id info env = - store_modtype id (Subst.Lazy.of_modtype_decl info) env +and add_modtype ?shape id info env = + let shape = shape_or_leaf info.mtd_uid shape in + store_modtype id (Subst.Lazy.of_modtype_decl info) shape env and add_modtype_lazy ~update_summary id info env = - store_modtype ~update_summary id info env + let shape = Shape.leaf info.Subst.Lazy.mtdl_uid in + store_modtype ~update_summary id info shape env -and add_class id ty env = +and add_class ?shape id ty env = let addr = class_declaration_address env id ty in - store_class id addr ty env - -and add_cltype id ty env = - store_cltype id ty env + let shape = shape_or_leaf ty.cty_uid shape in + store_class id addr ty shape env + +and add_cltype ?shape id ty env = + let shape = shape_or_leaf ty.clty_uid shape in + store_cltype id ty shape env + +let add_module_lazy ~update_summary id presence mty env = + let md = Subst.Lazy.{mdl_type = mty; + mdl_attributes = []; + mdl_loc = Location.none; + mdl_uid = Uid.internal_not_actually_unique} + in + add_module_declaration_lazy ~update_summary id presence md env -let add_module ?arg id presence mty env = - add_module_declaration ~check:false ?arg id presence (md mty) env +let add_module ?arg ?shape id presence mty env = + add_module_declaration ~check:false ?arg ?shape id presence (md mty) env let add_local_type path info env = { env with @@ -1978,38 +2335,40 @@ let scrape_alias t mty = let enter_value ?check name desc env = let id = Ident.create_local name in let addr = value_declaration_address env id desc in - let env = store_value ?check Value_mode.global id addr desc env in + let env = store_value ?check Value_mode.global id addr desc (Shape.leaf desc.val_uid) env in (id, env) let enter_type ~scope name info env = let id = Ident.create_scoped ~scope name in - let env = store_type ~check:true id info env in + let env = store_type ~check:true id info (Shape.leaf info.type_uid) env in (id, env) let enter_extension ~scope ~rebind name ext env = let id = Ident.create_scoped ~scope name in let addr = extension_declaration_address env id ext in - let env = store_extension ~check:true ~rebind id addr ext env in + let shape = Shape.leaf ext.ext_uid in + let env = store_extension ~check:true ~rebind id addr ext shape env in (id, env) -let enter_module_declaration ~scope ?arg s presence md env = +let enter_module_declaration ~scope ?arg ?shape s presence md env = let id = Ident.create_scoped ~scope s in - (id, add_module_declaration ?arg ~check:true id presence md env) + (id, add_module_declaration ?arg ?shape ~check:true id presence md env) let enter_modtype ~scope name mtd env = let id = Ident.create_scoped ~scope name in - let env = store_modtype id (Subst.Lazy.of_modtype_decl mtd) env in + let shape = Shape.leaf mtd.mtd_uid in + let env = store_modtype id (Subst.Lazy.of_modtype_decl mtd) shape env in (id, env) let enter_class ~scope name desc env = let id = Ident.create_scoped ~scope name in let addr = class_declaration_address env id desc in - let env = store_class id addr desc env in + let env = store_class id addr desc (Shape.leaf desc.cty_uid) env in (id, env) let enter_cltype ~scope name desc env = let id = Ident.create_scoped ~scope name in - let env = store_cltype id desc env in + let env = store_cltype id desc (Shape.leaf desc.clty_uid) env in (id, env) let enter_module ~scope ?arg s presence mty env = @@ -2024,26 +2383,68 @@ let add_region_lock env = (* Insertion of all components of a signature *) -let add_item comp env = +let add_item (map, mod_shape) comp env = + let proj_shape item = + match mod_shape with + | None -> map, None + | Some mod_shape -> + let shape = Shape.proj mod_shape item in + Shape.Map.add map item shape, Some shape + in match comp with - Sig_value(id, decl, _) -> add_value id decl env - | Sig_type(id, decl, _, _) -> add_type ~check:false id decl env + | Sig_value(id, decl, _) -> + let map, shape = proj_shape (Shape.Item.value id) in + map, add_value ?shape id decl env + | Sig_type(id, decl, _, _) -> + let map, shape = proj_shape (Shape.Item.type_ id) in + map, add_type ~check:false ?shape id decl env | Sig_typext(id, ext, _, _) -> - add_extension ~check:false ~rebind:false id ext env + let map, shape = proj_shape (Shape.Item.extension_constructor id) in + map, add_extension ~check:false ?shape ~rebind:false id ext env | Sig_module(id, presence, md, _, _) -> - add_module_declaration ~check:false id presence md env - | Sig_modtype(id, decl, _) -> add_modtype id decl env - | Sig_class(id, decl, _, _) -> add_class id decl env - | Sig_class_type(id, decl, _, _) -> add_cltype id decl env - -let rec add_signature sg env = + let map, shape = proj_shape (Shape.Item.module_ id) in + map, add_module_declaration ~check:false ?shape id presence md env + | Sig_modtype(id, decl, _) -> + let map, shape = proj_shape (Shape.Item.module_type id) in + map, add_modtype ?shape id decl env + | Sig_class(id, decl, _, _) -> + let map, shape = proj_shape (Shape.Item.class_ id) in + map, add_class ?shape id decl env + | Sig_class_type(id, decl, _, _) -> + let map, shape = proj_shape (Shape.Item.class_type id) in + map, add_cltype ?shape id decl env + +let rec add_signature (map, mod_shape) sg env = match sg with - [] -> env - | comp :: rem -> add_signature rem (add_item comp env) + [] -> map, env + | comp :: rem -> + let map, env = add_item (map, mod_shape) comp env in + add_signature (map, mod_shape) rem env -let enter_signature ~scope sg env = +let enter_signature_and_shape ~scope ~parent_shape mod_shape sg env = let sg = Subst.signature (Rescope scope) Subst.identity sg in - sg, add_signature sg env + let shape, env = add_signature (parent_shape, mod_shape) sg env in + sg, shape, env + +let enter_signature ?mod_shape ~scope sg env = + let sg, _, env = + enter_signature_and_shape ~scope ~parent_shape:Shape.Map.empty + mod_shape sg env + in + sg, env + +let enter_signature_and_shape ~scope ~parent_shape mod_shape sg env = + enter_signature_and_shape ~scope ~parent_shape (Some mod_shape) sg env + +let add_value = add_value ?shape:None +let add_type = add_type ?shape:None +let add_extension = add_extension ?shape:None +let add_class = add_class ?shape:None +let add_cltype = add_cltype ?shape:None +let add_modtype = add_modtype ?shape:None +let add_signature sg env = + let _, env = add_signature (Shape.Map.empty, None) sg env in + env (* Add "unbound" bindings *) @@ -2063,7 +2464,7 @@ let enter_unbound_module name reason env = let add_components slot root env0 comps = let add_l w comps env0 = - TycompTbl.add_open slot w comps env0 + TycompTbl.add_open slot w root comps env0 in let add w comps env0 = IdTbl.add_open slot w root comps env0 in let constrs = @@ -2110,6 +2511,43 @@ let open_signature slot root env0 : (_,_) result = | Ok (Structure_comps comps) -> Ok (add_components slot root env0 comps) +let remove_last_open root env0 = + let rec filter_summary summary = + match summary with + Env_empty -> raise Exit + | Env_open (s, p) -> + if Path.same p root then s else raise Exit + | Env_value _ + | Env_type _ + | Env_extension _ + | Env_module _ + | Env_modtype _ + | Env_class _ + | Env_cltype _ + | Env_functor_arg _ + | Env_constraints _ + | Env_persistent _ + | Env_copy_types _ + | Env_value_unbound _ + | Env_module_unbound _ -> + map_summary filter_summary summary + in + match filter_summary env0.summary with + | summary -> + let rem_l tbl = TycompTbl.remove_last_open root tbl + and rem tbl = IdTbl.remove_last_open root tbl in + Some { env0 with + summary; + constrs = rem_l env0.constrs; + labels = rem_l env0.labels; + values = rem env0.values; + types = rem env0.types; + modtypes = rem env0.modtypes; + classes = rem env0.classes; + cltypes = rem env0.cltypes; + modules = rem env0.modules; } + | exception Exit -> + None (* Open a signature from a file *) @@ -2170,7 +2608,7 @@ let open_signature (* Read a signature from a file *) let read_signature modname filename = - let mda = read_pers_mod modname filename in + let mda = read_pers_mod (Compilation_unit.name modname) filename in let md = Subst.Lazy.force_module_decl mda.mda_declaration in match md.md_type with | Mty_signature sg -> sg @@ -2264,24 +2702,28 @@ let mark_extension_used usage ext = | mark -> mark usage | exception Not_found -> () +let mark_label_used usage ld = + match Types.Uid.Tbl.find !used_labels ld.ld_uid with + | mark -> mark usage + | exception Not_found -> () + let mark_constructor_description_used usage env cstr = - let ty_path = - match repr cstr.cstr_res with - | {desc=Tconstr(path, _, _)} -> path - | _ -> assert false - in + let ty_path = Btype.cstr_type_path cstr in mark_type_path_used env ty_path; match Types.Uid.Tbl.find !used_constructors cstr.cstr_uid with | mark -> mark usage | exception Not_found -> () -let mark_label_description_used () env lbl = +let mark_label_description_used usage env lbl = let ty_path = - match repr lbl.lbl_res with - | {desc=Tconstr(path, _, _)} -> path + match get_desc lbl.lbl_res with + | Tconstr(path, _, _) -> path | _ -> assert false in - mark_type_path_used env ty_path + mark_type_path_used env ty_path; + match Types.Uid.Tbl.find !used_labels lbl.lbl_uid with + | mark -> mark usage + | exception Not_found -> () let mark_class_used uid = match Types.Uid.Tbl.find !type_declarations uid with @@ -2388,10 +2830,13 @@ let use_cltype ~use ~loc path desc = (Path.name path) end -let use_label ~use ~loc env lbl = +let use_label ~use ~loc usage env lbl = if use then begin - mark_label_description_used () env lbl; - Builtin_attributes.check_alerts loc lbl.lbl_attributes lbl.lbl_name + mark_label_description_used usage env lbl; + Builtin_attributes.check_alerts loc lbl.lbl_attributes lbl.lbl_name; + if is_mutating_label_usage usage then + Builtin_attributes.check_deprecated_mutable loc lbl.lbl_attributes + lbl.lbl_name end let use_constructor_desc ~use ~loc usage env cstr = @@ -2424,12 +2869,13 @@ let lookup_ident_module (type a) (load : a load) ~errors ~use ~loc s env = | Mod_unbound reason -> report_module_unbound ~errors ~loc env reason | Mod_persistent -> begin + let name = s |> Compilation_unit.Name.of_string in match load with | Don't_load -> - check_pers_mod ~loc s; + check_pers_mod ~loc name; path, (() : a) | Load -> begin - match find_pers_mod s with + match find_pers_mod name with | mda -> use_module ~use ~loc path mda; path, (mda : a) @@ -2473,8 +2919,8 @@ let lookup_ident_type ~errors ~use ~loc s env = let lookup_ident_modtype ~errors ~use ~loc s env = match IdTbl.find_name wrap_identity ~mark:use s env.modtypes with | (path, data) -> - use_modtype ~use ~loc path data; - (path, data) + use_modtype ~use ~loc path data.mtda_declaration; + (path, data.mtda_declaration) | exception Not_found -> may_lookup_error errors loc env (Unbound_modtype (Lident s)) @@ -2488,20 +2934,20 @@ let lookup_ident_class ~errors ~use ~loc s env = let lookup_ident_cltype ~errors ~use ~loc s env = match IdTbl.find_name wrap_identity ~mark:use s env.cltypes with - | (path, data) as res -> - use_cltype ~use ~loc path data; - res + | path, cltda -> + use_cltype ~use ~loc path cltda.cltda_declaration; + path, cltda.cltda_declaration | exception Not_found -> may_lookup_error errors loc env (Unbound_cltype (Lident s)) -let lookup_all_ident_labels ~errors ~use ~loc s env = +let lookup_all_ident_labels ~errors ~use ~loc usage s env = match TycompTbl.find_all ~mark:use s env.labels with | [] -> may_lookup_error errors loc env (Unbound_label (Lident s)) | lbls -> begin List.map (fun (lbl, use_fn) -> let use_fn () = - use_label ~use ~loc env lbl; + use_label ~use ~loc usage env lbl; use_fn () in (lbl, use_fn)) @@ -2529,12 +2975,11 @@ let rec lookup_module_components ~errors ~use ~loc lid env = | Ldot(l, s) -> let path, data = lookup_dot_module ~errors ~use ~loc l s env in path, data.mda_components - | Lapply(l1, l2) -> - let p1, f, arg = lookup_functor_components ~errors ~use ~loc l1 env in - let p2, md = lookup_module ~errors ~use ~loc l2 env in - check_functor_appl ~errors ~loc env p1 f arg p2 md; - let comps = !components_of_functor_appl' ~loc f env p1 p2 in - (Papply(p1, p2), comps) + | Lapply _ as lid -> + let f_path, f_comp, arg = lookup_apply ~errors ~use ~loc lid env in + let comps = + !components_of_functor_appl' ~loc ~f_path ~f_comp ~arg env in + Papply (f_path, arg), comps and lookup_structure_components ~errors ~use ~loc lid env = let path, comps = lookup_module_components ~errors ~use ~loc lid env in @@ -2547,14 +2992,13 @@ and lookup_structure_components ~errors ~use ~loc lid env = | Error (No_components_alias p) -> may_lookup_error errors loc env (Cannot_scrape_alias(lid, p)) -and lookup_functor_components ~errors ~use ~loc lid env = - let path, comps = lookup_module_components ~errors ~use ~loc lid env in +and get_functor_components ~errors ~loc lid env comps = match get_components_res comps with | Ok (Functor_comps fcomps) -> begin match fcomps.fcomp_arg with | Unit -> (* PR#7611 *) may_lookup_error errors loc env (Generative_used_as_applicative lid) - | Named (_, arg) -> path, fcomps, arg + | Named (_, arg) -> fcomps, arg end | Ok (Structure_comps _) -> may_lookup_error errors loc env (Structure_used_as_functor lid) @@ -2563,6 +3007,54 @@ and lookup_functor_components ~errors ~use ~loc lid env = | Error (No_components_alias p) -> may_lookup_error errors loc env (Cannot_scrape_alias(lid, p)) +and lookup_all_args ~errors ~use ~loc lid0 env = + let rec loop_lid_arg args = function + | Lident _ | Ldot _ as f_lid -> + (f_lid, args) + | Lapply (f_lid, arg_lid) -> + let arg_path, arg_md = lookup_module ~errors ~use ~loc arg_lid env in + loop_lid_arg ((f_lid,arg_path,arg_md.md_type)::args) f_lid + in + loop_lid_arg [] lid0 + +and lookup_apply ~errors ~use ~loc lid0 env = + let f0_lid, args0 = lookup_all_args ~errors ~use ~loc lid0 env in + let args_for_errors = List.map (fun (_,p,mty) -> (p,mty)) args0 in + let f0_path, f0_comp = + lookup_module_components ~errors ~use ~loc f0_lid env + in + let check_one_apply ~errors ~loc ~f_lid ~f_comp ~arg_path ~arg_mty env = + let f_comp, param_mty = + get_functor_components ~errors ~loc f_lid env f_comp + in + check_functor_appl + ~errors ~loc ~lid_whole_app:lid0 + ~f0_path ~args:args_for_errors ~f_comp + ~arg_path ~arg_mty ~param_mty + env; + arg_path, f_comp + in + let rec check_apply ~path:f_path ~comp:f_comp = function + | [] -> invalid_arg "Env.lookup_apply: empty argument list" + | [ f_lid, arg_path, arg_mty ] -> + let arg_path, comps = + check_one_apply ~errors ~loc ~f_lid ~f_comp + ~arg_path ~arg_mty env + in + f_path, comps, arg_path + | (f_lid, arg_path, arg_mty) :: args -> + let arg_path, f_comp = + check_one_apply ~errors ~loc ~f_lid ~f_comp + ~arg_path ~arg_mty env + in + let comp = + !components_of_functor_appl' ~loc ~f_path ~f_comp ~arg:arg_path env + in + let path = Papply (f_path, arg_path) in + check_apply ~path ~comp args + in + check_apply ~path:f0_path ~comp:f0_comp args0 + and lookup_module ~errors ~use ~loc lid env = match lid with | Lident s -> @@ -2573,12 +3065,10 @@ and lookup_module ~errors ~use ~loc lid env = let path, data = lookup_dot_module ~errors ~use ~loc l s env in let md = Subst.Lazy.force_module_decl data.mda_declaration in path, md - | Lapply(l1, l2) -> - let p1, fc, arg = lookup_functor_components ~errors ~use ~loc l1 env in - let p2, md2 = lookup_module ~errors ~use ~loc l2 env in - check_functor_appl ~errors ~loc env p1 fc arg p2 md2; - let md = md (modtype_of_functor_appl fc p1 p2) in - Papply(p1, p2), md + | Lapply _ as lid -> + let path_f, comp_f, path_arg = lookup_apply ~errors ~use ~loc lid env in + let md = md (modtype_of_functor_appl comp_f path_f path_arg) in + Papply(path_f, path_arg), md and lookup_dot_module ~errors ~use ~loc l s env = let p, comps = lookup_structure_components ~errors ~use ~loc l env in @@ -2615,10 +3105,10 @@ let lookup_dot_type ~errors ~use ~loc l s env = let lookup_dot_modtype ~errors ~use ~loc l s env = let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in match NameMap.find s comps.comp_modtypes with - | desc -> + | mta -> let path = Pdot(p, s) in - use_modtype ~use ~loc path desc; - (path, desc) + use_modtype ~use ~loc path mta.mtda_declaration; + (path, mta.mtda_declaration) | exception Not_found -> may_lookup_error errors loc env (Unbound_modtype (Ldot(l, s))) @@ -2635,14 +3125,14 @@ let lookup_dot_class ~errors ~use ~loc l s env = let lookup_dot_cltype ~errors ~use ~loc l s env = let (p, comps) = lookup_structure_components ~errors ~use ~loc l env in match NameMap.find s comps.comp_cltypes with - | desc -> + | cltda -> let path = Pdot(p, s) in - use_cltype ~use ~loc path desc; - (path, desc) + use_cltype ~use ~loc path cltda.cltda_declaration; + (path, cltda.cltda_declaration) | exception Not_found -> may_lookup_error errors loc env (Unbound_cltype (Ldot(l, s))) -let lookup_all_dot_labels ~errors ~use ~loc l s env = +let lookup_all_dot_labels ~errors ~use ~loc usage l s env = let (_, comps) = lookup_structure_components ~errors ~use ~loc l env in match NameMap.find s comps.comp_labels with | [] | exception Not_found -> @@ -2650,7 +3140,7 @@ let lookup_all_dot_labels ~errors ~use ~loc l s env = | lbls -> List.map (fun lbl -> - let use_fun () = use_label ~use ~loc env lbl in + let use_fun () = use_label ~use ~loc usage env lbl in (lbl, use_fun)) lbls @@ -2682,11 +3172,9 @@ let lookup_module_path ~errors ~use ~loc ~load lid env : Path.t = else fst (lookup_ident_module Load ~errors ~use ~loc s env) | Ldot(l, s) -> fst (lookup_dot_module ~errors ~use ~loc l s env) - | Lapply(l1, l2) -> - let (p1, f, arg) = lookup_functor_components ~errors ~use ~loc l1 env in - let p2, md2 = lookup_module ~errors ~use ~loc l2 env in - check_functor_appl ~errors ~loc env p1 f arg p2 md2; - Papply(p1, p2) + | Lapply _ as lid -> + let path_f, _comp_f, path_arg = lookup_apply ~errors ~use ~loc lid env in + Papply(path_f, path_arg) let lookup_value ~errors ~use ~loc lid env = match lid with @@ -2729,24 +3217,25 @@ let lookup_cltype ~errors ~use ~loc lid env = | Ldot(l, s) -> lookup_dot_cltype ~errors ~use ~loc l s env | Lapply _ -> assert false -let lookup_all_labels ~errors ~use ~loc lid env = +let lookup_all_labels ~errors ~use ~loc usage lid env = match lid with - | Lident s -> lookup_all_ident_labels ~errors ~use ~loc s env - | Ldot(l, s) -> lookup_all_dot_labels ~errors ~use ~loc l s env + | Lident s -> lookup_all_ident_labels ~errors ~use ~loc usage s env + | Ldot(l, s) -> lookup_all_dot_labels ~errors ~use ~loc usage l s env | Lapply _ -> assert false -let lookup_label ~errors ~use ~loc lid env = - match lookup_all_labels ~errors ~use ~loc lid env with +let lookup_label ~errors ~use ~loc usage lid env = + match lookup_all_labels ~errors ~use ~loc usage lid env with | [] -> assert false | (desc, use) :: _ -> use (); desc -let lookup_all_labels_from_type ~use ~loc ty_path env = +let lookup_all_labels_from_type ~use ~loc usage ty_path env = match find_type_descrs ty_path env with | exception Not_found -> [] - | (_, lbls) -> + | Type_variant _ | Type_abstract | Type_open -> [] + | Type_record (lbls, _) -> List.map (fun lbl -> - let use_fun () = use_label ~use ~loc env lbl in + let use_fun () = use_label ~use ~loc usage env lbl in (lbl, use_fun)) lbls @@ -2764,7 +3253,8 @@ let lookup_constructor ~errors ~use ~loc usage lid env = let lookup_all_constructors_from_type ~use ~loc usage ty_path env = match find_type_descrs ty_path env with | exception Not_found -> [] - | (cstrs, _) -> + | Type_record _ | Type_abstract | Type_open -> [] + | Type_variant (cstrs, _) -> List.map (fun cstr -> let use_fun () = @@ -2808,7 +3298,7 @@ let find_constructor_by_name lid env = let find_label_by_name lid env = let loc = Location.(in_file !input_name) in - lookup_label ~errors:false ~use:false ~loc lid env + lookup_label ~errors:false ~use:false ~loc Projection lid env (* Ordinary lookup functions *) @@ -2849,8 +3339,8 @@ let lookup_constructor ?(use=true) ~loc lid env = let lookup_all_constructors_from_type ?(use=true) ~loc usage ty_path env = lookup_all_constructors_from_type ~use ~loc usage ty_path env -let lookup_all_labels ?(use=true) ~loc lid env = - match lookup_all_labels ~errors:true ~use ~loc lid env with +let lookup_all_labels ?(use=true) ~loc usage lid env = + match lookup_all_labels ~errors:true ~use ~loc usage lid env with | exception Error(Lookup_error(loc', env', err)) -> (Error(loc', env', err) : _ result) | lbls -> Ok lbls @@ -2858,8 +3348,8 @@ let lookup_all_labels ?(use=true) ~loc lid env = let lookup_label ?(use=true) ~loc lid env = lookup_label ~errors:true ~use ~loc lid env -let lookup_all_labels_from_type ?(use=true) ~loc ty_path env = - lookup_all_labels_from_type ~use ~loc ty_path env +let lookup_all_labels_from_type ?(use=true) ~loc usage ty_path env = + lookup_all_labels_from_type ~use ~loc usage ty_path env let lookup_instance_variable ?(use=true) ~loc name env = match IdTbl.find_name_and_modes wrap_value ~mark:use name env.values with @@ -2891,7 +3381,7 @@ let bound_module name env = | exception Not_found -> if Current_unit_name.is name then false else begin - match find_pers_mod name with + match find_pers_mod (name |> Compilation_unit.Name.of_string) with | _ -> true | exception Not_found -> false end @@ -2974,7 +3464,8 @@ let fold_modules f lid env acc = in f name p md acc | Mod_persistent -> - match Persistent_env.find_in_cache !persistent_env name with + let modname = name |> Compilation_unit.Name.of_string in + match Persistent_env.find_in_cache !persistent_env modname with | None -> acc | Some mda -> let md = @@ -3020,13 +3511,15 @@ and fold_types f = and fold_modtypes f = let f l path data acc = f l path (Subst.Lazy.force_modtype_decl data) acc in find_all wrap_identity - (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) f + (fun env -> env.modtypes) (fun sc -> sc.comp_modtypes) + (fun k p mta acc -> f k p mta.mtda_declaration acc) and fold_classes f = find_all wrap_identity (fun env -> env.classes) (fun sc -> sc.comp_classes) (fun k p clda acc -> f k p clda.clda_declaration acc) and fold_cltypes f = find_all wrap_identity - (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) f + (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes) + (fun k p cltda acc -> f k p cltda.cltda_declaration acc) let filter_non_loaded_persistent f env = let to_remove = @@ -3036,7 +3529,8 @@ let filter_non_loaded_persistent f env = | Mod_local _ -> acc | Mod_unbound _ -> acc | Mod_persistent -> - match Persistent_env.find_in_cache !persistent_env name with + let modname = name |> Compilation_unit.Name.of_string in + match Persistent_env.find_in_cache !persistent_env modname with | Some _ -> acc | None -> if f (Ident.create_persistent name) then @@ -3057,38 +3551,24 @@ let filter_non_loaded_persistent f env = summary else match summary with - | Env_empty -> summary - | Env_value (s, id, vd) -> - Env_value (filter_summary s ids, id, vd) - | Env_type (s, id, td) -> - Env_type (filter_summary s ids, id, td) - | Env_extension (s, id, ec) -> - Env_extension (filter_summary s ids, id, ec) - | Env_module (s, id, mp, md) -> - Env_module (filter_summary s ids, id, mp, md) - | Env_modtype (s, id, md) -> - Env_modtype (filter_summary s ids, id, md) - | Env_class (s, id, cd) -> - Env_class (filter_summary s ids, id, cd) - | Env_cltype (s, id, ctd) -> - Env_cltype (filter_summary s ids, id, ctd) - | Env_open (s, p) -> - Env_open (filter_summary s ids, p) - | Env_functor_arg (s, id) -> - Env_functor_arg (filter_summary s ids, id) - | Env_constraints (s, cstrs) -> - Env_constraints (filter_summary s ids, cstrs) - | Env_copy_types s -> - Env_copy_types (filter_summary s ids) - | Env_persistent (s, id) -> - if String.Set.mem (Ident.name id) ids then - filter_summary s (String.Set.remove (Ident.name id) ids) - else - Env_persistent (filter_summary s ids, id) - | Env_value_unbound (s, n, r) -> - Env_value_unbound (filter_summary s ids, n, r) - | Env_module_unbound (s, n, r) -> - Env_module_unbound (filter_summary s ids, n, r) + Env_persistent (s, id) when String.Set.mem (Ident.name id) ids -> + filter_summary s (String.Set.remove (Ident.name id) ids) + | Env_empty + | Env_value _ + | Env_type _ + | Env_extension _ + | Env_module _ + | Env_modtype _ + | Env_class _ + | Env_cltype _ + | Env_open _ + | Env_functor_arg _ + | Env_constraints _ + | Env_copy_types _ + | Env_persistent _ + | Env_value_unbound _ + | Env_module_unbound _ -> + map_summary (fun s -> filter_summary s ids) summary in { env with modules = remove_ids env.modules to_remove; diff --git a/ocaml/typing/env.mli b/ocaml/typing/env.mli index 387daaf2392..2e3df10b7e2 100644 --- a/ocaml/typing/env.mli +++ b/ocaml/typing/env.mli @@ -18,6 +18,10 @@ open Types open Misc +val register_uid : Uid.t -> Location.t -> unit + +val get_uid_to_loc_tbl : unit -> Location.t Types.Uid.Tbl.t + type value_unbound_reason = | Val_unbound_instance_variable | Val_unbound_self @@ -47,7 +51,8 @@ type summary = | Env_module_unbound of summary * string * module_unbound_reason type address = - | Aident of Ident.t + | Aunit of Compilation_unit.t + | Alocal of Ident.t | Adot of address * int type t @@ -56,10 +61,12 @@ val empty: t val initial_safe_string: t val initial_unsafe_string: t val diff: t -> t -> Ident.t list -val copy_local: from:t -> t -> t -type type_descriptions = - constructor_description list * label_description list +type type_descr_kind = + (label_description, constructor_description) type_kind + + (* alias for compatibility *) +type type_descriptions = type_descr_kind (* For short-paths *) type iter_cont @@ -68,7 +75,7 @@ val iter_types: t -> iter_cont val run_iter_cont: iter_cont list -> (Path.t * iter_cont) list val same_types: t -> t -> bool -val used_persistent: unit -> Concr.t +val used_persistent: unit -> Compilation_unit.Name.Set.t val find_shadowed_types: Path.t -> t -> Path.t list val without_cmis: ('a -> 'b) -> 'a -> 'b (* [without_cmis f arg] applies [f] to [arg], but does not @@ -107,6 +114,9 @@ val find_module_address: Path.t -> t -> address val find_class_address: Path.t -> t -> address val find_constructor_address: Path.t -> t -> address +val shape_of_path: + namespace:Shape.Sig_component_kind.t -> t -> Path.t -> Shape.t + val add_functor_arg: Ident.t -> t -> t val is_functor_arg: Path.t -> t -> bool @@ -127,8 +137,8 @@ val normalize_modtype_path: t -> Path.t -> Path.t (* Normalize a module type path *) val reset_required_globals: unit -> unit -val get_required_globals: unit -> Ident.t list -val add_required_global: Ident.t -> unit +val get_required_globals: unit -> Compilation_unit.t list +val add_required_global: Path.t -> t -> unit val reset_probes: unit -> unit val add_probe: string -> unit @@ -141,12 +151,17 @@ val mark_value_used: Uid.t -> unit val mark_module_used: Uid.t -> unit val mark_type_used: Uid.t -> unit -type constructor_usage = Positive | Pattern | Privatize +type constructor_usage = Positive | Pattern | Exported_private | Exported val mark_constructor_used: constructor_usage -> constructor_declaration -> unit val mark_extension_used: constructor_usage -> extension_constructor -> unit +type label_usage = + Projection | Mutation | Construct | Exported_private | Exported +val mark_label_used: + label_usage -> label_declaration -> unit + (* Lookup by long identifiers *) (* Lookup errors *) @@ -234,14 +249,14 @@ val lookup_all_constructors_from_type: (constructor_description * (unit -> unit)) list val lookup_label: - ?use:bool -> loc:Location.t -> Longident.t -> t -> + ?use:bool -> loc:Location.t -> label_usage -> Longident.t -> t -> label_description val lookup_all_labels: - ?use:bool -> loc:Location.t -> Longident.t -> t -> + ?use:bool -> loc:Location.t -> label_usage -> Longident.t -> t -> ((label_description * (unit -> unit)) list, Location.t * t * lookup_error) result val lookup_all_labels_from_type: - ?use:bool -> loc:Location.t -> Path.t -> t -> + ?use:bool -> loc:Location.t -> label_usage -> Path.t -> t -> (label_description * (unit -> unit)) list val lookup_instance_variable: @@ -285,10 +300,12 @@ val add_value: val add_type: check:bool -> Ident.t -> type_declaration -> t -> t val add_extension: check:bool -> rebind:bool -> Ident.t -> extension_constructor -> t -> t -val add_module: - ?arg:bool -> Ident.t -> module_presence -> module_type -> t -> t -val add_module_declaration: ?arg:bool -> check:bool -> Ident.t -> - module_presence -> module_declaration -> t -> t +val add_module: ?arg:bool -> ?shape:Shape.t -> + Ident.t -> module_presence -> module_type -> t -> t +val add_module_lazy: update_summary:bool -> + Ident.t -> module_presence -> Subst.Lazy.modtype -> t -> t +val add_module_declaration: ?arg:bool -> ?shape:Shape.t -> check:bool -> + Ident.t -> module_presence -> module_declaration -> t -> t val add_module_declaration_lazy: update_summary:bool -> Ident.t -> module_presence -> Subst.Lazy.module_decl -> t -> t val add_modtype: Ident.t -> modtype_declaration -> t -> t @@ -319,7 +336,6 @@ val filter_non_loaded_persistent : (Ident.t -> bool) -> t -> t (* Insertion of all fields of a signature. *) -val add_item: signature_item -> t -> t val add_signature: signature -> t -> t (* Insertion of all fields of a signature, relative to the given path. @@ -333,6 +349,8 @@ val open_signature: val open_pers_signature: string -> t -> (t, [`Not_found]) result +val remove_last_open: Path.t -> t -> t option + (* Insertion by name *) val enter_value: @@ -346,7 +364,7 @@ val enter_module: scope:int -> ?arg:bool -> string -> module_presence -> module_type -> t -> Ident.t * t val enter_module_declaration: - scope:int -> ?arg:bool -> string -> module_presence -> + scope:int -> ?arg:bool -> ?shape:Shape.t -> string -> module_presence -> module_declaration -> t -> Ident.t * t val enter_modtype: scope:int -> string -> modtype_declaration -> t -> Ident.t * t @@ -356,7 +374,14 @@ val enter_cltype: (* Same as [add_signature] but refreshes (new stamp) and rescopes bound idents in the process. *) -val enter_signature: scope:int -> signature -> t -> signature * t +val enter_signature: ?mod_shape:Shape.t -> scope:int -> signature -> t -> + signature * t + +(* Same as [enter_signature] but also extends the shape map ([parent_shape]) + with all the the items from the signature, their shape being a projection + from the given shape. *) +val enter_signature_and_shape: scope:int -> parent_shape:Shape.Map.t -> + Shape.t -> signature -> t -> signature * Shape.Map.t * t val enter_unbound_value : string -> value_unbound_reason -> t -> t @@ -374,36 +399,37 @@ val reset_cache: preserve_persistent_env:bool -> unit val reset_cache_toplevel: unit -> unit (* Remember the name of the current compilation unit. *) -val set_unit_name: string -> unit -val get_unit_name: unit -> string +val set_unit_name: Compilation_unit.t option -> unit +val get_unit_name: unit -> Compilation_unit.t option (* Read, save a signature to/from a file *) -val read_signature: modname -> filepath -> signature +val read_signature: Compilation_unit.t -> filepath -> signature (* Arguments: module name, file name. Results: signature. *) val save_signature: - alerts:alerts -> signature -> modname -> filepath + alerts:alerts -> signature -> Compilation_unit.t -> filepath -> Cmi_format.cmi_infos (* Arguments: signature, module name, file name. *) val save_signature_with_imports: - alerts:alerts -> signature -> modname -> filepath -> crcs + alerts:alerts -> signature -> Compilation_unit.t -> filepath + -> Import_info.t array -> Cmi_format.cmi_infos (* Arguments: signature, module name, file name, imported units with their CRCs. *) (* Return the CRC of the interface of the given compilation unit *) -val crc_of_unit: modname -> Digest.t +val crc_of_unit: Compilation_unit.Name.t -> Digest.t (* Return the set of compilation units imported, with their CRC *) -val imports: unit -> crcs +val imports: unit -> Import_info.t list (* may raise Persistent_env.Consistbl.Inconsistency *) -val import_crcs: source:string -> crcs -> unit +val import_crcs: source:string -> Import_info.t array -> unit (* [is_imported_opaque md] returns true if [md] is an opaque imported module *) -val is_imported_opaque: modname -> bool +val is_imported_opaque: Compilation_unit.Name.t -> bool (* [register_import_as_opaque md] registers [md] as an opaque imported module *) -val register_import_as_opaque: modname -> unit +val register_import_as_opaque: Compilation_unit.Name.t -> unit (* Summaries -- compact representation of an environment, to be exported in debugging information. *) @@ -443,8 +469,12 @@ val set_type_used_callback: (* Forward declaration to break mutual recursion with Includemod. *) val check_functor_application: - (errors:bool -> loc:Location.t -> t -> module_type -> - Path.t -> module_type -> Path.t -> unit) ref + (errors:bool -> loc:Location.t -> + lid_whole_app:Longident.t -> + f0_path:Path.t -> args:(Path.t * Types.module_type) list -> + arg_path:Path.t -> arg_mty:Types.module_type -> + param_mty:Types.module_type -> + t -> unit) ref (* Forward declaration to break mutual recursion with Typemod. *) val check_well_formed_module: (t -> Location.t -> string -> module_type -> unit) ref @@ -498,3 +528,9 @@ val scrape_alias: t -> module_type -> module_type val check_value_name: string -> Location.t -> unit val print_address : Format.formatter -> address -> unit + +type address_head = + | AHunit of Compilation_unit.t + | AHlocal of Ident.t + +val address_head : address -> address_head diff --git a/ocaml/typing/errortrace.ml b/ocaml/typing/errortrace.ml new file mode 100644 index 00000000000..ec380329be2 --- /dev/null +++ b/ocaml/typing/errortrace.ml @@ -0,0 +1,194 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* Antal Spector-Zabusky, Jane Street, New York *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2021 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Types +open Format + +type position = First | Second + +let swap_position = function + | First -> Second + | Second -> First + +let print_pos ppf = function + | First -> fprintf ppf "first" + | Second -> fprintf ppf "second" + +type expanded_type = { ty: type_expr; expanded: type_expr } + +let trivial_expansion ty = { ty; expanded = ty } + +type 'a diff = { got: 'a; expected: 'a } + +let map_diff f r = + (* ordering is often meaningful when dealing with type_expr *) + let got = f r.got in + let expected = f r.expected in + { got; expected } + +let swap_diff x = { got = x.expected; expected = x.got } + +type 'a escape_kind = + | Constructor of Path.t + | Univ of type_expr + (* The type_expr argument of [Univ] is always a [Tunivar _], + we keep a [type_expr] to track renaming in {!Printtyp} *) + | Self + | Module_type of Path.t + | Equation of 'a + | Constraint + +type 'a escape = + { kind : 'a escape_kind; + context : type_expr option } + +let map_escape f esc = + {esc with kind = match esc.kind with + | Equation eq -> Equation (f eq) + | (Constructor _ | Univ _ | Self | Module_type _ | Constraint) as c -> c} + +let explain trace f = + let rec explain = function + | [] -> None + | [h] -> f ~prev:None h + | h :: (prev :: _ as rem) -> + match f ~prev:(Some prev) h with + | Some _ as m -> m + | None -> explain rem in + explain (List.rev trace) + +(* Type indices *) +type unification = private Unification +type comparison = private Comparison + +type fixed_row_case = + | Cannot_be_closed + | Cannot_add_tags of string list + +type 'variety variant = + (* Common *) + | Incompatible_types_for : string -> _ variant + | No_tags : position * (Asttypes.label * row_field) list -> _ variant + (* Unification *) + | No_intersection : unification variant + | Fixed_row : + position * fixed_row_case * fixed_explanation -> unification variant + (* Equality & Moregen *) + | Presence_not_guaranteed_for : position * string -> comparison variant + | Openness : position (* Always [Second] for Moregen *) -> comparison variant + +type 'variety obj = + (* Common *) + | Missing_field : position * string -> _ obj + | Abstract_row : position -> _ obj + (* Unification *) + | Self_cannot_be_closed : unification obj + +type ('a, 'variety) elt = + (* Common *) + | Diff : 'a diff -> ('a, _) elt + | Variant : 'variety variant -> ('a, 'variety) elt + | Obj : 'variety obj -> ('a, 'variety) elt + | Escape : 'a escape -> ('a, _) elt + | Incompatible_fields : { name:string; diff: type_expr diff } -> ('a, _) elt + (* Could move [Incompatible_fields] into [obj] *) + (* Unification & Moregen; included in Equality for simplicity *) + | Rec_occur : type_expr * type_expr -> ('a, _) elt + +type ('a, 'variety) t = ('a, 'variety) elt list + +type 'variety trace = (type_expr, 'variety) t +type 'variety error = (expanded_type, 'variety) t + +let map_elt (type variety) f : ('a, variety) elt -> ('b, variety) elt = function + | Diff x -> Diff (map_diff f x) + | Escape {kind = Equation x; context} -> + Escape { kind = Equation (f x); context } + | Escape {kind = (Univ _ | Self | Constructor _ | Module_type _ | Constraint); + _} + | Variant _ | Obj _ | Incompatible_fields _ | Rec_occur (_, _) as x -> x + +let map f t = List.map (map_elt f) t + +let incompatible_fields ~name ~got ~expected = + Incompatible_fields { name; diff={got; expected} } + +let swap_elt (type variety) : ('a, variety) elt -> ('a, variety) elt = function + | Diff x -> Diff (swap_diff x) + | Incompatible_fields { name; diff } -> + Incompatible_fields { name; diff = swap_diff diff} + | Obj (Missing_field(pos,s)) -> Obj (Missing_field(swap_position pos,s)) + | Obj (Abstract_row pos) -> Obj (Abstract_row (swap_position pos)) + | Variant (Fixed_row(pos,k,f)) -> + Variant (Fixed_row(swap_position pos,k,f)) + | Variant (No_tags(pos,f)) -> + Variant (No_tags(swap_position pos,f)) + | x -> x + +let swap_trace e = List.map swap_elt e + +type unification_error = { trace : unification error } [@@unboxed] + +type equality_error = + { trace : comparison error; + subst : (type_expr * type_expr) list } + +type moregen_error = { trace : comparison error } [@@unboxed] + +let unification_error ~trace : unification_error = + assert (trace <> []); + { trace } + +let equality_error ~trace ~subst : equality_error = + assert (trace <> []); + { trace; subst } + +let moregen_error ~trace : moregen_error = + assert (trace <> []); + { trace } + +type comparison_error = + | Equality_error of equality_error + | Moregen_error of moregen_error + +let swap_unification_error ({trace} : unification_error) = + ({trace = swap_trace trace} : unification_error) + +module Subtype = struct + type 'a elt = + | Diff of 'a diff + + type 'a t = 'a elt list + + type trace = type_expr t + type error_trace = expanded_type t + + type unification_error_trace = unification error (** To avoid shadowing *) + + type nonrec error = + { trace : error_trace + ; unification_trace : unification error } + + let error ~trace ~unification_trace = + assert (trace <> []); + { trace; unification_trace } + + let map_elt f = function + | Diff x -> Diff (map_diff f x) + + let map f t = List.map (map_elt f) t +end diff --git a/ocaml/typing/errortrace.mli b/ocaml/typing/errortrace.mli new file mode 100644 index 00000000000..90148893fe3 --- /dev/null +++ b/ocaml/typing/errortrace.mli @@ -0,0 +1,168 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* Antal Spector-Zabusky, Jane Street, New York *) +(* *) +(* Copyright 2018 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* Copyright 2021 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +open Types + +type position = First | Second + +val swap_position : position -> position +val print_pos : Format.formatter -> position -> unit + +type expanded_type = { ty: type_expr; expanded: type_expr } + +(** [trivial_expansion ty] creates an [expanded_type] whose expansion is also + [ty]. Usually, you want [Ctype.expand_type] instead, since the expansion + carries useful information; however, in certain circumstances, the error is + about the expansion of the type, meaning that actually performing the + expansion produces more confusing or inaccurate output. *) +val trivial_expansion : type_expr -> expanded_type + +type 'a diff = { got: 'a; expected: 'a } + +(** [map_diff f {expected;got}] is [{expected=f expected; got=f got}] *) +val map_diff: ('a -> 'b) -> 'a diff -> 'b diff + +(** Scope escape related errors *) +type 'a escape_kind = + | Constructor of Path.t + | Univ of type_expr + (* The type_expr argument of [Univ] is always a [Tunivar _], + we keep a [type_expr] to track renaming in {!Printtyp} *) + | Self + | Module_type of Path.t + | Equation of 'a + | Constraint + +type 'a escape = + { kind : 'a escape_kind; + context : type_expr option } + +val map_escape : ('a -> 'b) -> 'a escape -> 'b escape + +val explain: 'a list -> + (prev:'a option -> 'a -> 'b option) -> + 'b option + +(** Type indices *) +type unification = private Unification +type comparison = private Comparison + +type fixed_row_case = + | Cannot_be_closed + | Cannot_add_tags of string list + +type 'variety variant = + (* Common *) + | Incompatible_types_for : string -> _ variant + | No_tags : position * (Asttypes.label * row_field) list -> _ variant + (* Unification *) + | No_intersection : unification variant + | Fixed_row : + position * fixed_row_case * fixed_explanation -> unification variant + (* Equality & Moregen *) + | Presence_not_guaranteed_for : position * string -> comparison variant + | Openness : position (* Always [Second] for Moregen *) -> comparison variant + +type 'variety obj = + (* Common *) + | Missing_field : position * string -> _ obj + | Abstract_row : position -> _ obj + (* Unification *) + | Self_cannot_be_closed : unification obj + +type ('a, 'variety) elt = + (* Common *) + | Diff : 'a diff -> ('a, _) elt + | Variant : 'variety variant -> ('a, 'variety) elt + | Obj : 'variety obj -> ('a, 'variety) elt + | Escape : 'a escape -> ('a, _) elt + | Incompatible_fields : { name:string; diff: type_expr diff } -> ('a, _) elt + (* Unification & Moregen; included in Equality for simplicity *) + | Rec_occur : type_expr * type_expr -> ('a, _) elt + +type ('a, 'variety) t = ('a, 'variety) elt list + +type 'variety trace = (type_expr, 'variety) t +type 'variety error = (expanded_type, 'variety) t + +val map : ('a -> 'b) -> ('a, 'variety) t -> ('b, 'variety) t + +val incompatible_fields : + name:string -> got:type_expr -> expected:type_expr -> (type_expr, _) elt + +val swap_trace : ('a, 'variety) t -> ('a, 'variety) t + +(** The traces (['variety t]) are the core error types. However, we bundle them + up into three "top-level" error types, which are used elsewhere: + [unification_error], [equality_error], and [moregen_error]. In the case of + [equality_error], this has to bundle in extra information; in general, it + distinguishes the three types of errors and allows us to distinguish traces + that are being built (or processed) from those that are complete and have + become the final error. These error types have the invariants that their + traces are nonempty; we ensure that through three smart constructors with + matching names. *) + +type unification_error = private { trace : unification error } [@@unboxed] + +type equality_error = private + { trace : comparison error; + subst : (type_expr * type_expr) list } + +type moregen_error = private { trace : comparison error } [@@unboxed] + +val unification_error : trace:unification error -> unification_error + +val equality_error : + trace:comparison error -> subst:(type_expr * type_expr) list -> equality_error + +val moregen_error : trace:comparison error -> moregen_error + +(** Wraps up the two different kinds of [comparison] errors in one type *) +type comparison_error = + | Equality_error of equality_error + | Moregen_error of moregen_error + +(** Lift [swap_trace] to [unification_error] *) +val swap_unification_error : unification_error -> unification_error + +module Subtype : sig + type 'a elt = + | Diff of 'a diff + + type 'a t = 'a elt list + + (** Just as outside [Subtype], we split traces, completed traces, and complete + errors. However, in a minor asymmetry, the name [Subtype.error_trace] + corresponds to the outside [error] type, and [Subtype.error] corresponds + to the outside [*_error] types (e.g., [unification_error]). This [error] + type has the invariant that the subtype trace is nonempty; note that no + such invariant is imposed on the unification trace. *) + + type trace = type_expr t + type error_trace = expanded_type t + + type unification_error_trace = unification error (** To avoid shadowing *) + + type nonrec error = private + { trace : error_trace + ; unification_trace : unification error } + + val error : + trace:error_trace -> unification_trace:unification_error_trace -> error + + val map : ('a -> 'b) -> 'a t -> 'b t +end diff --git a/ocaml/typing/includeclass.ml b/ocaml/typing/includeclass.ml index 483088d6fee..3a2cd57694f 100644 --- a/ocaml/typing/includeclass.ml +++ b/ocaml/typing/includeclass.ml @@ -49,15 +49,15 @@ let rec hide_params = function | cty -> cty *) -let include_err ppf = +let include_err mode ppf = function | CM_Virtual_class -> fprintf ppf "A class cannot be changed from virtual to concrete" | CM_Parameter_arity_mismatch _ -> fprintf ppf "The classes do not have the same number of type parameters" - | CM_Type_parameter_mismatch (env, trace) -> - Printtyp.report_unification_error ppf env trace + | CM_Type_parameter_mismatch (env, err) -> + Printtyp.report_equality_error ppf mode env err (function ppf -> fprintf ppf "A type parameter has type") (function ppf -> @@ -69,20 +69,20 @@ let include_err ppf = Printtyp.class_type cty1 "is not matched by the class type" Printtyp.class_type cty2) - | CM_Parameter_mismatch (env, trace) -> - Printtyp.report_unification_error ppf env trace + | CM_Parameter_mismatch (env, err) -> + Printtyp.report_moregen_error ppf mode env err (function ppf -> fprintf ppf "A parameter has type") (function ppf -> fprintf ppf "but is expected to have type") - | CM_Val_type_mismatch (lab, env, trace) -> - Printtyp.report_unification_error ppf env trace + | CM_Val_type_mismatch (lab, env, err) -> + Printtyp.report_comparison_error ppf mode env err (function ppf -> fprintf ppf "The instance variable %s@ has type" lab) (function ppf -> fprintf ppf "but is expected to have type") - | CM_Meth_type_mismatch (lab, env, trace) -> - Printtyp.report_unification_error ppf env trace + | CM_Meth_type_mismatch (lab, env, err) -> + Printtyp.report_comparison_error ppf mode env err (function ppf -> fprintf ppf "The method %s@ has type" lab) (function ppf -> @@ -108,9 +108,9 @@ let include_err ppf = | CM_Private_method lab -> fprintf ppf "@[The private method %s cannot become public@]" lab -let report_error ppf = function +let report_error mode ppf = function | [] -> () | err :: errs -> let print_errs ppf errs = - List.iter (fun err -> fprintf ppf "@ %a" include_err err) errs in - fprintf ppf "@[%a%a@]" include_err err print_errs errs + List.iter (fun err -> fprintf ppf "@ %a" (include_err mode) err) errs in + fprintf ppf "@[%a%a@]" (include_err mode) err print_errs errs diff --git a/ocaml/typing/includeclass.mli b/ocaml/typing/includeclass.mli index ebfa97897f7..84de6212c4a 100644 --- a/ocaml/typing/includeclass.mli +++ b/ocaml/typing/includeclass.mli @@ -29,4 +29,5 @@ val class_declarations: Env.t -> class_declaration -> class_declaration -> class_match_failure list -val report_error: formatter -> class_match_failure list -> unit +val report_error : + Printtyp.type_or_scheme -> formatter -> class_match_failure list -> unit diff --git a/ocaml/typing/includecore.ml b/ocaml/typing/includecore.ml index c30c552fa85..cf96f37816f 100644 --- a/ocaml/typing/includecore.ml +++ b/ocaml/typing/includecore.ml @@ -20,12 +20,10 @@ open Path open Types open Typedtree -type position = Ctype.Unification_trace.position = First | Second +type position = Errortrace.position = First | Second (* Inclusion between value descriptions *) -exception Dont_match - type primitive_mismatch = | Name | Arity @@ -37,6 +35,13 @@ type primitive_mismatch = | Result_repr | Argument_repr of int +type value_mismatch = + | Primitive_mismatch of primitive_mismatch + | Not_a_primitive + | Type of Errortrace.moregen_error + +exception Dont_match of value_mismatch + let native_repr_args nra1 nra2 = let rec loop i nra1 nra2 = match nra1, nra2 with @@ -92,114 +97,56 @@ let value_descriptions ~loc env name let ty1_global, _ = Ctype.instance_prim_mode p1 vd1.val_type in let ty2_global = let ty2, mode2 = Ctype.instance_prim_mode p2 vd2.val_type in - Option.iter Btype.Alloc_mode.make_global_exn mode2; + Option.iter Alloc_mode.make_global_exn mode2; ty2 in - if not (Ctype.moregeneral env true ty1_global ty2_global) then - raise Dont_match; + (try Ctype.moregeneral env true ty1_global ty2_global + with Ctype.Moregen err -> raise (Dont_match (Type err))); let ty1_local, _ = Ctype.instance_prim_mode p1 vd1.val_type in let ty2_local = let ty2, mode2 = Ctype.instance_prim_mode p2 vd2.val_type in - Option.iter Btype.Alloc_mode.make_local_exn mode2; + Option.iter Alloc_mode.make_local_exn mode2; ty2 in - if not (Ctype.moregeneral env true ty1_local ty2_local) then - raise Dont_match; + (try Ctype.moregeneral env true ty1_local ty2_local + with Ctype.Moregen err -> raise (Dont_match (Type err))); match primitive_descriptions p1 p2 with | None -> Tcoerce_none - | Some _ -> raise Dont_match + | Some err -> raise (Dont_match (Primitive_mismatch err)) end | _ -> let ty1, mode1 = Ctype.instance_prim_mode p1 vd1.val_type in - if not (Ctype.moregeneral env true ty1 vd2.val_type) then - raise Dont_match; + (try Ctype.moregeneral env true ty1 vd2.val_type + with Ctype.Moregen err -> raise (Dont_match (Type err))); let pc = {pc_desc = p1; pc_type = vd2.Types.val_type; pc_poly_mode = mode1; pc_env = env; pc_loc = vd1.Types.val_loc; } in Tcoerce_primitive pc end | _ -> - if Ctype.moregeneral env true vd1.val_type vd2.val_type then begin + match Ctype.moregeneral env true vd1.val_type vd2.val_type with + | exception Ctype.Moregen err -> raise (Dont_match (Type err)) + | () -> begin match vd2.val_kind with - | Val_prim _ -> raise Dont_match + | Val_prim _ -> raise (Dont_match Not_a_primitive) | _ -> Tcoerce_none - end else - raise Dont_match - -(* Inclusion between "private" annotations *) - -let private_flags decl1 decl2 = - match decl1.type_private, decl2.type_private with - | Private, Public -> - decl2.type_kind = Type_abstract && - (decl2.type_manifest = None || decl1.type_kind <> Type_abstract) - | _, _ -> true + end (* Inclusion between manifest types (particularly for private row types) *) let is_absrow env ty = - match ty.desc with - Tconstr(Pident _, _, _) -> - begin match Ctype.expand_head env ty with - {desc=Tobject _|Tvariant _} -> true + match get_desc ty with + | Tconstr(Pident _, _, _) -> + (* This function is checking for an abstract row on the side that is being + included into (usually numbered with "2" in this file). In this case, + the abstract row variable has been substituted for an object or variant + type. *) + begin match get_desc (Ctype.expand_head env ty) with + | Tobject _|Tvariant _ -> true | _ -> false end | _ -> false -let type_manifest env ty1 params1 ty2 params2 priv2 = - let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in - match ty1'.desc, ty2'.desc with - Tvariant row1, Tvariant row2 when is_absrow env (Btype.row_more row2) -> - let row1 = Btype.row_repr row1 and row2 = Btype.row_repr row2 in - Ctype.equal env true (ty1::params1) (row2.row_more::params2) && - begin match row1.row_more with - {desc=Tvar _|Tconstr _|Tnil} -> true - | _ -> false - end && - let r1, r2, pairs = - Ctype.merge_row_fields row1.row_fields row2.row_fields in - (not row2.row_closed || - row1.row_closed && Ctype.filter_row_fields false r1 = []) && - List.for_all - (fun (_,f) -> match Btype.row_field_repr f with - Rabsent | Reither _ -> true | Rpresent _ -> false) - r2 && - let to_equal = ref (List.combine params1 params2) in - List.for_all - (fun (_, f1, f2) -> - match Btype.row_field_repr f1, Btype.row_field_repr f2 with - Rpresent(Some t1), - (Rpresent(Some t2) | Reither(false, [t2], _, _)) -> - to_equal := (t1,t2) :: !to_equal; true - | Rpresent None, (Rpresent None | Reither(true, [], _, _)) -> true - | Reither(c1,tl1,_,_), Reither(c2,tl2,_,_) - when List.length tl1 = List.length tl2 && c1 = c2 -> - to_equal := List.combine tl1 tl2 @ !to_equal; true - | Rabsent, (Reither _ | Rabsent) -> true - | _ -> false) - pairs && - let tl1, tl2 = List.split !to_equal in - Ctype.equal env true tl1 tl2 - | Tobject (fi1, _), Tobject (fi2, _) - when is_absrow env (snd(Ctype.flatten_fields fi2)) -> - let (fields2,rest2) = Ctype.flatten_fields fi2 in - Ctype.equal env true (ty1::params1) (rest2::params2) && - let (fields1,rest1) = Ctype.flatten_fields fi1 in - (match rest1 with {desc=Tnil|Tvar _|Tconstr _} -> true | _ -> false) && - let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in - miss2 = [] && - let tl1, tl2 = - List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) in - Ctype.equal env true (params1 @ tl1) (params2 @ tl2) - | _ -> - let rec check_super ty1 = - Ctype.equal env true (ty1 :: params1) (ty2 :: params2) || - priv2 = Private && - try check_super - (Ctype.try_expand_once_opt env (Ctype.expand_head env ty1)) - with Ctype.Cannot_expand -> false - in check_super ty1 - (* Inclusion between type declarations *) let choose ord first second = @@ -212,32 +159,39 @@ let choose_other ord first second = | First -> choose Second first second | Second -> choose First first second +(* Documents which kind of private thing would be revealed *) +type privacy_mismatch = + | Private_type_abbreviation + | Private_variant_type + | Private_record_type + | Private_extensible_variant + | Private_row_type + +type locality_mismatch = + { order : position; + nonlocal : bool + } + type label_mismatch = - | Type + | Type of Errortrace.equality_error | Mutability of position - | Nonlocality of position * bool + | Nonlocality of locality_mismatch + +type record_change = + (Types.label_declaration, Types.label_declaration, label_mismatch) + Diffing_with_keys.change type record_mismatch = - | Label_mismatch of Types.label_declaration - * Types.label_declaration - * label_mismatch - | Label_names of int * Ident.t * Ident.t - | Label_missing of position * Ident.t + | Label_mismatch of record_change list | Unboxed_float_representation of position type constructor_mismatch = - | Type + | Type of Errortrace.equality_error | Arity - | Inline_record of record_mismatch + | Inline_record of record_change list | Kind of position | Explicit_return_type of position - -type variant_mismatch = - | Constructor_mismatch of Types.constructor_declaration - * Types.constructor_declaration - * constructor_mismatch - | Constructor_names of int * Ident.t * Ident.t - | Constructor_missing of position * Ident.t + | Nonlocality of int * locality_mismatch type extension_constructor_mismatch = | Constructor_privacy @@ -246,63 +200,169 @@ type extension_constructor_mismatch = * Types.extension_constructor * constructor_mismatch +type private_variant_mismatch = + | Only_outer_closed (* It's only dangerous in one direction *) + | Missing of position * string + | Presence of string + | Incompatible_types_for of string + | Types of Errortrace.equality_error + +type private_object_mismatch = + | Missing of string + | Types of Errortrace.equality_error + +type variant_change = + (Types.constructor_declaration as 'l, 'l, constructor_mismatch) + Diffing_with_keys.change + type type_mismatch = | Arity - | Privacy + | Privacy of privacy_mismatch | Kind - | Constraint - | Manifest + | Constraint of Errortrace.equality_error + | Manifest of Errortrace.equality_error + | Private_variant of type_expr * type_expr * private_variant_mismatch + | Private_object of type_expr * type_expr * private_object_mismatch | Variance | Record_mismatch of record_mismatch - | Variant_mismatch of variant_mismatch + | Variant_mismatch of variant_change list | Unboxed_representation of position | Immediate of Type_immediacy.Violation.t -let report_label_mismatch first second ppf err = +let report_locality_mismatch first second ppf err = + let {order; nonlocal} = err in + let sort = + if nonlocal then "nonlocal" + else "global" + in + Format.fprintf ppf "%s is %s and %s is not." + (String.capitalize_ascii (choose order first second)) + sort + (choose_other order first second) + +let report_primitive_mismatch first second ppf err = let pr fmt = Format.fprintf ppf fmt in + match (err : primitive_mismatch) with + | Name -> + pr "The names of the primitives are not the same" + | Arity -> + pr "The syntactic arities of these primitives were not the same.@ \ + (They must have the same number of arrows present in the source.)" + | No_alloc ord -> + pr "%s primitive is [@@@@noalloc] but %s is not" + (String.capitalize_ascii (choose ord first second)) + (choose_other ord first second) + | Builtin -> + pr "The two primitives differ in whether they are builtins" + | Effects -> + pr "The two primitives have different effect annotations" + | Coeffects -> + pr "The two primitives have different coeffect annotations" + | Native_name -> + pr "The native names of the primitives are not the same" + | Result_repr -> + pr "The two primitives' results have different representations" + | Argument_repr n -> + pr "The two primitives' %d%s arguments have different representations" + n (Misc.ordinal_suffix n) + +let report_value_mismatch first second env ppf err = + let pr fmt = Format.fprintf ppf fmt in + pr "@ "; + match (err : value_mismatch) with + | Primitive_mismatch pm -> + report_primitive_mismatch first second ppf pm + | Not_a_primitive -> + pr "The implementation is not a primitive." + | Type trace -> + Printtyp.report_moregen_error ppf Type_scheme env trace + (fun ppf -> Format.fprintf ppf "The type") + (fun ppf -> Format.fprintf ppf "is not compatible with the type") + +let report_type_inequality env ppf err = + Printtyp.report_equality_error ppf Type_scheme env err + (fun ppf -> Format.fprintf ppf "The type") + (fun ppf -> Format.fprintf ppf "is not equal to the type") + +let report_privacy_mismatch ppf err = + let singular, item = + match err with + | Private_type_abbreviation -> true, "type abbreviation" + | Private_variant_type -> false, "variant constructor(s)" + | Private_record_type -> true, "record constructor" + | Private_extensible_variant -> true, "extensible variant" + | Private_row_type -> true, "row type" + in Format.fprintf ppf "%s %s would be revealed." + (if singular then "A private" else "Private") + item + +let report_label_mismatch first second env ppf err = match (err : label_mismatch) with - | Type -> pr "The types are not equal." + | Type err -> + report_type_inequality env ppf err | Mutability ord -> - pr "%s is mutable and %s is not." - (String.capitalize_ascii (choose ord first second)) - (choose_other ord first second) - | Nonlocality(ord, nonlocal) -> - let sort = - if nonlocal then "nonlocal" - else "global" - in - pr "%s is %s and %s is not." - (String.capitalize_ascii (choose ord first second)) - sort + Format.fprintf ppf "%s is mutable and %s is not." + (String.capitalize_ascii (choose ord first second)) (choose_other ord first second) + | Nonlocality err_ -> report_locality_mismatch first second ppf err_ + +let pp_record_diff first second prefix decl env ppf (x : record_change) = + match x with + | Delete cd -> + Format.fprintf ppf "%aAn extra field, %s, is provided in %s %s." + prefix x (Ident.name cd.delete.ld_id) first decl + | Insert cd -> + Format.fprintf ppf "%aA field, %s, is missing in %s %s." + prefix x (Ident.name cd.insert.ld_id) first decl + | Change Type {got=lbl1; expected=lbl2; reason} -> + Format.fprintf ppf + "@[%aFields do not match:@;<1 2>\ + %a@ is not the same as:\ + @;<1 2>%a@ %a@]" + prefix x + Printtyp.label lbl1 + Printtyp.label lbl2 + (report_label_mismatch first second env) reason + | Change Name n -> + Format.fprintf ppf "%aFields have different names, %s and %s." + prefix x n.got n.expected + | Swap sw -> + Format.fprintf ppf "%aFields %s and %s have been swapped." + prefix x sw.first sw.last + | Move {name; got; expected } -> + Format.fprintf ppf + "@[<2>%aField %s has been moved@ from@ position %d@ to %d.@]" + prefix x name expected got -let report_record_mismatch first second decl ppf err = +let report_patch pr_diff first second decl env ppf patch = + let nl ppf () = Format.fprintf ppf "@," in + let no_prefix _ppf _ = () in + match patch with + | [ elt ] -> + Format.fprintf ppf "@[%a@]" + (pr_diff first second no_prefix decl env) elt + | _ -> + let pp_diff = pr_diff first second Diffing_with_keys.prefix decl env in + Format.fprintf ppf "@[%a@]" + (Format.pp_print_list ~pp_sep:nl pp_diff) patch + +let report_record_mismatch first second decl env ppf err = let pr fmt = Format.fprintf ppf fmt in match err with - | Label_mismatch (l1, l2, err) -> - pr - "@[Fields do not match:@;<1 2>%a@ is not compatible with:\ - @;<1 2>%a@ %a" - Printtyp.label l1 - Printtyp.label l2 - (report_label_mismatch first second) err - | Label_names (n, name1, name2) -> - pr "@[Fields number %i have different names, %s and %s.@]" - n (Ident.name name1) (Ident.name name2) - | Label_missing (ord, s) -> - pr "@[The field %s is only present in %s %s.@]" - (Ident.name s) (choose ord first second) decl + | Label_mismatch patch -> + report_patch pp_record_diff first second decl env ppf patch | Unboxed_float_representation ord -> pr "@[Their internal representations differ:@ %s %s %s.@]" (choose ord first second) decl "uses unboxed float representation" -let report_constructor_mismatch first second decl ppf err = +let report_constructor_mismatch first second decl env ppf err = let pr fmt = Format.fprintf ppf fmt in match (err : constructor_mismatch) with - | Type -> pr "The types are not equal." + | Type err -> report_type_inequality env ppf err | Arity -> pr "They have different arities." - | Inline_record err -> report_record_mismatch first second decl ppf err + | Inline_record err -> + report_patch pp_record_diff first second decl env ppf err | Kind ord -> pr "%s uses inline records and %s doesn't." (String.capitalize_ascii (choose ord first second)) @@ -311,46 +371,104 @@ let report_constructor_mismatch first second decl ppf err = pr "%s has explicit return type and %s doesn't." (String.capitalize_ascii (choose ord first second)) (choose_other ord first second) + | Nonlocality (i, err) -> + pr "Locality mismatch at argument position %i : %a" + (i + 1) (report_locality_mismatch first second) err + (* argument position is one-based; more intuitive *) -let report_variant_mismatch first second decl ppf err = - let pr fmt = Format.fprintf ppf fmt in - match (err : variant_mismatch) with - | Constructor_mismatch (c1, c2, err) -> - pr - "@[Constructors do not match:@;<1 2>%a@ is not compatible with:\ - @;<1 2>%a@ %a" - Printtyp.constructor c1 - Printtyp.constructor c2 - (report_constructor_mismatch first second decl) err - | Constructor_names (n, name1, name2) -> - pr "Constructors number %i have different names, %s and %s." - n (Ident.name name1) (Ident.name name2) - | Constructor_missing (ord, s) -> - pr "The constructor %s is only present in %s %s." - (Ident.name s) (choose ord first second) decl +let pp_variant_diff first second prefix decl env ppf (x : variant_change) = + match x with + | Delete cd -> + Format.fprintf ppf "%aAn extra constructor, %s, is provided in %s %s." + prefix x (Ident.name cd.delete.cd_id) first decl + | Insert cd -> + Format.fprintf ppf "%aA constructor, %s, is missing in %s %s." + prefix x (Ident.name cd.insert.cd_id) first decl + | Change Type {got; expected; reason} -> + Format.fprintf ppf + "@[%aConstructors do not match:@;<1 2>\ + %a@ is not the same as:\ + @;<1 2>%a@ %a@]" + prefix x + Printtyp.constructor got + Printtyp.constructor expected + (report_constructor_mismatch first second decl env) reason + | Change Name n -> + Format.fprintf ppf + "%aConstructors have different names, %s and %s." + prefix x n.got n.expected + | Swap sw -> + Format.fprintf ppf + "%aConstructors %s and %s have been swapped." + prefix x sw.first sw.last + | Move {name; got; expected} -> + Format.fprintf ppf + "@[<2>%aConstructor %s has been moved@ from@ position %d@ to %d.@]" + prefix x name expected got -let report_extension_constructor_mismatch first second decl ppf err = +let report_extension_constructor_mismatch first second decl env ppf err = let pr fmt = Format.fprintf ppf fmt in match (err : extension_constructor_mismatch) with - | Constructor_privacy -> pr "A private type would be revealed." + | Constructor_privacy -> + pr "Private extension constructor(s) would be revealed." | Constructor_mismatch (id, ext1, ext2, err) -> - pr "@[Constructors do not match:@;<1 2>%a@ is not compatible with:\ + pr "@[Constructors do not match:@;<1 2>%a@ is not the same as:\ @;<1 2>%a@ %a@]" (Printtyp.extension_only_constructor id) ext1 (Printtyp.extension_only_constructor id) ext2 - (report_constructor_mismatch first second decl) err + (report_constructor_mismatch first second decl env) err -let report_type_mismatch0 first second decl ppf err = +let report_private_variant_mismatch first second decl env ppf err = let pr fmt = Format.fprintf ppf fmt in + match (err : private_variant_mismatch) with + | Only_outer_closed -> + (* It's only dangerous in one direction, so we don't have a position *) + pr "%s is private and closed, but %s is not closed" + (String.capitalize_ascii second) first + | Missing (ord, name) -> + pr "The constructor %s is only present in %s %s." + name (choose ord first second) decl + | Presence s -> + pr "The tag `%s is present in the %s %s,@ but might not be in the %s" + s second decl first + | Incompatible_types_for s -> pr "Types for tag `%s are incompatible" s + | Types err -> + report_type_inequality env ppf err + +let report_private_object_mismatch env ppf err = + let pr fmt = Format.fprintf ppf fmt in + match (err : private_object_mismatch) with + | Missing s -> pr "The implementation is missing the method %s" s + | Types err -> report_type_inequality env ppf err + +let report_type_mismatch first second decl env ppf err = + let pr fmt = Format.fprintf ppf fmt in + pr "@ "; match err with - | Arity -> pr "They have different arities." - | Privacy -> pr "A private type would be revealed." - | Kind -> pr "Their kinds differ." - | Constraint -> pr "Their constraints differ." - | Manifest -> () - | Variance -> pr "Their variances do not agree." - | Record_mismatch err -> report_record_mismatch first second decl ppf err - | Variant_mismatch err -> report_variant_mismatch first second decl ppf err + | Arity -> + pr "They have different arities." + | Privacy err -> + report_privacy_mismatch ppf err + | Kind -> + pr "Their kinds differ." + | Constraint err -> + (* This error can come from implicit parameter disagreement or from + explicit `constraint`s. Both affect the parameters, hence this choice + of explanatory text *) + pr "Their parameters differ@,"; + report_type_inequality env ppf err + | Manifest err -> + report_type_inequality env ppf err + | Private_variant (_ty1, _ty2, mismatch) -> + report_private_variant_mismatch first second decl env ppf mismatch + | Private_object (_ty1, _ty2, mismatch) -> + report_private_object_mismatch env ppf mismatch + | Variance -> + pr "Their variances do not agree." + | Record_mismatch err -> + report_record_mismatch first second decl env ppf err + | Variant_mismatch err -> + report_patch pp_variant_diff first second decl env ppf err | Unboxed_representation ord -> pr "Their internal representations differ:@ %s %s %s." (choose ord first second) decl @@ -364,120 +482,467 @@ let report_type_mismatch0 first second decl ppf err = pr "%s is not a type that is always immediate on 64 bit platforms." first -let report_type_mismatch first second decl ppf err = - if err = Manifest then () else - Format.fprintf ppf "@ %a" (report_type_mismatch0 first second decl) err - -let rec compare_constructor_arguments ~loc env params1 params2 arg1 arg2 = - match arg1, arg2 with - | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 -> - if List.length arg1 <> List.length arg2 then - Some (Arity : constructor_mismatch) - else if - (* Ctype.equal must be called on all arguments at once, cf. PR#7378 *) - Ctype.equal env true (params1 @ arg1) (params2 @ arg2) - then None else Some Type - | Types.Cstr_record l1, Types.Cstr_record l2 -> - Option.map - (fun rec_err -> Inline_record rec_err) - (compare_records env ~loc params1 params2 0 l1 l2) - | Types.Cstr_record _, _ -> Some (Kind First : constructor_mismatch) - | _, Types.Cstr_record _ -> Some (Kind Second : constructor_mismatch) - -and compare_constructors ~loc env params1 params2 res1 res2 args1 args2 = - match res1, res2 with - | Some r1, Some r2 -> - if Ctype.equal env true [r1] [r2] then - compare_constructor_arguments ~loc env [r1] [r2] args1 args2 - else Some Type - | Some _, None -> Some (Explicit_return_type First) - | None, Some _ -> Some (Explicit_return_type Second) - | None, None -> - compare_constructor_arguments ~loc env params1 params2 args1 args2 - -and compare_variants ~loc env params1 params2 n - (cstrs1 : Types.constructor_declaration list) - (cstrs2 : Types.constructor_declaration list) = - match cstrs1, cstrs2 with - | [], [] -> None - | [], c::_ -> Some (Constructor_missing (Second, c.Types.cd_id)) - | c::_, [] -> Some (Constructor_missing (First, c.Types.cd_id)) - | cd1::rem1, cd2::rem2 -> - if Ident.name cd1.cd_id <> Ident.name cd2.cd_id then - Some (Constructor_names (n, cd1.cd_id, cd2.cd_id)) - else begin - Builtin_attributes.check_alerts_inclusion - ~def:cd1.cd_loc - ~use:cd2.cd_loc - loc - cd1.cd_attributes cd2.cd_attributes - (Ident.name cd1.cd_id); +let compare_global_flags flag0 flag1 = + match flag0, flag1 with + | Global, (Nonlocal | Unrestricted) -> + Some {order = First; nonlocal = false} + | (Nonlocal | Unrestricted), Global -> + Some {order = Second; nonlocal = false} + | Nonlocal, Unrestricted -> + Some {order = First; nonlocal = true} + | Unrestricted, Nonlocal -> + Some {order = Second; nonlocal = true} + | Global, Global + | Nonlocal, Nonlocal + | Unrestricted, Unrestricted -> + None + +module Record_diffing = struct + + let compare_labels env params1 params2 + (ld1 : Types.label_declaration) + (ld2 : Types.label_declaration) = + if ld1.ld_mutable <> ld2.ld_mutable + then + let ord = if ld1.ld_mutable = Asttypes.Mutable then First else Second in + Some (Mutability ord) + else begin + match compare_global_flags ld1.ld_global ld2.ld_global with + | None -> + let tl1 = params1 @ [ld1.ld_type] in + let tl2 = params2 @ [ld2.ld_type] in + begin + match Ctype.equal env true tl1 tl2 with + | exception Ctype.Equality err -> + Some (Type err : label_mismatch) + | () -> None + end + | Some e -> Some (Nonlocality e : label_mismatch) + end + + let rec equal ~loc env params1 params2 + (labels1 : Types.label_declaration list) + (labels2 : Types.label_declaration list) = + match labels1, labels2 with + | [], [] -> true + | _ :: _ , [] | [], _ :: _ -> false + | ld1 :: rem1, ld2 :: rem2 -> + if Ident.name ld1.ld_id <> Ident.name ld2.ld_id + then false + else begin + Builtin_attributes.check_deprecated_mutable_inclusion + ~def:ld1.ld_loc + ~use:ld2.ld_loc + loc + ld1.ld_attributes ld2.ld_attributes + (Ident.name ld1.ld_id); + match compare_labels env params1 params2 ld1 ld2 with + | Some _ -> false + (* add arguments to the parameters, cf. PR#7378 *) + | None -> + equal ~loc env + (ld1.ld_type::params1) (ld2.ld_type::params2) + rem1 rem2 + end + + module Defs = struct + type left = Types.label_declaration + type right = left + type diff = label_mismatch + type state = type_expr list * type_expr list + end + module Diff = Diffing_with_keys.Define(Defs) + + let update (d:Diff.change) (params1,params2 as st) = + match d with + | Insert _ | Change _ | Delete _ -> st + | Keep (x,y,_) -> + (* We need to add equality between existential type parameters + (in inline records) *) + x.data.ld_type::params1, y.data.ld_type::params2 + + let test _loc env (params1,params2) + ({pos; data=lbl1}: Diff.left) + ({data=lbl2; _ }: Diff.right) + = + let name1, name2 = Ident.name lbl1.ld_id, Ident.name lbl2.ld_id in + if name1 <> name2 then + let types_match = + match compare_labels env params1 params2 lbl1 lbl2 with + | Some _ -> false + | None -> true + in + Error + (Diffing_with_keys.Name {types_match; pos; got=name1; expected=name2}) + else + match compare_labels env params1 params2 lbl1 lbl2 with + | Some reason -> + Error ( + Diffing_with_keys.Type {pos; got=lbl1; expected=lbl2; reason} + ) + | None -> Ok () + + let weight: Diff.change -> _ = function + | Insert _ -> 10 + | Delete _ -> 10 + | Keep _ -> 0 + | Change (_,_,Diffing_with_keys.Name t ) -> + if t.types_match then 10 else 15 + | Change _ -> 10 + + + + let key (x: Defs.left) = Ident.name x.ld_id + let diffing loc env params1 params2 cstrs_1 cstrs_2 = + let module Compute = Diff.Simple(struct + let key_left = key + let key_right = key + let update = update + let test = test loc env + let weight = weight + end) + in + Compute.diff (params1,params2) cstrs_1 cstrs_2 + + let compare ~loc env params1 params2 l r = + if equal ~loc env params1 params2 l r then + None + else + Some (diffing loc env params1 params2 l r) + + + let compare_with_representation ~loc env params1 params2 l r rep1 rep2 = + if not (equal ~loc env params1 params2 l r) then + let patch = diffing loc env params1 params2 l r in + Some (Record_mismatch (Label_mismatch patch)) + else + match rep1, rep2 with + | Record_unboxed _, Record_unboxed _ -> None + | Record_unboxed _, _ -> Some (Unboxed_representation First) + | _, Record_unboxed _ -> Some (Unboxed_representation Second) + + | Record_float, Record_float -> None + | Record_float, _ -> + Some (Record_mismatch (Unboxed_float_representation First)) + | _, Record_float -> + Some (Record_mismatch (Unboxed_float_representation Second)) + + | Record_regular, Record_regular + | Record_inlined _, Record_inlined _ + | Record_extension _, Record_extension _ -> None + | (Record_regular|Record_inlined _|Record_extension _), + (Record_regular|Record_inlined _|Record_extension _) -> + assert false + +end + +(* just like List.find_map, but also gives index if found *) +let rec find_map_idx f ?(off = 0) l = + match l with + | [] -> None + | x :: xs -> begin + match f x with + | None -> find_map_idx f ~off:(off+1) xs + | Some y -> Some (off, y) + end + +module Variant_diffing = struct + + let compare_constructor_arguments ~loc env params1 params2 arg1 arg2 = + match arg1, arg2 with + | Types.Cstr_tuple arg1, Types.Cstr_tuple arg2 -> + if List.length arg1 <> List.length arg2 then + Some (Arity : constructor_mismatch) + else begin + let arg1_tys, arg1_gfs = List.split arg1 + and arg2_tys, arg2_gfs = List.split arg2 + in + (* Ctype.equal must be called on all arguments at once, cf. PR#7378 *) + match Ctype.equal env true (params1 @ arg1_tys) (params2 @ arg2_tys) with + | exception Ctype.Equality err -> Some (Type err) + | () -> List.combine arg1_gfs arg2_gfs + |> find_map_idx (fun (x,y) -> compare_global_flags x y) + |> Option.map (fun (i, err) -> Nonlocality (i, err)) + end + | Types.Cstr_record l1, Types.Cstr_record l2 -> + Option.map + (fun rec_err -> Inline_record rec_err) + (Record_diffing.compare env ~loc params1 params2 l1 l2) + | Types.Cstr_record _, _ -> Some (Kind First : constructor_mismatch) + | _, Types.Cstr_record _ -> Some (Kind Second : constructor_mismatch) + + let compare_constructors ~loc env params1 params2 res1 res2 args1 args2 = + match res1, res2 with + | Some r1, Some r2 -> + begin match Ctype.equal env true [r1] [r2] with + | exception Ctype.Equality err -> Some (Type err) + | () -> compare_constructor_arguments ~loc env [r1] [r2] args1 args2 + end + | Some _, None -> Some (Explicit_return_type First) + | None, Some _ -> Some (Explicit_return_type Second) + | None, None -> + compare_constructor_arguments ~loc env params1 params2 args1 args2 + + let equal ~loc env params1 params2 + (cstrs1 : Types.constructor_declaration list) + (cstrs2 : Types.constructor_declaration list) = + List.length cstrs1 = List.length cstrs2 && + List.for_all2 (fun (cd1:Types.constructor_declaration) + (cd2:Types.constructor_declaration) -> + Ident.name cd1.cd_id = Ident.name cd2.cd_id + && + begin + Builtin_attributes.check_alerts_inclusion + ~def:cd1.cd_loc + ~use:cd2.cd_loc + loc + cd1.cd_attributes cd2.cd_attributes + (Ident.name cd1.cd_id) + ; match compare_constructors ~loc env params1 params2 cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with - | Some r -> - Some ((Constructor_mismatch (cd1, cd2, r)) : variant_mismatch) - | None -> compare_variants ~loc env params1 params2 (n+1) rem1 rem2 - end + | Some _ -> false + | None -> true + end) cstrs1 cstrs2 -and compare_labels env params1 params2 - (ld1 : Types.label_declaration) - (ld2 : Types.label_declaration) = - if ld1.ld_mutable <> ld2.ld_mutable - then - let ord = if ld1.ld_mutable = Asttypes.Mutable then First else Second in - Some (Mutability ord) - else begin - match ld1.ld_global, ld2.ld_global with - | Global, (Nonlocal | Unrestricted) -> - Some (Nonlocality(First, false)) - | (Nonlocal | Unrestricted), Global -> - Some (Nonlocality(Second, false)) - | Nonlocal, Unrestricted -> - Some (Nonlocality(First, true)) - | Unrestricted, Nonlocal -> - Some (Nonlocality(Second, true)) - | Global, Global - | Nonlocal, Nonlocal - | Unrestricted, Unrestricted -> - if Ctype.equal env true (ld1.ld_type::params1) (ld2.ld_type::params2) - then None - else Some (Type : label_mismatch) - end + module Defs = struct + type left = Types.constructor_declaration + type right = left + type diff = constructor_mismatch + type state = type_expr list * type_expr list + end + module D = Diffing_with_keys.Define(Defs) + + let update _ st = st -and compare_records ~loc env params1 params2 n - (labels1 : Types.label_declaration list) - (labels2 : Types.label_declaration list) = - match labels1, labels2 with - | [], [] -> None - | [], l::_ -> Some (Label_missing (Second, l.Types.ld_id)) - | l::_, [] -> Some (Label_missing (First, l.Types.ld_id)) - | ld1::rem1, ld2::rem2 -> - if Ident.name ld1.ld_id <> Ident.name ld2.ld_id - then Some (Label_names (n, ld1.ld_id, ld2.ld_id)) + let weight: D.change -> _ = function + | Insert _ -> 10 + | Delete _ -> 10 + | Keep _ -> 0 + | Change (_,_,Diffing_with_keys.Name t) -> + if t.types_match then 10 else 15 + | Change _ -> 10 + + + let test loc env (params1,params2) + ({pos; data=cd1}: D.left) + ({data=cd2; _}: D.right) = + let name1, name2 = Ident.name cd1.cd_id, Ident.name cd2.cd_id in + if name1 <> name2 then + let types_match = + match compare_constructors ~loc env params1 params2 + cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with + | Some _ -> false + | None -> true + in + Error + (Diffing_with_keys.Name {types_match; pos; got=name1; expected=name2}) + else + match compare_constructors ~loc env params1 params2 + cd1.cd_res cd2.cd_res cd1.cd_args cd2.cd_args with + | Some reason -> + Error (Diffing_with_keys.Type {pos; got=cd1; expected=cd2; reason}) + | None -> Ok () + + let diffing loc env params1 params2 cstrs_1 cstrs_2 = + let key (x:Defs.left) = Ident.name x.cd_id in + let module Compute = D.Simple(struct + let key_left = key + let key_right = key + let test = test loc env + let update = update + let weight = weight + end) + in + Compute.diff (params1,params2) cstrs_1 cstrs_2 + + let compare ~loc env params1 params2 l r = + if equal ~loc env params1 params2 l r then + None + else + Some (diffing loc env params1 params2 l r) + + let compare_with_representation ~loc env params1 params2 + cstrs1 cstrs2 rep1 rep2 + = + let err = compare ~loc env params1 params2 cstrs1 cstrs2 in + match err, rep1, rep2 with + | None, Variant_regular, Variant_regular + | None, Variant_unboxed, Variant_unboxed -> + None + | Some err, _, _ -> + Some (Variant_mismatch err) + | None, Variant_unboxed, Variant_regular -> + Some (Unboxed_representation First) + | None, Variant_regular, Variant_unboxed -> + Some (Unboxed_representation Second) +end + +(* Inclusion between "private" annotations *) +let privacy_mismatch env decl1 decl2 = + match decl1.type_private, decl2.type_private with + | Private, Public -> begin + match decl1.type_kind, decl2.type_kind with + | Type_record _, Type_record _ -> Some Private_record_type + | Type_variant _, Type_variant _ -> Some Private_variant_type + | Type_open, Type_open -> Some Private_extensible_variant + | Type_abstract, Type_abstract + when Option.is_some decl2.type_manifest -> begin + match decl1.type_manifest with + | Some ty1 -> begin + let ty1 = Ctype.expand_head env ty1 in + match get_desc ty1 with + | Tvariant row when Btype.is_constr_row ~allow_ident:true + (row_more row) -> + Some Private_row_type + | Tobject (fi, _) when Btype.is_constr_row ~allow_ident:true + (snd (Ctype.flatten_fields fi)) -> + Some Private_row_type + | _ -> + Some Private_type_abbreviation + end + | None -> + None + end + | _, _ -> + None + end + | _, _ -> + None + +let private_variant env row1 params1 row2 params2 = + let r1, r2, pairs = + Ctype.merge_row_fields (row_fields row1) (row_fields row2) + in + let row1_closed = row_closed row1 in + let row2_closed = row_closed row2 in + let err = + if row2_closed && not row1_closed then Some Only_outer_closed else begin - Builtin_attributes.check_deprecated_mutable_inclusion - ~def:ld1.ld_loc - ~use:ld2.ld_loc - loc - ld1.ld_attributes ld2.ld_attributes - (Ident.name ld1.ld_id); - match compare_labels env params1 params2 ld1 ld2 with - | Some r -> Some (Label_mismatch (ld1, ld2, r)) - (* add arguments to the parameters, cf. PR#7378 *) - | None -> compare_records ~loc env - (ld1.ld_type::params1) (ld2.ld_type::params2) - (n+1) - rem1 rem2 + match row2_closed, Ctype.filter_row_fields false r1 with + | true, (s, _) :: _ -> + Some (Missing (Second, s) : private_variant_mismatch) + | _, _ -> None end + in + if err <> None then err else + let err = + let missing = + List.find_opt + (fun (_,f) -> + match row_field_repr f with + | Rabsent | Reither _ -> false + | Rpresent _ -> true) + r2 + in + match missing with + | None -> None + | Some (s, _) -> Some (Missing (First, s) : private_variant_mismatch) + in + if err <> None then err else + let rec loop tl1 tl2 pairs = + match pairs with + | [] -> begin + match Ctype.equal env true tl1 tl2 with + | exception Ctype.Equality err -> + Some (Types err : private_variant_mismatch) + | () -> None + end + | (s, f1, f2) :: pairs -> begin + match row_field_repr f1, row_field_repr f2 with + | Rpresent to1, Rpresent to2 -> begin + match to1, to2 with + | Some t1, Some t2 -> + loop (t1 :: tl1) (t2 :: tl2) pairs + | None, None -> + loop tl1 tl2 pairs + | Some _, None | None, Some _ -> + Some (Incompatible_types_for s) + end + | Rpresent to1, Reither(const2, ts2, _) -> begin + match to1, const2, ts2 with + | Some t1, false, [t2] -> loop (t1 :: tl1) (t2 :: tl2) pairs + | None, true, [] -> loop tl1 tl2 pairs + | _, _, _ -> Some (Incompatible_types_for s) + end + | Rpresent _, Rabsent -> + Some (Missing (Second, s) : private_variant_mismatch) + | Reither(const1, ts1, _), Reither(const2, ts2, _) -> + if const1 = const2 && List.length ts1 = List.length ts2 then + loop (ts1 @ tl1) (ts2 @ tl2) pairs + else + Some (Incompatible_types_for s) + | Reither _, Rpresent _ -> + Some (Presence s) + | Reither _, Rabsent -> + Some (Missing (Second, s) : private_variant_mismatch) + | Rabsent, (Reither _ | Rabsent) -> + loop tl1 tl2 pairs + | Rabsent, Rpresent _ -> + Some (Missing (First, s) : private_variant_mismatch) + end + in + loop params1 params2 pairs -let compare_records_with_representation ~loc env params1 params2 n - labels1 labels2 rep1 rep2 - = - match compare_records ~loc env params1 params2 n labels1 labels2 with - | None when rep1 <> rep2 -> - let pos = if rep2 = Record_float then Second else First in - Some (Unboxed_float_representation pos) - | err -> err +let private_object env fields1 params1 fields2 params2 = + let pairs, _miss1, miss2 = Ctype.associate_fields fields1 fields2 in + let err = + match miss2 with + | [] -> None + | (f, _, _) :: _ -> Some (Missing f) + in + if err <> None then err else + let tl1, tl2 = + List.split (List.map (fun (_,_,t1,_,t2) -> t1, t2) pairs) + in + begin + match Ctype.equal env true (params1 @ tl1) (params2 @ tl2) with + | exception Ctype.Equality err -> Some (Types err) + | () -> None + end + +let type_manifest env ty1 params1 ty2 params2 priv2 kind2 = + let ty1' = Ctype.expand_head env ty1 and ty2' = Ctype.expand_head env ty2 in + match get_desc ty1', get_desc ty2' with + | Tvariant row1, Tvariant row2 + when is_absrow env (row_more row2) -> begin + assert (Ctype.is_equal env true (ty1::params1) (row_more row2::params2)); + match private_variant env row1 params1 row2 params2 with + | None -> None + | Some err -> Some (Private_variant(ty1, ty2, err)) + end + | Tobject (fi1, _), Tobject (fi2, _) + when is_absrow env (snd (Ctype.flatten_fields fi2)) -> begin + let (fields2,rest2) = Ctype.flatten_fields fi2 in + let (fields1,_) = Ctype.flatten_fields fi1 in + assert (Ctype.is_equal env true (ty1::params1) (rest2::params2)); + match private_object env fields1 params1 fields2 params2 with + | None -> None + | Some err -> Some (Private_object(ty1, ty2, err)) + end + | _ -> begin + let is_private_abbrev_2 = + match priv2, kind2 with + | Private, Type_abstract -> begin + (* Same checks as the [when] guards from above, inverted *) + match get_desc ty2' with + | Tvariant row -> + not (is_absrow env (row_more row)) + | Tobject (fi, _) -> + not (is_absrow env (snd (Ctype.flatten_fields fi))) + | _ -> true + end + | _, _ -> false + in + match + if is_private_abbrev_2 then + Ctype.equal_private env params1 ty1 params2 ty2 + else + Ctype.equal env true (params1 @ [ty1]) (params2 @ [ty2]) + with + | exception Ctype.Equality err -> Some (Manifest err) + | () -> None + end let type_declarations ?(equality = false) ~loc env ~mark name decl1 path decl2 = @@ -488,58 +953,71 @@ let type_declarations ?(equality = false) ~loc env ~mark name decl1.type_attributes decl2.type_attributes name; if decl1.type_arity <> decl2.type_arity then Some Arity else - if not (private_flags decl1 decl2) then Some Privacy else + let err = + match privacy_mismatch env decl1 decl2 with + | Some err -> Some (Privacy err) + | None -> None + in + if err <> None then err else let err = match (decl1.type_manifest, decl2.type_manifest) with (_, None) -> - if Ctype.equal env true decl1.type_params decl2.type_params - then None else Some Constraint + begin + match Ctype.equal env true decl1.type_params decl2.type_params with + | exception Ctype.Equality err -> Some (Constraint err) + | () -> None + end | (Some ty1, Some ty2) -> - if type_manifest env ty1 decl1.type_params ty2 decl2.type_params - decl2.type_private - then None else Some Manifest + type_manifest env ty1 decl1.type_params ty2 decl2.type_params + decl2.type_private decl2.type_kind | (None, Some ty2) -> let ty1 = Btype.newgenty (Tconstr(path, decl2.type_params, ref Mnil)) in - if Ctype.equal env true decl1.type_params decl2.type_params then - if Ctype.equal env false [ty1] [ty2] then None - else Some Manifest - else Some Constraint - in - if err <> None then err else - let err = - match (decl2.type_kind, decl1.type_unboxed.unboxed, - decl2.type_unboxed.unboxed) with - | Type_abstract, _, _ -> None - | _, true, false -> Some (Unboxed_representation First) - | _, false, true -> Some (Unboxed_representation Second) - | _ -> None + match Ctype.equal env true decl1.type_params decl2.type_params with + | exception Ctype.Equality err -> Some (Constraint err) + | () -> + match Ctype.equal env false [ty1] [ty2] with + | exception Ctype.Equality err -> Some (Manifest err) + | () -> None in if err <> None then err else let err = match (decl1.type_kind, decl2.type_kind) with (_, Type_abstract) -> None - | (Type_variant cstrs1, Type_variant cstrs2) -> + | (Type_variant (cstrs1, rep1), Type_variant (cstrs2, rep2)) -> if mark then begin let mark usage cstrs = List.iter (Env.mark_constructor_used usage) cstrs in - let usage = - if decl2.type_private = Public then Env.Positive - else Env.Privatize + let usage : Env.constructor_usage = + if decl2.type_private = Public then Env.Exported + else Env.Exported_private in mark usage cstrs1; - if equality then mark Env.Positive cstrs2 + if equality then mark Env.Exported cstrs2 end; - Option.map - (fun var_err -> Variant_mismatch var_err) - (compare_variants ~loc env decl1.type_params decl2.type_params 1 - cstrs1 cstrs2) + Variant_diffing.compare_with_representation ~loc env + decl1.type_params + decl2.type_params + cstrs1 + cstrs2 + rep1 + rep2 | (Type_record(labels1,rep1), Type_record(labels2,rep2)) -> - Option.map (fun rec_err -> Record_mismatch rec_err) - (compare_records_with_representation ~loc env - decl1.type_params decl2.type_params 1 - labels1 labels2 - rep1 rep2) + if mark then begin + let mark usage lbls = + List.iter (Env.mark_label_used usage) lbls + in + let usage : Env.label_usage = + if decl2.type_private = Public then Env.Exported + else Env.Exported_private + in + mark usage labels1; + if equality then mark Env.Exported labels2 + end; + Record_diffing.compare_with_representation ~loc env + decl1.type_params decl2.type_params + labels1 labels2 + rep1 rep2 | (Type_open, Type_open) -> None | (_, _) -> Some Kind in @@ -563,7 +1041,7 @@ let type_declarations ?(equality = false) ~loc env ~mark name if not need_variance then None else let abstr = abstr || decl2.type_private = Private in let opn = decl2.type_kind = Type_open && decl2.type_manifest = None in - let constrained ty = not (Btype.(is_Tvar (repr ty))) in + let constrained ty = not (Btype.is_Tvar ty) in if List.for_all2 (fun ty (v1,v2) -> let open Variance in @@ -581,9 +1059,9 @@ let type_declarations ?(equality = false) ~loc env ~mark name let extension_constructors ~loc env ~mark id ext1 ext2 = if mark then begin - let usage = - if ext2.ext_private = Public then Env.Positive - else Env.Privatize + let usage : Env.constructor_usage = + if ext2.ext_private = Public then Env.Exported + else Env.Exported_private in Env.mark_extension_used usage ext1 end; @@ -593,17 +1071,21 @@ let extension_constructors ~loc env ~mark id ext1 ext2 = let ty2 = Btype.newgenty (Tconstr(ext2.ext_type_path, ext2.ext_type_params, ref Mnil)) in - if not (Ctype.equal env true (ty1 :: ext1.ext_type_params) - (ty2 :: ext2.ext_type_params)) - then Some (Constructor_mismatch (id, ext1, ext2, Type)) - else + let tl1 = ty1 :: ext1.ext_type_params in + let tl2 = ty2 :: ext2.ext_type_params in + match Ctype.equal env true tl1 tl2 with + | exception Ctype.Equality err -> + Some (Constructor_mismatch (id, ext1, ext2, Type err)) + | () -> let r = - compare_constructors ~loc env ext1.ext_type_params ext2.ext_type_params + Variant_diffing.compare_constructors ~loc env + ext1.ext_type_params ext2.ext_type_params ext1.ext_ret_type ext2.ext_ret_type ext1.ext_args ext2.ext_args in match r with | Some r -> Some (Constructor_mismatch (id, ext1, ext2, r)) - | None -> match ext1.ext_private, ext2.ext_private with - Private, Public -> Some Constructor_privacy + | None -> + match ext1.ext_private, ext2.ext_private with + | Private, Public -> Some Constructor_privacy | _, _ -> None diff --git a/ocaml/typing/includecore.mli b/ocaml/typing/includecore.mli index 01199f6a8e8..5cc2c7ee452 100644 --- a/ocaml/typing/includecore.mli +++ b/ocaml/typing/includecore.mli @@ -18,34 +18,59 @@ open Typedtree open Types -exception Dont_match +type position = Errortrace.position = First | Second -type position = Ctype.Unification_trace.position = First | Second +type primitive_mismatch = + | Name + | Arity + | No_alloc of position + | Builtin + | Effects + | Coeffects + | Native_name + | Result_repr + | Argument_repr of int + +type value_mismatch = + | Primitive_mismatch of primitive_mismatch + | Not_a_primitive + | Type of Errortrace.moregen_error + +exception Dont_match of value_mismatch + +(* Documents which kind of private thing would be revealed *) +type privacy_mismatch = + | Private_type_abbreviation + | Private_variant_type + | Private_record_type + | Private_extensible_variant + | Private_row_type + +type locality_mismatch = + { order : position + ; nonlocal : bool + (* whether expected mode is nonlocal or global *) + } type label_mismatch = - | Type + | Type of Errortrace.equality_error | Mutability of position - | Nonlocality of position * bool + | Nonlocality of locality_mismatch + +type record_change = + (Types.label_declaration as 'ld, 'ld, label_mismatch) Diffing_with_keys.change type record_mismatch = - | Label_mismatch of label_declaration * label_declaration * label_mismatch - | Label_names of int * Ident.t * Ident.t - | Label_missing of position * Ident.t + | Label_mismatch of record_change list | Unboxed_float_representation of position type constructor_mismatch = - | Type + | Type of Errortrace.equality_error | Arity - | Inline_record of record_mismatch + | Inline_record of record_change list | Kind of position | Explicit_return_type of position - -type variant_mismatch = - | Constructor_mismatch of constructor_declaration - * constructor_declaration - * constructor_mismatch - | Constructor_names of int * Ident.t * Ident.t - | Constructor_missing of position * Ident.t + | Nonlocality of int * locality_mismatch type extension_constructor_mismatch = | Constructor_privacy @@ -53,16 +78,32 @@ type extension_constructor_mismatch = * extension_constructor * extension_constructor * constructor_mismatch +type variant_change = + (Types.constructor_declaration as 'cd, 'cd, constructor_mismatch) + Diffing_with_keys.change + +type private_variant_mismatch = + | Only_outer_closed + | Missing of position * string + | Presence of string + | Incompatible_types_for of string + | Types of Errortrace.equality_error + +type private_object_mismatch = + | Missing of string + | Types of Errortrace.equality_error type type_mismatch = | Arity - | Privacy + | Privacy of privacy_mismatch | Kind - | Constraint - | Manifest + | Constraint of Errortrace.equality_error + | Manifest of Errortrace.equality_error + | Private_variant of type_expr * type_expr * private_variant_mismatch + | Private_object of type_expr * type_expr * private_object_mismatch | Variance | Record_mismatch of record_mismatch - | Variant_mismatch of variant_mismatch + | Variant_mismatch of variant_change list | Unboxed_representation of position | Immediate of Type_immediacy.Violation.t @@ -85,7 +126,17 @@ val class_types: Env.t -> class_type -> class_type -> bool *) -val report_type_mismatch: - string -> string -> string -> Format.formatter -> type_mismatch -> unit -val report_extension_constructor_mismatch: string -> string -> string -> +val report_value_mismatch : + string -> string -> + Env.t -> + Format.formatter -> value_mismatch -> unit + +val report_type_mismatch : + string -> string -> string -> + Env.t -> + Format.formatter -> type_mismatch -> unit + +val report_extension_constructor_mismatch : + string -> string -> string -> + Env.t -> Format.formatter -> extension_constructor_mismatch -> unit diff --git a/ocaml/typing/includemod.ml b/ocaml/typing/includemod.ml index ebd7efbd9f8..ca32b328fd8 100644 --- a/ocaml/typing/includemod.ml +++ b/ocaml/typing/includemod.ml @@ -19,36 +19,95 @@ open Misc open Typedtree open Types -type symptom = - Missing_field of Ident.t * Location.t * string (* kind *) - | Value_descriptions of Ident.t * value_description * value_description - | Type_declarations of Ident.t * type_declaration - * type_declaration * Includecore.type_mismatch - | Extension_constructors of Ident.t * extension_constructor - * extension_constructor * Includecore.extension_constructor_mismatch - | Module_types of module_type * module_type - | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration - | Modtype_permutation of Types.module_type * Typedtree.module_coercion - | Interface_mismatch of string * string - | Class_type_declarations of - Ident.t * class_type_declaration * class_type_declaration * - Ctype.class_match_failure list - | Class_declarations of - Ident.t * class_declaration * class_declaration * - Ctype.class_match_failure list - | Unbound_modtype_path of Path.t - | Unbound_module_path of Path.t - | Invalid_module_alias of Path.t - type pos = | Module of Ident.t | Modtype of Ident.t | Arg of functor_parameter | Body of functor_parameter -type error = pos list * Env.t * symptom -exception Error of error list -exception Apply_error of Location.t * Path.t * Path.t * error list + +module Error = struct + + type functor_arg_descr = + | Anonymous + | Named of Path.t + | Unit + + type ('a,'b) diff = {got:'a; expected:'a; symptom:'b} + type 'a core_diff =('a,unit) diff + let diff x y s = {got=x;expected=y; symptom=s} + let sdiff x y = {got=x; expected=y; symptom=()} + + type core_sigitem_symptom = + | Value_descriptions of (value_description, Includecore.value_mismatch) diff + | Type_declarations of (type_declaration, Includecore.type_mismatch) diff + | Extension_constructors of + (extension_constructor, Includecore.extension_constructor_mismatch) diff + | Class_type_declarations of + (class_type_declaration, Ctype.class_match_failure list) diff + | Class_declarations of + (class_declaration, Ctype.class_match_failure list) diff + + type core_module_type_symptom = + | Not_an_alias + | Not_an_identifier + | Incompatible_aliases + | Abstract_module_type + | Unbound_module_path of Path.t + + type module_type_symptom = + | Mt_core of core_module_type_symptom + | Signature of signature_symptom + | Functor of functor_symptom + | Invalid_module_alias of Path.t + | After_alias_expansion of module_type_diff + + + and module_type_diff = (module_type, module_type_symptom) diff + + and functor_symptom = + | Params of functor_params_diff + | Result of module_type_diff + + and ('arg,'path) functor_param_symptom = + | Incompatible_params of 'arg * functor_parameter + | Mismatch of module_type_diff + + and arg_functor_param_symptom = + (functor_parameter, Ident.t) functor_param_symptom + + and functor_params_diff = (functor_parameter list * module_type) core_diff + + and signature_symptom = { + env: Env.t; + missings: signature_item list; + incompatibles: (Ident.t * sigitem_symptom) list; + } + and sigitem_symptom = + | Core of core_sigitem_symptom + | Module_type_declaration of + (modtype_declaration, module_type_declaration_symptom) diff + | Module_type of module_type_diff + + and module_type_declaration_symptom = + | Illegal_permutation of Typedtree.module_coercion + | Not_greater_than of module_type_diff + | Not_less_than of module_type_diff + | Incomparable of + {less_than:module_type_diff; greater_than: module_type_diff} + + + type all = + | In_Compilation_unit of (string, signature_symptom) diff + | In_Signature of signature_symptom + | In_Include_functor_signature of signature_symptom + | In_Module_type of module_type_diff + | In_Module_type_substitution of + Ident.t * (Types.module_type,module_type_declaration_symptom) diff + | In_Type_declaration of Ident.t * core_sigitem_symptom + | In_Expansion of core_module_type_symptom + +end type mark = | Mark_both @@ -72,19 +131,19 @@ let mark_positive = function (* Inclusion between value descriptions *) -let value_descriptions ~loc env ~mark cxt subst id vd1 vd2 = +let value_descriptions ~loc env ~mark subst id vd1 vd2 = Cmt_format.record_value_dependency vd1 vd2; if mark_positive mark then Env.mark_value_used vd1.val_uid; let vd2 = Subst.value_description subst vd2 in try - Includecore.value_descriptions ~loc env (Ident.name id) vd1 vd2 - with Includecore.Dont_match -> - raise(Error[cxt, env, Value_descriptions(id, vd1, vd2)]) + Ok (Includecore.value_descriptions ~loc env (Ident.name id) vd1 vd2) + with Includecore.Dont_match err -> + Error Error.(Core (Value_descriptions (diff vd1 vd2 err))) (* Inclusion between type declarations *) -let type_declarations ~loc env ~mark cxt subst id decl1 decl2 = +let type_declarations ~loc env ~mark subst id decl1 decl2 = let mark = mark_positive mark in if mark then Env.mark_type_used decl1.type_uid; @@ -93,74 +152,78 @@ let type_declarations ~loc env ~mark cxt subst id decl1 decl2 = Includecore.type_declarations ~loc env ~mark (Ident.name id) decl1 (Path.Pident id) decl2 with - | None -> () + | None -> Ok Tcoerce_none | Some err -> - raise(Error[cxt, env, Type_declarations(id, decl1, decl2, err)]) + Error Error.(Core(Type_declarations (diff decl1 decl2 err))) (* Inclusion between extension constructors *) -let extension_constructors ~loc env ~mark cxt subst id ext1 ext2 = +let extension_constructors ~loc env ~mark subst id ext1 ext2 = let mark = mark_positive mark in let ext2 = Subst.extension_constructor subst ext2 in match Includecore.extension_constructors ~loc env ~mark id ext1 ext2 with - | None -> () + | None -> Ok Tcoerce_none | Some err -> - raise(Error[cxt, env, Extension_constructors(id, ext1, ext2, err)]) + Error Error.(Core(Extension_constructors(diff ext1 ext2 err))) (* Inclusion between class declarations *) -let class_type_declarations ~loc env cxt subst id decl1 decl2 = +let class_type_declarations ~loc env subst decl1 decl2 = let decl2 = Subst.cltype_declaration subst decl2 in match Includeclass.class_type_declarations ~loc env decl1 decl2 with - [] -> () + [] -> Ok Tcoerce_none | reason -> - raise(Error[cxt, env, - Class_type_declarations(id, decl1, decl2, reason)]) + Error Error.(Core(Class_type_declarations(diff decl1 decl2 reason))) -let class_declarations env cxt subst id decl1 decl2 = +let class_declarations env subst decl1 decl2 = let decl2 = Subst.class_declaration subst decl2 in match Includeclass.class_declarations env decl1 decl2 with - [] -> () + [] -> Ok Tcoerce_none | reason -> - raise(Error[cxt, env, Class_declarations(id, decl1, decl2, reason)]) + Error Error.(Core(Class_declarations(diff decl1 decl2 reason))) (* Expand a module type identifier when possible *) -exception Dont_match +let expand_modtype_path env path = + match Env.find_modtype_expansion path env with + | exception Not_found -> None + | x -> Some x -let try_expand_modtype_path env path = - try - Env.find_modtype_expansion path env - with Not_found -> raise Dont_match - -let expand_module_alias ~strengthen env cxt path = - try +let expand_module_alias ~strengthen env path = + match if strengthen then Env.find_strengthened_module ~aliasable:true path env else (Env.find_module path env).md_type - with Not_found -> - raise(Error[cxt, env, Unbound_module_path path]) + with + | x -> Ok x + | exception Not_found -> Error (Error.Unbound_module_path path) (* Extract name, kind and ident from a signature item *) -type field_desc = - Field_value of string - | Field_type of string - | Field_exception of string - | Field_typext of string - | Field_module of string - | Field_modtype of string - | Field_class of string - | Field_classtype of string - -let kind_of_field_desc = function - | Field_value _ -> "value" - | Field_type _ -> "type" - | Field_exception _ -> "exception" - | Field_typext _ -> "extension constructor" - | Field_module _ -> "module" - | Field_modtype _ -> "module type" - | Field_class _ -> "class" - | Field_classtype _ -> "class type" +type field_kind = + | Field_value + | Field_type + | Field_exception + | Field_typext + | Field_module + | Field_modtype + | Field_class + | Field_classtype + + + +type field_desc = { name: string; kind: field_kind } + +let kind_of_field_desc fd = match fd.kind with + | Field_value -> "value" + | Field_type -> "type" + | Field_exception -> "exception" + | Field_typext -> "extension constructor" + | Field_module -> "module" + | Field_modtype -> "module type" + | Field_class -> "class" + | Field_classtype -> "class type" + +let field_desc kind id = { kind; name = Ident.name id } (** Map indexed by both field types and names. This avoids name clashes between different sorts of fields @@ -171,20 +234,20 @@ module FieldMap = Map.Make(struct end) let item_ident_name = function - Sig_value(id, d, _) -> (id, d.val_loc, Field_value(Ident.name id)) - | Sig_type(id, d, _, _) -> (id, d.type_loc, Field_type(Ident.name id)) + Sig_value(id, d, _) -> (id, d.val_loc, field_desc Field_value id) + | Sig_type(id, d, _, _) -> (id, d.type_loc, field_desc Field_type id ) | Sig_typext(id, d, _, _) -> - let kind = - if Path.same d.ext_type_path Predef.path_exn - then Field_exception(Ident.name id) - else Field_typext(Ident.name id) - in - (id, d.ext_loc, kind) - | Sig_module(id, _, d, _, _) -> (id, d.md_loc, Field_module(Ident.name id)) - | Sig_modtype(id, d, _) -> (id, d.mtd_loc, Field_modtype(Ident.name id)) - | Sig_class(id, d, _, _) -> (id, d.cty_loc, Field_class(Ident.name id)) + let kind = + if Path.same d.ext_type_path Predef.path_exn + then Field_exception + else Field_typext + in + (id, d.ext_loc, field_desc kind id) + | Sig_module(id, _, d, _, _) -> (id, d.md_loc, field_desc Field_module id) + | Sig_modtype(id, d, _) -> (id, d.mtd_loc, field_desc Field_modtype id) + | Sig_class(id, d, _, _) -> (id, d.cty_loc, field_desc Field_class id) | Sig_class_type(id, d, _, _) -> - (id, d.clty_loc, Field_classtype(Ident.name id)) + (id, d.clty_loc, field_desc Field_classtype id) let is_runtime_component = function | Sig_value(_,{val_kind = Val_prim _}, _) @@ -255,188 +318,339 @@ let simplify_structure_coercion cc id_pos_list = then Tcoerce_none else Tcoerce_structure (cc, id_pos_list) -(* Build a table of the components of a signature, along with their positions. + +(* Build a table of the components of sig1, along with their positions. The table is indexed by kind and name of component *) let build_component_table pos_rep sg = - let rec build_table pos tbl = function - [] -> pos, tbl - | (Sig_value (_, _, Hidden) - |Sig_type (_, _, _, Hidden) - |Sig_typext (_, _, _, Hidden) - |Sig_module (_, _, _, _, Hidden) - |Sig_modtype (_, _, Hidden) - |Sig_class (_, _, _, Hidden) - |Sig_class_type (_, _, _, Hidden) - ) as item :: rem -> - let pos = if is_runtime_component item then pos + 1 else pos in - build_table pos tbl rem (* do not pair private items. *) - | item :: rem -> - let (id, _loc, name) = item_ident_name item in - let pos, nextpos = - if is_runtime_component item then pos, pos + 1 - else -1, pos - in - build_table nextpos - (FieldMap.add name (id, item, pos_rep pos id) tbl) rem + let rec build_table nb_exported pos tbl = function + [] -> nb_exported, pos, tbl + | item :: rem -> + let pos, nextpos = + if is_runtime_component item then pos, pos + 1 + else -1, pos + in + match item_visibility item with + | Hidden -> + (* do not pair private items. *) + build_table nb_exported nextpos tbl rem + | Exported -> + let (id, _loc, name) = item_ident_name item in + build_table (nb_exported + 1) nextpos + (FieldMap.add name (id, item, pos_rep pos id) tbl) rem in - build_table 0 FieldMap.empty sg + build_table 0 0 FieldMap.empty sg -(* Pair each component of sig2 with a component of sig1, identifying the names - along the way. - Return a list containing each pair and the position of the component in sig1. - Raises if any component of sig2 cannot be paired. *) -let pair_components env cxt subst sig1_comps sig2 = +(* Pair each component of sig2 with a component of sig1, + identifying the names along the way. + Return a coercion list indicating, for all run-time components + of sig2, the position of the matching run-time components of sig1 + and the coercion to be applied to it. *) +let pair_components subst sig1_comps sig2 = let rec pair subst paired unpaired = function - [] -> begin - match unpaired with - | [] -> paired, subst - | _ -> raise(Error unpaired) - end - | item2 :: rem -> - let (id2, loc, name2) = item_ident_name item2 in - let name2, report = - match item2, name2 with - Sig_type (_, {type_manifest=None}, _, _), Field_type s - when Btype.is_row_name s -> - (* Do not report in case of failure, - as the main type will generate an error *) - Field_type (String.sub s 0 (String.length s - 4)), false - | _ -> name2, true + | [] -> + paired, unpaired, subst + | item2 :: rem -> + let (id2, _loc, name2) = item_ident_name item2 in + let name2, report = + match item2, name2 with + Sig_type (_, {type_manifest=None}, _, _), {name=s; kind=Field_type} + when Btype.is_row_name s -> + (* Do not report in case of failure, + as the main type will generate an error *) + { kind=Field_type; name=String.sub s 0 (String.length s - 4) }, + false + | _ -> name2, true + in + begin match FieldMap.find name2 sig1_comps with + | (id1, item1, pos1) -> + let new_subst = + match item2 with + Sig_type _ -> + Subst.add_type id2 (Path.Pident id1) subst + | Sig_module _ -> + Subst.add_module id2 (Path.Pident id1) subst + | Sig_modtype _ -> + Subst.add_modtype id2 (Mty_ident (Path.Pident id1)) subst + | Sig_value _ | Sig_typext _ + | Sig_class _ | Sig_class_type _ -> + subst in - begin try - let (id1, item1, pos1) = FieldMap.find name2 sig1_comps in - let new_subst = - match item2 with - Sig_type _ -> - Subst.add_type id2 (Path.Pident id1) subst - | Sig_module _ -> - Subst.add_module id2 (Path.Pident id1) subst - | Sig_modtype _ -> - Subst.add_modtype id2 (Mty_ident (Path.Pident id1)) subst - | Sig_value _ | Sig_typext _ - | Sig_class _ | Sig_class_type _ -> - subst - in - pair new_subst ((item1, item2, pos1) :: paired) unpaired rem - with Not_found -> - let unpaired = - if report then - (cxt, env, Missing_field (id2, loc, kind_of_field_desc name2)) :: - unpaired - else unpaired in - pair subst paired unpaired rem - end + pair new_subst + ((item1, item2, pos1) :: paired) unpaired rem + | exception Not_found -> + let unpaired = + if report then + item2 :: unpaired + else unpaired in + pair subst paired unpaired rem + end in pair subst [] [] sig2 + +let retrieve_functor_params env mty = + let rec retrieve_functor_params before env = + function + | Mty_ident p as res -> + begin match expand_modtype_path env p with + | Some mty -> retrieve_functor_params before env mty + | None -> List.rev before, res + end + | Mty_alias p as res -> + begin match expand_module_alias ~strengthen:false env p with + | Ok mty -> retrieve_functor_params before env mty + | Error _ -> List.rev before, res + end + | Mty_functor (p, res) -> retrieve_functor_params (p :: before) env res + | Mty_signature _ as res -> List.rev before, res + in + retrieve_functor_params [] env mty + (* Inclusion between module types. Return the restriction that transforms a value of the smaller type into a value of the bigger type. *) -let rec modtypes ~loc env ~mark cxt subst mty1 mty2 = - try - try_modtypes ~loc env ~mark cxt subst mty1 mty2 - with - Dont_match -> - raise(Error[cxt, env, - Module_types(mty1, Subst.modtype Make_local subst mty2)]) - | Error reasons as err -> - match mty1, mty2 with - Mty_alias _, _ - | _, Mty_alias _ -> raise err - | _ -> - raise(Error((cxt, env, - Module_types(mty1, Subst.modtype Make_local subst mty2)) - :: reasons)) - -and try_modtypes ~loc env ~mark cxt subst mty1 mty2 = +(* When computing a signature difference, we need to distinguish between + recoverable errors at the value level and unrecoverable errors at the type + level that require us to stop the computation of the difference due to + incoherent types. +*) +type 'a recoverable_error = { error: 'a; recoverable:bool } +let mark_error_as_recoverable r = + Result.map_error (fun error -> { error; recoverable=true}) r +let mark_error_as_unrecoverable r = + Result.map_error (fun error -> { error; recoverable=false}) r + + +module Sign_diff = struct + type 'a t = { + runtime_coercions: ('a * Typedtree.module_coercion) list; + shape_map: Shape.Map.t; + deep_modifications:bool; + errors: (Ident.t * Error.sigitem_symptom) list; + leftovers: ((Types.signature_item as 'it) * 'it * 'a) list + } + + let empty = { + runtime_coercions = []; + shape_map = Shape.Map.empty; + deep_modifications = false; + errors = []; + leftovers = [] + } + + let merge x y = + { + runtime_coercions = x.runtime_coercions @ y.runtime_coercions; + shape_map = y.shape_map; + (* the shape map is threaded the map during the difference computation, + the last shape map contains all previous elements. *) + deep_modifications = x.deep_modifications || y.deep_modifications; + errors = x.errors @ y.errors; + leftovers = x.leftovers @ y.leftovers + } +end + +(** + In the group of mutual functions below, the [~in_eq] argument is [true] when + we are in fact checking equality of module types. + + The module subtyping relation [A <: B] checks that [A.T = B.T] when [A] + and [B] define a module type [T]. The relation [A.T = B.T] is equivalent + to [(A.T <: B.T) and (B.T <: A.T)], but checking both recursively would lead + to an exponential slowdown (see #10598 and #10616). + To avoid this issue, when [~in_eq] is [true], we compute a coarser relation + [A << B] which is the same as [A <: B] except that module types [T] are + checked only for [A.T << B.T] and not the reverse. + Thus, we can implement a cheap module type equality check [A.T = B.T] by + computing [(A.T << B.T) and (B.T << A.T)], avoiding the exponential slowdown + described above. +*) + +let rec modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape = + match try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape with + | Ok _ as ok -> ok + | Error reason -> + let mty2 = Subst.modtype Make_local subst mty2 in + Error Error.(diff mty1 mty2 reason) + +and try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape = match mty1, mty2 with | (Mty_alias p1, Mty_alias p2) -> if Env.is_functor_arg p2 env then - raise (Error[cxt, env, Invalid_module_alias p2]); - if not (equal_module_paths env p1 subst p2) then - raise Dont_match; - Tcoerce_none - | (Mty_alias p1, _) -> - let p1 = try + Error (Error.Invalid_module_alias p2) + else if not (equal_module_paths env p1 subst p2) then + Error Error.(Mt_core Incompatible_aliases) + else Ok (Tcoerce_none, orig_shape) + | (Mty_alias p1, _) -> begin + match Env.normalize_module_path (Some Location.none) env p1 - with Env.Error (Env.Missing_module (_, _, path)) -> - raise (Error[cxt, env, Unbound_module_path path]) - in - let mty1 = expand_module_alias ~strengthen:false env cxt p1 in - strengthened_modtypes ~loc ~aliasable:true env ~mark cxt - subst mty1 p1 mty2 + with + | exception Env.Error (Env.Missing_module (_, _, path)) -> + Error Error.(Mt_core(Unbound_module_path path)) + | p1 -> + begin match expand_module_alias ~strengthen:false env p1 with + | Error e -> Error (Error.Mt_core e) + | Ok mty1 -> + match strengthened_modtypes ~in_eq ~loc ~aliasable:true env ~mark + subst mty1 p1 mty2 orig_shape + with + | Ok _ as x -> x + | Error reason -> Error (Error.After_alias_expansion reason) + end + end | (Mty_ident p1, Mty_ident p2) -> let p1 = Env.normalize_modtype_path env p1 in let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in - if Path.same p1 p2 then Tcoerce_none + if Path.same p1 p2 then Ok (Tcoerce_none, orig_shape) else - try_modtypes ~loc env ~mark cxt subst - (try_expand_modtype_path env p1) - (try_expand_modtype_path env p2) + begin match expand_modtype_path env p1, expand_modtype_path env p2 with + | Some mty1, Some mty2 -> + try_modtypes ~in_eq ~loc env ~mark subst mty1 mty2 orig_shape + | None, _ | _, None -> Error (Error.Mt_core Abstract_module_type) + end | (Mty_ident p1, _) -> let p1 = Env.normalize_modtype_path env p1 in - try_modtypes ~loc env ~mark cxt subst - (try_expand_modtype_path env p1) mty2 + begin match expand_modtype_path env p1 with + | Some p1 -> + try_modtypes ~in_eq ~loc env ~mark subst p1 mty2 orig_shape + | None -> Error (Error.Mt_core Abstract_module_type) + end | (_, Mty_ident p2) -> let p2 = Env.normalize_modtype_path env (Subst.modtype_path subst p2) in - try_modtypes ~loc env ~mark cxt subst mty1 - (try_expand_modtype_path env p2) + begin match expand_modtype_path env p2 with + | Some p2 -> try_modtypes ~in_eq ~loc env ~mark subst mty1 p2 orig_shape + | None -> + begin match mty1 with + | Mty_functor _ -> + let params1 = retrieve_functor_params env mty1 in + let d = Error.sdiff params1 ([],mty2) in + Error Error.(Functor (Params d)) + | _ -> Error Error.(Mt_core Not_an_identifier) + end + end | (Mty_signature sig1, Mty_signature sig2) -> - signatures ~loc env ~mark cxt subst sig1 sig2 - | (Mty_functor(Unit, res1), Mty_functor(Unit, res2)) -> - begin - match modtypes ~loc env ~mark (Body Unit::cxt) subst res1 res2 with - | Tcoerce_none -> Tcoerce_none - | cc -> Tcoerce_functor (Tcoerce_none, cc) - end - | (Mty_functor(Named (param1, arg1) as arg, res1), - Mty_functor(Named (param2, arg2), res2)) -> + begin match + signatures ~in_eq ~loc env ~mark subst sig1 sig2 orig_shape + with + | Ok _ as ok -> ok + | Error e -> Error (Error.Signature e) + end + | Mty_functor (param1, res1), Mty_functor (param2, res2) -> + let cc_arg, env, subst = + functor_param ~in_eq ~loc env ~mark:(negate_mark mark) + subst param1 param2 + in + let var, res_shape = + match Shape.decompose_abs orig_shape with + | Some (var, res_shape) -> var, res_shape + | None -> + (* Using a fresh variable with a placeholder uid here is fine: users + will never try to jump to the definition of that variable. + If they try to jump to the parameter from inside the functor, + they will use the variable shape that is stored in the local + environment. *) + let var, shape_var = + Shape.fresh_var Uid.internal_not_actually_unique + in + var, Shape.app orig_shape ~arg:shape_var + in + let cc_res = modtypes ~in_eq ~loc env ~mark subst res1 res2 res_shape in + begin match cc_arg, cc_res with + | Ok Tcoerce_none, Ok (Tcoerce_none, final_res_shape) -> + let final_shape = + if final_res_shape == res_shape + then orig_shape + else Shape.abs var final_res_shape + in + Ok (Tcoerce_none, final_shape) + | Ok cc_arg, Ok (cc_res, final_res_shape) -> + let final_shape = + if final_res_shape == res_shape + then orig_shape + else Shape.abs var final_res_shape + in + Ok (Tcoerce_functor(cc_arg, cc_res), final_shape) + | _, Error {Error.symptom = Error.Functor Error.Params res; _} -> + let got_params, got_res = res.got in + let expected_params, expected_res = res.expected in + let d = Error.sdiff + (param1::got_params, got_res) + (param2::expected_params, expected_res) in + Error Error.(Functor (Params d)) + | Error _, _ -> + let params1, res1 = retrieve_functor_params env res1 in + let params2, res2 = retrieve_functor_params env res2 in + let d = Error.sdiff (param1::params1, res1) (param2::params2, res2) in + Error Error.(Functor (Params d)) + | Ok _, Error res -> + Error Error.(Functor (Result res)) + end + | Mty_functor _, _ + | _, Mty_functor _ -> + let params1 = retrieve_functor_params env mty1 in + let params2 = retrieve_functor_params env mty2 in + let d = Error.sdiff params1 params2 in + Error Error.(Functor (Params d)) + | _, Mty_alias _ -> + Error (Error.Mt_core Error.Not_an_alias) + +(* Functor parameters *) + +and functor_param ~in_eq ~loc env ~mark subst param1 param2 = + match param1, param2 with + | Unit, Unit -> + Ok Tcoerce_none, env, subst + | Named (name1, arg1), Named (name2, arg2) -> let arg2' = Subst.modtype Keep subst arg2 in let cc_arg = - modtypes ~loc env ~mark:(negate_mark mark) - (Arg arg::cxt) Subst.identity arg2' arg1 + match + modtypes ~in_eq ~loc env ~mark Subst.identity arg2' arg1 + Shape.dummy_mod + with + | Ok (cc, _) -> Ok cc + | Error err -> Error (Error.Mismatch err) in let env, subst = - match param1, param2 with - | Some p1, Some p2 -> - Env.add_module p1 Mp_present arg2' env, - Subst.add_module p2 (Path.Pident p1) subst - | None, Some p2 -> - Env.add_module p2 Mp_present arg2' env, subst - | Some p1, None -> - Env.add_module p1 Mp_present arg2' env, subst + match name1, name2 with + | Some id1, Some id2 -> + Env.add_module id1 Mp_present arg2' env, + Subst.add_module id2 (Path.Pident id1) subst + | None, Some id2 -> + let id1 = Ident.rename id2 in + Env.add_module id1 Mp_present arg2' env, + Subst.add_module id2 (Path.Pident id1) subst + | Some id1, None -> + Env.add_module id1 Mp_present arg2' env, subst | None, None -> env, subst in - let cc_res = modtypes ~loc env ~mark (Body arg::cxt) subst res1 res2 in - begin match (cc_arg, cc_res) with - (Tcoerce_none, Tcoerce_none) -> Tcoerce_none - | _ -> Tcoerce_functor(cc_arg, cc_res) - end - | (_, _) -> - raise Dont_match + cc_arg, env, subst + | _, _ -> + Error (Error.Incompatible_params (param1, param2)), env, subst -and strengthened_modtypes ~loc ~aliasable env ~mark cxt subst mty1 path1 mty2 = +and strengthened_modtypes ~in_eq ~loc ~aliasable env ~mark + subst mty1 path1 mty2 shape = match mty1, mty2 with | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 -> - Tcoerce_none + Ok (Tcoerce_none, shape) | _, _ -> let mty1 = Mtype.strengthen ~aliasable env mty1 path1 in - modtypes ~loc env ~mark cxt subst mty1 mty2 + modtypes ~in_eq ~loc env ~mark subst mty1 mty2 shape -and strengthened_module_decl ~loc ~aliasable env ~mark cxt subst md1 path1 md2 = +and strengthened_module_decl ~loc ~aliasable env ~mark + subst md1 path1 md2 shape = match md1.md_type, md2.md_type with | Mty_ident p1, Mty_ident p2 when equal_modtype_paths env p1 subst p2 -> - Tcoerce_none + Ok (Tcoerce_none, shape) | _, _ -> let md1 = Mtype.strengthen_decl ~aliasable env md1 path1 in - modtypes ~loc env ~mark cxt subst md1.md_type md2.md_type + modtypes ~in_eq:false ~loc env ~mark subst md1.md_type md2.md_type shape (* Inclusion between signatures *) -and signatures ~loc env ~mark cxt subst sig1 sig2 = +and signatures ~in_eq ~loc env ~mark subst sig1 sig2 mod_shape = (* Environment used to check inclusion of components *) let new_env = Env.add_signature sig1 (Env.in_signature true env) in @@ -448,71 +662,166 @@ and signatures ~loc env ~mark cxt subst sig1 sig2 = ((id,pos,Tcoerce_none)::l , pos+1) | item -> (l, if is_runtime_component item then pos+1 else pos)) ([], 0) sig1 in - let len1, comps1 = build_component_table (fun pos _name -> pos) sig1 in - let len2 = - List.fold_left - (fun n i -> if is_runtime_component i then n + 1 else n) - 0 - sig2 + let exported_len1, runtime_len1, comps1 = + build_component_table (fun pos _name -> pos) sig1 + in + let exported_len2, runtime_len2 = + List.fold_left (fun (el, rl) i -> + let el = match item_visibility i with Hidden -> el | Exported -> el + 1 in + let rl = if is_runtime_component i then rl + 1 else rl in + el, rl + ) (0, 0) sig2 in (* Do the pairing and checking, and return the final coercion *) - let paired, subst = pair_components new_env cxt subst comps1 sig2 in - let cc = signature_components ~loc ~mark new_env cxt subst (List.rev paired) in - if len1 = len2 then (* see PR#5098 *) - simplify_structure_coercion cc id_pos_list - else - Tcoerce_structure (cc, id_pos_list) + let paired, unpaired, subst = pair_components subst comps1 sig2 in + let d = + signature_components ~in_eq ~loc ~mark new_env subst mod_shape + Shape.Map.empty + (List.rev paired) + in + let open Sign_diff in + match unpaired, d.errors, d.runtime_coercions, d.leftovers with + | [], [], cc, [] -> + let shape = + if not d.deep_modifications && exported_len1 = exported_len2 + then mod_shape + else Shape.str ?uid:mod_shape.Shape.uid d.shape_map + in + if runtime_len1 = runtime_len2 then (* see PR#5098 *) + Ok (simplify_structure_coercion cc id_pos_list, shape) + else + Ok (Tcoerce_structure (cc, id_pos_list), shape) + | missings, incompatibles, _, _leftovers -> + Error { + Error.env=new_env; + missings; + incompatibles; + } (* Inclusion between signature components *) and signature_components : - 'a. loc:_ -> mark:_ -> _ -> _ -> _ -> (_ * _ * 'a) list -> ('a * _) list = - fun ~loc ~mark env cxt subst paired -> - let comps_rec rem = - signature_components ~loc ~mark env cxt subst rem - in + 'a. in_eq:_ -> loc:_ -> mark:_ -> _ -> _ -> _ -> _ -> (_ * _ * 'a) list -> 'a Sign_diff.t = + fun ~in_eq ~loc ~mark env subst orig_shape shape_map paired -> match paired with - [] -> [] - | (Sig_value(id1, valdecl1, _), Sig_value(_id2, valdecl2, _), pos) :: rem -> - let cc = - value_descriptions ~loc env ~mark cxt subst id1 valdecl1 valdecl2 + | [] -> Sign_diff.{ empty with shape_map } + | (sigi1, sigi2, pos) :: rem -> + let shape_modified = ref false in + let id, item, shape_map, present_at_runtime = + match sigi1, sigi2 with + | Sig_value(id1, valdecl1, _) ,Sig_value(_id2, valdecl2, _) -> + let item = + value_descriptions ~loc env ~mark subst id1 valdecl1 valdecl2 + in + let item = mark_error_as_recoverable item in + let present_at_runtime = match valdecl2.val_kind with + | Val_prim _ -> false + | _ -> true + in + let shape_map = Shape.Map.add_value_proj shape_map id1 orig_shape in + id1, item, shape_map, present_at_runtime + | Sig_type(id1, tydec1, _, _), Sig_type(_id2, tydec2, _, _) -> + let item = + type_declarations ~loc env ~mark subst id1 tydec1 tydec2 + in + let item = mark_error_as_unrecoverable item in + let shape_map = Shape.Map.add_type_proj shape_map id1 orig_shape in + id1, item, shape_map, false + | Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _) -> + let item = + extension_constructors ~loc env ~mark subst id1 ext1 ext2 + in + let item = mark_error_as_unrecoverable item in + let shape_map = + Shape.Map.add_extcons_proj shape_map id1 orig_shape + in + id1, item, shape_map, true + | Sig_module(id1, pres1, mty1, _, _), Sig_module(_, pres2, mty2, _, _) + -> begin + let orig_shape = + Shape.(proj orig_shape (Item.module_ id1)) + in + let item = + module_declarations ~in_eq ~loc env ~mark subst id1 mty1 mty2 + orig_shape + in + let item, shape_map = + match item with + | Ok (cc, shape) -> + if shape != orig_shape then shape_modified := true; + let mod_shape = Shape.set_uid_if_none shape mty1.md_uid in + Ok cc, Shape.Map.add_module shape_map id1 mod_shape + | Error diff -> + Error (Error.Module_type diff), + (* We add the original shape to the map, even though + there is a type error. + It could still be useful for merlin. *) + Shape.Map.add_module shape_map id1 orig_shape + in + let present_at_runtime, item = + match pres1, pres2, mty1.md_type with + | Mp_present, Mp_present, _ -> true, item + | _, Mp_absent, _ -> false, item + | Mp_absent, Mp_present, Mty_alias p1 -> + true, Result.map (fun i -> Tcoerce_alias (env, p1, i)) item + | Mp_absent, Mp_present, _ -> assert false + in + let item = mark_error_as_unrecoverable item in + id1, item, shape_map, present_at_runtime + end + | Sig_modtype(id1, info1, _), Sig_modtype(_id2, info2, _) -> + let item = + modtype_infos ~in_eq ~loc env ~mark subst id1 info1 info2 + in + let shape_map = + Shape.Map.add_module_type_proj shape_map id1 orig_shape + in + let item = mark_error_as_unrecoverable item in + id1, item, shape_map, false + | Sig_class(id1, decl1, _, _), Sig_class(_id2, decl2, _, _) -> + let item = + class_declarations env subst decl1 decl2 + in + let shape_map = + Shape.Map.add_class_proj shape_map id1 orig_shape + in + let item = mark_error_as_unrecoverable item in + id1, item, shape_map, true + | Sig_class_type(id1, info1, _, _), Sig_class_type(_id2, info2, _, _) -> + let item = + class_type_declarations ~loc env subst info1 info2 + in + let item = mark_error_as_unrecoverable item in + let shape_map = + Shape.Map.add_class_type_proj shape_map id1 orig_shape + in + id1, item, shape_map, false + | _ -> + assert false in - begin match valdecl2.val_kind with - Val_prim _ -> comps_rec rem - | _ -> (pos, cc) :: comps_rec rem - end - | (Sig_type(id1, tydecl1, _, _), Sig_type(_id2, tydecl2, _, _), _pos) :: rem - -> - type_declarations ~loc env ~mark cxt subst id1 tydecl1 tydecl2; - comps_rec rem - | (Sig_typext(id1, ext1, _, _), Sig_typext(_id2, ext2, _, _), pos) - :: rem -> - extension_constructors ~loc env ~mark cxt subst id1 ext1 ext2; - (pos, Tcoerce_none) :: comps_rec rem - | (Sig_module(id1, pres1, mty1, _, _), - Sig_module(_id2, pres2, mty2, _, _), pos) :: rem -> begin - let cc = module_declarations ~loc env ~mark cxt subst id1 mty1 mty2 in - let rem = comps_rec rem in - match pres1, pres2, mty1.md_type with - | Mp_present, Mp_present, _ -> (pos, cc) :: rem - | _, Mp_absent, _ -> rem - | Mp_absent, Mp_present, Mty_alias p1 -> - (pos, Tcoerce_alias (env, p1, cc)) :: rem - | Mp_absent, Mp_present, _ -> assert false - end - | (Sig_modtype(id1, info1, _), Sig_modtype(_id2, info2, _), _pos) :: rem -> - modtype_infos ~loc env ~mark cxt subst id1 info1 info2; - comps_rec rem - | (Sig_class(id1, decl1, _, _), Sig_class(_id2, decl2, _, _), pos) :: rem -> - class_declarations env cxt subst id1 decl1 decl2; - (pos, Tcoerce_none) :: comps_rec rem - | (Sig_class_type(id1, info1, _, _), - Sig_class_type(_id2, info2, _, _), _pos) :: rem -> - class_type_declarations ~loc env cxt subst id1 info1 info2; - comps_rec rem - | _ -> - assert false - -and module_declarations ~loc env ~mark cxt subst id1 md1 md2 = + let deep_modifications = !shape_modified in + let first = + match item with + | Ok x -> + let runtime_coercions = + if present_at_runtime then [pos,x] else [] + in + Sign_diff.{ empty with deep_modifications; runtime_coercions } + | Error { error; recoverable=_ } -> + Sign_diff.{ empty with errors=[id,error]; deep_modifications } + in + let continue = match item with + | Ok _ -> true + | Error x -> x.recoverable + in + let rest = + if continue then + signature_components ~in_eq ~loc ~mark env subst + orig_shape shape_map rem + else Sign_diff.{ empty with leftovers=rem } + in + Sign_diff.merge first rest + +and module_declarations ~in_eq ~loc env ~mark subst id1 md1 md2 orig_shape = Builtin_attributes.check_alerts_inclusion ~def:md1.md_loc ~use:md2.md_loc @@ -522,12 +831,12 @@ and module_declarations ~loc env ~mark cxt subst id1 md1 md2 = let p1 = Path.Pident id1 in if mark_positive mark then Env.mark_module_used md1.md_uid; - strengthened_modtypes ~loc ~aliasable:true env ~mark (Module id1::cxt) subst - md1.md_type p1 md2.md_type + strengthened_modtypes ~in_eq ~loc ~aliasable:true env ~mark subst + md1.md_type p1 md2.md_type orig_shape (* Inclusion between module type specifications *) -and modtype_infos ~loc env ~mark cxt subst id info1 info2 = +and modtype_infos ~in_eq ~loc env ~mark subst id info1 info2 = Builtin_attributes.check_alerts_inclusion ~def:info1.mtd_loc ~use:info2.mtd_loc @@ -535,33 +844,60 @@ and modtype_infos ~loc env ~mark cxt subst id info1 info2 = info1.mtd_attributes info2.mtd_attributes (Ident.name id); let info2 = Subst.modtype_declaration Keep subst info2 in - let cxt' = Modtype id :: cxt in - try + let r = match (info1.mtd_type, info2.mtd_type) with - (None, None) -> () - | (Some _, None) -> () + (None, None) -> Ok Tcoerce_none + | (Some _, None) -> Ok Tcoerce_none | (Some mty1, Some mty2) -> - check_modtype_equiv ~loc env ~mark cxt' mty1 mty2 + check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 | (None, Some mty2) -> - check_modtype_equiv ~loc env ~mark cxt' (Mty_ident(Path.Pident id)) mty2 - with Error reasons -> - raise(Error((cxt, env, Modtype_infos(id, info1, info2)) :: reasons)) - -and check_modtype_equiv ~loc env ~mark cxt mty1 mty2 = - match - (modtypes ~loc env ~mark cxt Subst.identity mty1 mty2, - modtypes ~loc env ~mark:(negate_mark mark) cxt Subst.identity mty2 mty1) - with - (Tcoerce_none, Tcoerce_none) -> () - | (c1, _c2) -> + let mty1 = Mty_ident(Path.Pident id) in + check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 in + match r with + | Ok _ as ok -> ok + | Error e -> Error Error.(Module_type_declaration (diff info1 info2 e)) + +and check_modtype_equiv ~in_eq ~loc env ~mark mty1 mty2 = + let c1 = + modtypes ~in_eq:true ~loc env ~mark Subst.identity mty1 mty2 Shape.dummy_mod + in + let c2 = + (* For nested module type paths, we check only one side of the equivalence: + the outer module type is the one responsible for checking the other side + of the equivalence. + *) + if in_eq then None + else + let mark = negate_mark mark in + Some ( + modtypes ~in_eq:true ~loc env ~mark Subst.identity + mty2 mty1 Shape.dummy_mod + ) + in + match c1, c2 with + | Ok (Tcoerce_none, _), (Some Ok (Tcoerce_none, _)|None) -> Ok Tcoerce_none + | Ok (c1, _), (Some Ok _ | None) -> (* Format.eprintf "@[c1 = %a@ c2 = %a@]@." - print_coercion _c1 print_coercion _c2; *) - raise(Error [cxt, env, Modtype_permutation (mty1, c1)]) - -let include_functor_signatures ~loc env ~mark cxt subst sig1 sig2 = - let _, comps1 = build_component_table (fun _pos name -> name) sig1 in - let paired, subst = pair_components env cxt subst comps1 sig2 in - signature_components ~loc ~mark env cxt subst (List.rev paired) + print_coercion _c1 print_coercion _c2; *) + Error Error.(Illegal_permutation c1) + | Ok _, Some Error e -> Error Error.(Not_greater_than e) + | Error e, (Some Ok _ | None) -> Error Error.(Not_less_than e) + | Error less_than, Some Error greater_than -> + Error Error.(Incomparable {less_than; greater_than}) + +let include_functor_signatures ~loc env ~mark subst sig1 sig2 mod_shape = + let _, _, comps1 = build_component_table (fun _pos name -> name) sig1 in + let paired, unpaired, subst = pair_components subst comps1 sig2 in + let d = signature_components ~in_eq:false ~loc ~mark env subst mod_shape + Shape.Map.empty + (List.rev paired) + in + let open Sign_diff in + match unpaired, d.errors, d.leftovers with + | [], [], [] -> + Ok d.runtime_coercions + | missings, incompatibles, _leftovers -> + Error Error.{ env; missings; incompatibles } let can_alias env path = let rec no_apply = function @@ -571,337 +907,336 @@ let can_alias env path = in no_apply path && not (Env.is_functor_arg path env) -let check_modtype_inclusion ~loc env mty1 path1 mty2 = + + +type explanation = Env.t * Error.all +exception Error of explanation + +exception Apply_error of { + loc : Location.t ; + env : Env.t ; + lid_app : Longident.t option ; + mty_f : module_type ; + args : (Error.functor_arg_descr * module_type) list ; + } + +let check_modtype_inclusion_raw ~loc env mty1 path1 mty2 = let aliasable = can_alias env path1 in - ignore - (strengthened_modtypes ~loc ~aliasable env ~mark:Mark_both [] - Subst.identity mty1 path1 mty2) + strengthened_modtypes ~in_eq:false ~loc ~aliasable env ~mark:Mark_both + Subst.identity mty1 path1 mty2 Shape.dummy_mod + |> Result.map fst + +let check_modtype_inclusion ~loc env mty1 path1 mty2 = + match check_modtype_inclusion_raw ~loc env mty1 path1 mty2 with + | Ok _ -> None + | Error e -> Some (env, Error.In_Module_type e) + +let check_functor_application_in_path + ~errors ~loc ~lid_whole_app ~f0_path ~args + ~arg_path ~arg_mty ~param_mty env = + match check_modtype_inclusion_raw ~loc env arg_mty arg_path param_mty with + | Ok _ -> () + | Error _errs -> + if errors then + let prepare_arg (arg_path, arg_mty) = + let aliasable = can_alias env arg_path in + let smd = Mtype.strengthen ~aliasable env arg_mty arg_path in + (Error.Named arg_path, smd) + in + let mty_f = (Env.find_module f0_path env).md_type in + let args = List.map prepare_arg args in + let lid_app = Some lid_whole_app in + raise (Apply_error {loc; env; lid_app; mty_f; args}) + else + raise Not_found let () = - Env.check_functor_application := - (fun ~errors ~loc env mty1 path1 mty2 path2 -> - try - check_modtype_inclusion ~loc env mty1 path1 mty2 - with Error errs -> - if errors then - raise (Apply_error(loc, path1, path2, errs)) - else - raise Not_found) + Env.check_functor_application := check_functor_application_in_path + (* Check that an implementation of a compilation unit meets its interface. *) -let compunit env ~mark impl_name impl_sig intf_name intf_sig = - try - signatures ~loc:(Location.in_file impl_name) env ~mark [] - Subst.identity impl_sig intf_sig - with Error reasons -> - raise(Error(([], Env.empty,Interface_mismatch(impl_name, intf_name)) - :: reasons)) +let compunit env ~mark impl_name impl_sig intf_name intf_sig unit_shape = + match + signatures ~in_eq:false ~loc:(Location.in_file impl_name) env ~mark + Subst.identity impl_sig intf_sig unit_shape + with Result.Error reasons -> + let cdiff = + Error.In_Compilation_unit(Error.diff impl_name intf_name reasons) in + raise(Error(env, cdiff)) + | Ok x -> x + +(* Functor diffing computation: + The diffing computation uses the internal typing function + *) + +module Functor_inclusion_diff = struct + + module Defs = struct + type left = Types.functor_parameter + type right = left + type eq = Typedtree.module_coercion + type diff = (Types.functor_parameter, unit) Error.functor_param_symptom + type state = { + res: module_type option; + env: Env.t; + subst: Subst.t; + } + end + open Defs + + module Diff = Diffing.Define(Defs) + + let param_name = function + | Named(x,_) -> x + | Unit -> None + + let weight: Diff.change -> _ = function + | Insert _ -> 10 + | Delete _ -> 10 + | Change _ -> 10 + | Keep (param1, param2, _) -> begin + match param_name param1, param_name param2 with + | None, None + -> 0 + | Some n1, Some n2 + when String.equal (Ident.name n1) (Ident.name n2) + -> 0 + | Some _, Some _ -> 1 + | Some _, None | None, Some _ -> 1 + end -(* Hide the context and substitution parameters to the outside world *) -let modtypes ~loc env ~mark mty1 mty2 = - modtypes ~loc env ~mark [] Subst.identity mty1 mty2 -let signatures env ~mark sig1 sig2 = - signatures ~loc:Location.none env ~mark [] Subst.identity sig1 sig2 -let include_functor_signatures env ~mark:mark sig1 sig2 = - include_functor_signatures ~loc:Location.none env ~mark [] Subst.identity sig1 sig2 -let type_declarations ~loc env ~mark id decl1 decl2 = - type_declarations ~loc env ~mark [] Subst.identity id decl1 decl2 -let strengthened_module_decl ~loc ~aliasable env ~mark - md1 path1 md2 = - strengthened_module_decl ~loc ~aliasable env ~mark [] Subst.identity - md1 path1 md2 - -(* -let modtypes env m1 m2 = - let c = modtypes env m1 m2 in - Format.eprintf "@[<2>modtypes@ %a@ %a =@ %a@]@." - Printtyp.modtype m1 Printtyp.modtype m2 - print_coercion c; - c -*) -(* Error report *) - -module Illegal_permutation = struct - (** Extraction of information in case of illegal permutation - in a module type *) - - (** When examining coercions, we only have runtime component indices, - we use thus a limited version of {!pos}. *) - type coerce_pos = - | Item of int - | InArg - | InBody - - let either f x g y = match f x with - | None -> g y - | Some _ as v -> v - - (** We extract a lone transposition from a full tree of permutations. *) - let rec transposition_under path = function - | Tcoerce_structure(c,_) -> - either - (not_fixpoint path 0) c - (first_non_id path 0) c - | Tcoerce_functor(arg,res) -> - either - (transposition_under (InArg::path)) arg - (transposition_under (InBody::path)) res - | Tcoerce_none -> None - | Tcoerce_alias _ | Tcoerce_primitive _ -> - (* these coercions are not inversible, and raise an error earlier when - checking for module type equivalence *) - assert false - (* we search the first point which is not invariant at the current level *) - and not_fixpoint path pos = function - | [] -> None - | (n, _) :: q -> - if n = pos then - not_fixpoint path (pos+1) q - else - Some(List.rev path, pos, n) - (* we search the first item with a non-identity inner coercion *) - and first_non_id path pos = function - | [] -> None - | (_,Tcoerce_none) :: q -> first_non_id path (pos + 1) q - | (_,c) :: q -> - either - (transposition_under (Item pos :: path)) c - (first_non_id path (pos + 1)) q - - let transposition c = - match transposition_under [] c with - | None -> raise Not_found - | Some x -> x - - let rec runtime_item k = function - | [] -> raise Not_found - | item :: q -> - if not(is_runtime_component item) then - runtime_item k q - else if k = 0 then - item - else - runtime_item (k-1) q - - (* Find module type at position [path] and convert the [coerce_pos] path to - a [pos] path *) - let rec find env ctx path mt = match mt, path with - | (Mty_ident p | Mty_alias p), _ -> - begin match (Env.find_modtype p env).mtd_type with - | None -> raise Not_found - | Some mt -> find env ctx path mt + let keep_expansible_param = function + | Mty_ident _ | Mty_alias _ as mty -> Some mty + | Mty_signature _ | Mty_functor _ -> None + + let lookup_expansion { env ; res ; _ } = match res with + | None -> None + | Some res -> + match retrieve_functor_params env res with + | [], _ -> None + | params, res -> + let more = Array.of_list params in + Some (keep_expansible_param res, more) + + let expand_params state = + match lookup_expansion state with + | None -> state, [||] + | Some (res, expansion) -> { state with res }, expansion + + let update (d:Diff.change) st = match d with + | Insert (Unit | Named (None,_)) + | Delete (Unit | Named (None,_)) + | Keep (Unit,_,_) + | Keep (_,Unit,_) + | Change (_,(Unit | Named (None,_)), _) -> + st, [||] + | Insert (Named (Some id, arg)) + | Delete (Named (Some id, arg)) + | Change (Unit, Named (Some id, arg), _) -> + let arg' = Subst.modtype Keep st.subst arg in + let env = Env.add_module id Mp_present arg' st.env in + expand_params { st with env } + | Keep (Named (name1, _), Named (name2, arg2), _) + | Change (Named (name1, _), Named (name2, arg2), _) -> begin + let arg' = Subst.modtype Keep st.subst arg2 in + match name1, name2 with + | Some id1, Some id2 -> + let env = Env.add_module id1 Mp_present arg' st.env in + let subst = Subst.add_module id2 (Path.Pident id1) st.subst in + expand_params { st with env; subst } + | None, Some id2 -> + let env = Env.add_module id2 Mp_present arg' st.env in + { st with env }, [||] + | Some id1, None -> + let env = Env.add_module id1 Mp_present arg' st.env in + expand_params { st with env } + | None, None -> + st, [||] + end + + let diff env (l1,res1) (l2,_) = + let module Compute = Diff.Left_variadic(struct + let test st mty1 mty2 = + let loc = Location.none in + let res, _, _ = + functor_param ~in_eq:false ~loc st.env ~mark:Mark_neither + st.subst mty1 mty2 + in + res + let update = update + let weight = weight + end) + in + let param1 = Array.of_list l1 in + let param2 = Array.of_list l2 in + let state = + { env; subst = Subst.identity; res = keep_expansible_param res1} + in + Compute.diff state param1 param2 + +end + +module Functor_app_diff = struct + module I = Functor_inclusion_diff + module Defs= struct + type left = Error.functor_arg_descr * Types.module_type + type right = Types.functor_parameter + type eq = Typedtree.module_coercion + type diff = (Error.functor_arg_descr, unit) Error.functor_param_symptom + type state = I.Defs.state + end + module Diff = Diffing.Define(Defs) + + let weight: Diff.change -> _ = function + | Insert _ -> 10 + | Delete _ -> 10 + | Change _ -> 10 + | Keep (param1, param2, _) -> + (* We assign a small penalty to named arguments with + non-matching names *) + begin + let desc1 : Error.functor_arg_descr = fst param1 in + match desc1, I.param_name param2 with + | (Unit | Anonymous) , None + -> 0 + | Named (Path.Pident n1), Some n2 + when String.equal (Ident.name n1) (Ident.name n2) + -> 0 + | Named _, Some _ -> 1 + | Named _, None | (Unit | Anonymous), Some _ -> 1 + end + + let update (d: Diff.change) (st:Defs.state) = + let open Error in + match d with + | Insert _ + | Delete _ + | Keep ((Unit,_),_,_) + | Keep (_,Unit,_) + | Change (_,(Unit | Named (None,_)), _ ) + | Change ((Unit,_), Named (Some _, _), _) -> + st, [||] + | Keep ((Named arg, _mty) , Named (param_name, _param), _) + | Change ((Named arg, _mty), Named (param_name, _param), _) -> + begin match param_name with + | Some param -> + let res = + Option.map (fun res -> + let scope = Ctype.create_scope () in + let subst = Subst.add_module param arg Subst.identity in + Subst.modtype (Rescope scope) subst res + ) + st.res + in + let subst = Subst.add_module param arg st.subst in + I.expand_params { st with subst; res } + | None -> + st, [||] end - | Mty_signature s , [] -> List.rev ctx, s - | Mty_signature s, Item k :: q -> - begin match runtime_item k s with - | Sig_module (id, _, md,_,_) -> find env (Module id :: ctx) q md.md_type - | _ -> raise Not_found + | Keep ((Anonymous, mty) , Named (param_name, _param), _) + | Change ((Anonymous, mty), Named (param_name, _param), _) -> begin + begin match param_name with + | Some param -> + let mty' = Subst.modtype Keep st.subst mty in + let env = + Env.add_module ~arg:true param Mp_present mty' st.env in + let res = + Option.map (Mtype.nondep_supertype env [param]) st.res in + I.expand_params { st with env; res} + | None -> + st, [||] end - | Mty_functor(Named (_,mt) as arg,_), InArg :: q -> - find env (Arg arg :: ctx) q mt - | Mty_functor(arg, mt), InBody :: q -> - find env (Body arg :: ctx) q mt - | _ -> raise Not_found - - let find env path mt = find env [] path mt - let item mt k = item_ident_name (runtime_item k mt) - - let pp_item ppf (id,_,kind) = - Format.fprintf ppf "%s %S" (kind_of_field_desc kind) (Ident.name id) - - let pp ctx_printer env ppf (mty,c) = - try - let p, k, l = transposition c in - let ctx, mt = find env p mty in - Format.fprintf ppf - "@[Illegal permutation of runtime components in a module type.@ \ - @[For example,@ %a@[the %a@ and the %a are not in the same order@ \ - in the expected and actual module types.@]@]" - ctx_printer ctx pp_item (item mt k) pp_item (item mt l) - with Not_found -> (* this should not happen *) - Format.fprintf ppf - "Illegal permutation of runtime components in a module type." + end + + let diff env ~f ~args = + let params, res = retrieve_functor_params env f in + let module Compute = Diff.Right_variadic(struct + let update = update + let test (state:Defs.state) (arg,arg_mty) param = + let loc = Location.none in + let res = match (arg:Error.functor_arg_descr), param with + | Unit, Unit -> Ok Tcoerce_none + | Unit, Named _ | (Anonymous | Named _), Unit -> + Result.Error (Error.Incompatible_params(arg,param)) + | ( Anonymous | Named _ ) , Named (_, param) -> + match + modtypes ~in_eq:false ~loc state.env ~mark:Mark_neither + state.subst arg_mty param Shape.dummy_mod + with + | Error mty -> Result.Error (Error.Mismatch mty) + | Ok (cc, _) -> Ok cc + in + res + let weight = weight + end) + in + let args = Array.of_list args in + let params = Array.of_list params in + let state : Defs.state = + { env; subst = Subst.identity; res = I.keep_expansible_param res } + in + Compute.diff state args params end -open Format - -let show_loc msg ppf loc = - let pos = loc.Location.loc_start in - if List.mem pos.Lexing.pos_fname [""; "_none_"; "//toplevel//"] then () - else fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg - -let show_locs ppf (loc1, loc2) = - show_loc "Expected declaration" ppf loc2; - show_loc "Actual declaration" ppf loc1 - -let path_of_context = function - Module id :: rem -> - let rec subm path = function - | [] -> path - | Module id :: rem -> subm (Path.Pdot (path, Ident.name id)) rem - | _ -> assert false - in subm (Path.Pident id) rem - | _ -> assert false - - -let rec context ppf = function - Module id :: rem -> - fprintf ppf "@[<2>module %a%a@]" Printtyp.ident id args rem - | Modtype id :: rem -> - fprintf ppf "@[<2>module type %a =@ %a@]" - Printtyp.ident id context_mty rem - | Body x :: rem -> - fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem - | Arg x :: rem -> - fprintf ppf "functor (%s : %a) -> ..." (argname x) context_mty rem - | [] -> - fprintf ppf "" -and context_mty ppf = function - (Module _ | Modtype _) :: _ as rem -> - fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem - | cxt -> context ppf cxt -and args ppf = function - Body x :: rem -> - fprintf ppf "(%s)%a" (argname x) args rem - | Arg x :: rem -> - fprintf ppf "(%s :@ %a) : ..." (argname x) context_mty rem - | cxt -> - fprintf ppf " :@ %a" context_mty cxt -and argname = function - | Unit -> "" - | Named (None, _) -> "_" - | Named (Some id, _) -> Ident.name id - -let alt_context ppf cxt = - if cxt = [] then () else - if List.for_all (function Module _ -> true | _ -> false) cxt then - fprintf ppf "in module %a,@ " Printtyp.path (path_of_context cxt) - else - fprintf ppf "@[at position@ %a,@]@ " context cxt - -let context ppf cxt = - if cxt = [] then () else - if List.for_all (function Module _ -> true | _ -> false) cxt then - fprintf ppf "In module %a:@ " Printtyp.path (path_of_context cxt) - else - fprintf ppf "@[At position@ %a@]@ " context cxt - -let include_err env ppf = function - | Missing_field (id, loc, kind) -> - fprintf ppf "The %s `%a' is required but not provided" - kind Printtyp.ident id; - show_loc "Expected declaration" ppf loc - | Value_descriptions(id, d1, d2) -> - fprintf ppf - "@[Values do not match:@ %a@;<1 -2>is not included in@ %a@]" - !Oprint.out_sig_item (Printtyp.tree_of_value_description id d1) - !Oprint.out_sig_item (Printtyp.tree_of_value_description id d2); - show_locs ppf (d1.val_loc, d2.val_loc) - | Type_declarations(id, d1, d2, err) -> - fprintf ppf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a@]" - "Type declarations do not match" - !Oprint.out_sig_item - (Printtyp.tree_of_type_declaration id d1 Trec_first) - "is not included in" - !Oprint.out_sig_item - (Printtyp.tree_of_type_declaration id d2 Trec_first) - (Includecore.report_type_mismatch - "the first" "the second" "declaration") err - show_locs (d1.type_loc, d2.type_loc) - | Extension_constructors(id, x1, x2, err) -> - fprintf ppf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]@ %a%a@]" - "Extension declarations do not match" - !Oprint.out_sig_item - (Printtyp.tree_of_extension_constructor id x1 Text_first) - "is not included in" - !Oprint.out_sig_item - (Printtyp.tree_of_extension_constructor id x2 Text_first) - (Includecore.report_extension_constructor_mismatch - "the first" "the second" "declaration") err - show_locs (x1.ext_loc, x2.ext_loc) - | Module_types(mty1, mty2)-> - fprintf ppf - "@[Modules do not match:@ \ - %a@;<1 -2>is not included in@ %a@]" - !Oprint.out_module_type (Printtyp.tree_of_modtype mty1) - !Oprint.out_module_type (Printtyp.tree_of_modtype mty2) - | Modtype_infos(id, d1, d2) -> - fprintf ppf - "@[Module type declarations do not match:@ \ - %a@;<1 -2>does not match@ %a@]" - !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d1) - !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d2) - | Modtype_permutation (mty,c) -> - Illegal_permutation.pp alt_context env ppf (mty,c) - | Interface_mismatch(impl_name, intf_name) -> - fprintf ppf "@[The implementation %s@ does not match the interface %s:" - impl_name intf_name - | Class_type_declarations(id, d1, d2, reason) -> - fprintf ppf - "@[Class type declarations do not match:@ \ - %a@;<1 -2>does not match@ %a@]@ %a" - !Oprint.out_sig_item - (Printtyp.tree_of_cltype_declaration id d1 Trec_first) - !Oprint.out_sig_item - (Printtyp.tree_of_cltype_declaration id d2 Trec_first) - Includeclass.report_error reason - | Class_declarations(id, d1, d2, reason) -> - fprintf ppf - "@[Class declarations do not match:@ \ - %a@;<1 -2>does not match@ %a@]@ %a" - !Oprint.out_sig_item (Printtyp.tree_of_class_declaration id d1 Trec_first) - !Oprint.out_sig_item (Printtyp.tree_of_class_declaration id d2 Trec_first) - Includeclass.report_error reason - | Unbound_modtype_path path -> - fprintf ppf "Unbound module type %a" Printtyp.path path - | Unbound_module_path path -> - fprintf ppf "Unbound module %a" Printtyp.path path - | Invalid_module_alias path -> - fprintf ppf "Module %a cannot be aliased" Printtyp.path path - -let include_err ppf (cxt, env, err) = - Printtyp.wrap_printing_env ~error:true env (fun () -> - fprintf ppf "@[%a%a@]" context (List.rev cxt) (include_err env) err) - -let buffer = ref Bytes.empty -let is_big obj = - let size = !Clflags.error_size in - size > 0 && - begin - if Bytes.length !buffer < size then buffer := Bytes.create size; - try ignore (Marshal.to_buffer !buffer 0 size obj []); false - with _ -> true - end +(* Hide the context and substitution parameters to the outside world *) -let report_error ppf errs = - if errs = [] then () else - let (errs , err) = split_last errs in - let pe = ref true in - let include_err' ppf (_,_,obj as err) = - if not (is_big obj) then fprintf ppf "%a@ " include_err err - else if !pe then (fprintf ppf "...@ "; pe := false) - in - let print_errs ppf = List.iter (include_err' ppf) in - Printtyp.Conflicts.reset(); - fprintf ppf "@[%a%a%t@]" print_errs errs include_err err - Printtyp.Conflicts.print_explanations +let modtypes_with_shape ~shape ~loc env ~mark mty1 mty2 = + match modtypes ~in_eq:false ~loc env ~mark + Subst.identity mty1 mty2 shape + with + | Ok (cc, shape) -> cc, shape + | Error reason -> raise (Error (env, Error.(In_Module_type reason))) + +let modtypes ~loc env ~mark mty1 mty2 = + match modtypes ~in_eq:false ~loc env ~mark + Subst.identity mty1 mty2 Shape.dummy_mod + with + | Ok (cc, _) -> cc + | Error reason -> raise (Error (env, Error.(In_Module_type reason))) -let report_apply_error p1 p2 ppf errs = - fprintf ppf "@[The type of %a does not match %a's parameter@ %a@]" - Printtyp.path p1 Printtyp.path p2 report_error errs +let signatures env ~mark sig1 sig2 = + match signatures ~in_eq:false ~loc:Location.none env ~mark + Subst.identity sig1 sig2 Shape.dummy_mod + with + | Ok (cc, _) -> cc + | Error reason -> raise (Error(env,Error.(In_Signature reason))) -(* We could do a better job to split the individual error items - as sub-messages of the main interface mismatch on the whole unit. *) -let () = - Location.register_error_of_exn - (function - | Error err -> Some (Location.error_of_printer_file report_error err) - | Apply_error(loc, p1, p2, err) -> - Some (Location.error_of_printer ~loc (report_apply_error p1 p2) err) - | _ -> None - ) +let include_functor_signatures env ~mark sig1 sig2 = + match include_functor_signatures ~loc:Location.none env ~mark + Subst.identity sig1 sig2 Shape.dummy_mod + with + | Ok cc -> cc + | Error reason -> raise (Error(env,Error.(In_Include_functor_signature reason))) + +let type_declarations ~loc env ~mark id decl1 decl2 = + match type_declarations ~loc env ~mark Subst.identity id decl1 decl2 with + | Ok _ -> () + | Error (Error.Core reason) -> + raise (Error(env,Error.(In_Type_declaration(id,reason)))) + | Error _ -> assert false + +let strengthened_module_decl ~loc ~aliasable env ~mark md1 path1 md2 = + match strengthened_module_decl ~loc ~aliasable env ~mark Subst.identity + md1 path1 md2 Shape.dummy_mod with + | Ok (x, _shape) -> x + | Error mdiff -> + raise (Error(env,Error.(In_Module_type mdiff))) + +let expand_module_alias ~strengthen env path = + match expand_module_alias ~strengthen env path with + | Ok x -> x + | Result.Error _ -> + raise (Error(env,In_Expansion(Error.Unbound_module_path path))) + +let check_modtype_equiv ~loc env id mty1 mty2 = + match check_modtype_equiv ~in_eq:false ~loc env ~mark:Mark_both mty1 mty2 with + | Ok _ -> () + | Error e -> + raise (Error(env, + Error.(In_Module_type_substitution (id,diff mty1 mty2 e))) + ) diff --git a/ocaml/typing/includemod.mli b/ocaml/typing/includemod.mli index c10ea36dcb8..a13d339eb3b 100644 --- a/ocaml/typing/includemod.mli +++ b/ocaml/typing/includemod.mli @@ -17,7 +17,6 @@ open Typedtree open Types -open Format (** Type describing which arguments of an inclusion to consider as used for the usage warnings. [Mark_both] is the default. *) @@ -31,21 +30,145 @@ type mark = | Mark_neither (** Do not mark definitions used from either argument *) +module Error: sig + + type ('elt,'explanation) diff = { + got:'elt; + expected:'elt; + symptom:'explanation + } + type 'elt core_diff =('elt,unit) diff + + type functor_arg_descr = + | Anonymous + | Named of Path.t + | Unit + + type core_sigitem_symptom = + | Value_descriptions of + (Types.value_description, Includecore.value_mismatch) diff + | Type_declarations of + (Types.type_declaration, Includecore.type_mismatch) diff + | Extension_constructors of + (Types.extension_constructor, + Includecore.extension_constructor_mismatch) diff + | Class_type_declarations of + (Types.class_type_declaration, Ctype.class_match_failure list) diff + | Class_declarations of + (Types.class_declaration, Ctype.class_match_failure list) diff + + type core_module_type_symptom = + | Not_an_alias + | Not_an_identifier + | Incompatible_aliases + | Abstract_module_type + | Unbound_module_path of Path.t + + type module_type_symptom = + | Mt_core of core_module_type_symptom + | Signature of signature_symptom + | Functor of functor_symptom + | Invalid_module_alias of Path.t + | After_alias_expansion of module_type_diff + + + and module_type_diff = (Types.module_type, module_type_symptom) diff + + and functor_symptom = + | Params of functor_params_diff + | Result of module_type_diff + + and ('arg,'path) functor_param_symptom = + | Incompatible_params of 'arg * Types.functor_parameter + | Mismatch of module_type_diff + + and arg_functor_param_symptom = + (Types.functor_parameter, Ident.t) functor_param_symptom + + and functor_params_diff = + (Types.functor_parameter list * Types.module_type) core_diff + + and signature_symptom = { + env: Env.t; + missings: Types.signature_item list; + incompatibles: (Ident.t * sigitem_symptom) list; + (** signature items that could not be compared due to type divergence *) + } + and sigitem_symptom = + | Core of core_sigitem_symptom + | Module_type_declaration of + (Types.modtype_declaration, module_type_declaration_symptom) diff + | Module_type of module_type_diff + + and module_type_declaration_symptom = + | Illegal_permutation of Typedtree.module_coercion + | Not_greater_than of module_type_diff + | Not_less_than of module_type_diff + | Incomparable of + {less_than:module_type_diff; greater_than: module_type_diff} + + + type all = + | In_Compilation_unit of (string, signature_symptom) diff + | In_Signature of signature_symptom + | In_Include_functor_signature of signature_symptom + | In_Module_type of module_type_diff + | In_Module_type_substitution of + Ident.t * (Types.module_type,module_type_declaration_symptom) diff + | In_Type_declaration of Ident.t * core_sigitem_symptom + | In_Expansion of core_module_type_symptom +end +type explanation = Env.t * Error.all + +(* Extract name, kind and ident from a signature item *) +type field_kind = + | Field_value + | Field_type + | Field_exception + | Field_typext + | Field_module + | Field_modtype + | Field_class + | Field_classtype + +type field_desc = { name: string; kind: field_kind } + +val kind_of_field_desc: field_desc -> string +val field_desc: field_kind -> Ident.t -> field_desc + +(** Map indexed by both field types and names. + This avoids name clashes between different sorts of fields + such as values and types. *) +module FieldMap: Map.S with type key = field_desc + +val item_ident_name: Types.signature_item -> Ident.t * Location.t * field_desc +val is_runtime_component: Types.signature_item -> bool + + +(* Typechecking *) + val modtypes: loc:Location.t -> Env.t -> mark:mark -> module_type -> module_type -> module_coercion +val modtypes_with_shape: + shape:Shape.t -> loc:Location.t -> Env.t -> mark:mark -> + module_type -> module_type -> module_coercion * Shape.t + val strengthened_module_decl: loc:Location.t -> aliasable:bool -> Env.t -> mark:mark -> module_declaration -> Path.t -> module_declaration -> module_coercion val check_modtype_inclusion : loc:Location.t -> Env.t -> Types.module_type -> Path.t -> Types.module_type -> - unit + explanation option (** [check_modtype_inclusion ~loc env mty1 path1 mty2] checks that the functor application F(M) is well typed, where mty2 is the type of the argument of F and path1/mty1 is the path/unstrenghened type of M. *) +val check_modtype_equiv: + loc:Location.t -> Env.t -> Ident.t -> module_type -> module_type -> unit + val signatures: Env.t -> mark:mark -> signature -> signature -> module_coercion @@ -54,44 +177,56 @@ val include_functor_signatures : Env.t -> mark:mark -> val compunit: Env.t -> mark:mark -> string -> signature -> - string -> signature -> module_coercion + string -> signature -> Shape.t -> module_coercion * Shape.t val type_declarations: loc:Location.t -> Env.t -> mark:mark -> Ident.t -> type_declaration -> type_declaration -> unit -val print_coercion: formatter -> module_coercion -> unit - -type symptom = - Missing_field of Ident.t * Location.t * string (* kind *) - | Value_descriptions of Ident.t * value_description * value_description - | Type_declarations of Ident.t * type_declaration - * type_declaration * Includecore.type_mismatch - | Extension_constructors of Ident.t * extension_constructor - * extension_constructor * Includecore.extension_constructor_mismatch - | Module_types of module_type * module_type - | Modtype_infos of Ident.t * modtype_declaration * modtype_declaration - | Modtype_permutation of Types.module_type * Typedtree.module_coercion - | Interface_mismatch of string * string - | Class_type_declarations of - Ident.t * class_type_declaration * class_type_declaration * - Ctype.class_match_failure list - | Class_declarations of - Ident.t * class_declaration * class_declaration * - Ctype.class_match_failure list - | Unbound_modtype_path of Path.t - | Unbound_module_path of Path.t - | Invalid_module_alias of Path.t +val print_coercion: Format.formatter -> module_coercion -> unit type pos = | Module of Ident.t | Modtype of Ident.t | Arg of functor_parameter | Body of functor_parameter -type error = pos list * Env.t * symptom -exception Error of error list +exception Error of explanation +exception Apply_error of { + loc : Location.t ; + env : Env.t ; + lid_app : Longident.t option ; + mty_f : module_type ; + args : (Error.functor_arg_descr * Types.module_type) list ; + } + +val expand_module_alias: strengthen:bool -> Env.t -> Path.t -> Types.module_type + +module Functor_inclusion_diff: sig + module Defs: sig + type left = Types.functor_parameter + type right = left + type eq = Typedtree.module_coercion + type diff = (Types.functor_parameter, unit) Error.functor_param_symptom + type state + end + val diff: Env.t -> + Types.functor_parameter list * Types.module_type -> + Types.functor_parameter list * Types.module_type -> + Diffing.Define(Defs).patch +end -val report_error: formatter -> error list -> unit -val expand_module_alias: - strengthen:bool -> Env.t -> pos list -> Path.t -> Types.module_type +module Functor_app_diff: sig + module Defs: sig + type left = Error.functor_arg_descr * Types.module_type + type right = Types.functor_parameter + type eq = Typedtree.module_coercion + type diff = (Error.functor_arg_descr, unit) Error.functor_param_symptom + type state + end + val diff: + Env.t -> + f:Types.module_type -> + args:(Error.functor_arg_descr * Types.module_type) list -> + Diffing.Define(Defs).patch +end diff --git a/ocaml/typing/includemod_errorprinter.ml b/ocaml/typing/includemod_errorprinter.ml new file mode 100644 index 00000000000..e5c27692087 --- /dev/null +++ b/ocaml/typing/includemod_errorprinter.ml @@ -0,0 +1,937 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + +module Context = struct + type pos = + | Module of Ident.t + | Modtype of Ident.t + | Arg of Types.functor_parameter + | Body of Types.functor_parameter + + let path_of_context = function + Module id :: rem -> + let rec subm path = function + | [] -> path + | Module id :: rem -> subm (Path.Pdot (path, Ident.name id)) rem + | _ -> assert false + in subm (Path.Pident id) rem + | _ -> assert false + + + let rec context ppf = function + Module id :: rem -> + Format.fprintf ppf "@[<2>module %a%a@]" Printtyp.ident id args rem + | Modtype id :: rem -> + Format.fprintf ppf "@[<2>module type %a =@ %a@]" + Printtyp.ident id context_mty rem + | Body x :: rem -> + Format.fprintf ppf "functor (%s) ->@ %a" (argname x) context_mty rem + | Arg x :: rem -> + Format.fprintf ppf "functor (%s : %a) -> ..." + (argname x) context_mty rem + | [] -> + Format.fprintf ppf "" + and context_mty ppf = function + (Module _ | Modtype _) :: _ as rem -> + Format.fprintf ppf "@[<2>sig@ %a@;<1 -2>end@]" context rem + | cxt -> context ppf cxt + and args ppf = function + Body x :: rem -> + Format.fprintf ppf "(%s)%a" (argname x) args rem + | Arg x :: rem -> + Format.fprintf ppf "(%s :@ %a) : ..." (argname x) context_mty rem + | cxt -> + Format.fprintf ppf " :@ %a" context_mty cxt + and argname = function + | Types.Unit -> "" + | Types.Named (None, _) -> "_" + | Types.Named (Some id, _) -> Ident.name id + + let alt_pp ppf cxt = + if cxt = [] then () else + if List.for_all (function Module _ -> true | _ -> false) cxt then + Format.fprintf ppf "in module %a," Printtyp.path (path_of_context cxt) + else + Format.fprintf ppf "@[at position@ %a,@]" context cxt + + let pp ppf cxt = + if cxt = [] then () else + if List.for_all (function Module _ -> true | _ -> false) cxt then + Format.fprintf ppf "In module %a:@ " Printtyp.path (path_of_context cxt) + else + Format.fprintf ppf "@[At position@ %a@]@ " context cxt +end + +module Illegal_permutation = struct + (** Extraction of information in case of illegal permutation + in a module type *) + + (** When examining coercions, we only have runtime component indices, + we use thus a limited version of {!pos}. *) + type coerce_pos = + | Item of int + | InArg + | InBody + + let either f x g y = match f x with + | None -> g y + | Some _ as v -> v + + (** We extract a lone transposition from a full tree of permutations. *) + let rec transposition_under path (coerc:Typedtree.module_coercion) = + match coerc with + | Tcoerce_structure(c,_) -> + either + (not_fixpoint path 0) c + (first_non_id path 0) c + | Tcoerce_functor(arg,res) -> + either + (transposition_under (InArg::path)) arg + (transposition_under (InBody::path)) res + | Tcoerce_none -> None + | Tcoerce_alias _ | Tcoerce_primitive _ -> + (* these coercions are not inversible, and raise an error earlier when + checking for module type equivalence *) + assert false + (* we search the first point which is not invariant at the current level *) + and not_fixpoint path pos = function + | [] -> None + | (n, _) :: q -> + if n = pos then + not_fixpoint path (pos+1) q + else + Some(List.rev path, pos, n) + (* we search the first item with a non-identity inner coercion *) + and first_non_id path pos = function + | [] -> None + | (_, Typedtree.Tcoerce_none) :: q -> first_non_id path (pos + 1) q + | (_,c) :: q -> + either + (transposition_under (Item pos :: path)) c + (first_non_id path (pos + 1)) q + + let transposition c = + match transposition_under [] c with + | None -> raise Not_found + | Some x -> x + + let rec runtime_item k = function + | [] -> raise Not_found + | item :: q -> + if not(Includemod.is_runtime_component item) then + runtime_item k q + else if k = 0 then + item + else + runtime_item (k-1) q + + (* Find module type at position [path] and convert the [coerce_pos] path to + a [pos] path *) + let rec find env ctx path (mt:Types.module_type) = match mt, path with + | (Mty_ident p | Mty_alias p), _ -> + begin match (Env.find_modtype p env).mtd_type with + | None -> raise Not_found + | Some mt -> find env ctx path mt + end + | Mty_signature s , [] -> List.rev ctx, s + | Mty_signature s, Item k :: q -> + begin match runtime_item k s with + | Sig_module (id, _, md,_,_) -> + find env (Context.Module id :: ctx) q md.md_type + | _ -> raise Not_found + end + | Mty_functor(Named (_,mt) as arg,_), InArg :: q -> + find env (Context.Arg arg :: ctx) q mt + | Mty_functor(arg, mt), InBody :: q -> + find env (Context.Body arg :: ctx) q mt + | _ -> raise Not_found + + let find env path mt = find env [] path mt + let item mt k = Includemod.item_ident_name (runtime_item k mt) + + let pp_item ppf (id,_,kind) = + Format.fprintf ppf "%s %S" + (Includemod.kind_of_field_desc kind) + (Ident.name id) + + let pp ctx_printer env ppf (mty,c) = + try + let p, k, l = transposition c in + let ctx, mt = find env p mty in + Format.fprintf ppf + "@[Illegal permutation of runtime components in a module type.@ \ + @[For example,@ %a@]@ @[the %a@ and the %a are not in the same order@ \ + in the expected and actual module types.@]@]" + ctx_printer ctx pp_item (item mt k) pp_item (item mt l) + with Not_found -> (* this should not happen *) + Format.fprintf ppf + "Illegal permutation of runtime components in a module type." + +end + + + +module Err = Includemod.Error + +let buffer = ref Bytes.empty +let is_big obj = + let size = !Clflags.error_size in + size > 0 && + begin + if Bytes.length !buffer < size then buffer := Bytes.create size; + try ignore (Marshal.to_buffer !buffer 0 size obj []); false + with _ -> true + end + +let show_loc msg ppf loc = + let pos = loc.Location.loc_start in + if List.mem pos.Lexing.pos_fname [""; "_none_"; "//toplevel//"] then () + else Format.fprintf ppf "@\n@[<2>%a:@ %s@]" Location.print_loc loc msg + +let show_locs ppf (loc1, loc2) = + show_loc "Expected declaration" ppf loc2; + show_loc "Actual declaration" ppf loc1 + + +let dmodtype mty = + let tmty = Printtyp.tree_of_modtype mty in + Format.dprintf "%a" !Oprint.out_module_type tmty + +let space ppf () = Format.fprintf ppf "@ " + +(** + In order to display a list of functor arguments in a compact format, + we introduce a notion of shorthand for functor arguments. + The aim is to first present the lists of actual and expected types with + shorthands: + + (X: $S1) (Y: $S2) (Z: An_existing_module_type) ... + does not match + (X: $T1) (Y: A_real_path) (Z: $T3) ... + + and delay the full display of the module types corresponding to $S1, $S2, + $T1, and $T3 to the suberror message. + +*) +module With_shorthand = struct + + (** A item with a potential shorthand name *) + type 'a named = { + item: 'a; + name : string; + } + + type 'a t = + | Original of 'a (** The shorthand has been discarded *) + | Synthetic of 'a named + (** The shorthand is potentially useful *) + + type functor_param = + | Unit + | Named of (Ident.t option * Types.module_type t) + + (** Shorthand generation *) + type kind = + | Got + | Expected + | Unneeded + + type variant = + | App + | Inclusion + + let elide_if_app ctx s = match ctx with + | App -> Unneeded + | Inclusion -> s + + let make side pos = + match side with + | Got -> Format.sprintf "$S%d" pos + | Expected -> Format.sprintf "$T%d" pos + | Unneeded -> "..." + + (** Add shorthands to a patch *) + open Diffing + let patch ctx p = + let add_shorthand side pos mty = + {name = (make side pos); item = mty } + in + let aux i d = + let pos = i + 1 in + let d = match d with + | Insert mty -> + Insert (add_shorthand Expected pos mty) + | Delete mty -> + Delete (add_shorthand (elide_if_app ctx Got) pos mty) + | Change (g, e, p) -> + Change + (add_shorthand Got pos g, + add_shorthand Expected pos e, p) + | Keep (g, e, p) -> + Keep (add_shorthand Got pos g, + add_shorthand (elide_if_app ctx Expected) pos e, p) + in + pos, d + in + List.mapi aux p + + (** Shorthand computation from named item *) + let modtype (r : _ named) = match r.item with + | Types.Mty_ident _ + | Types.Mty_alias _ + | Types.Mty_signature [] + -> Original r.item + | Types.Mty_signature _ | Types.Mty_functor _ + -> Synthetic r + + let functor_param (ua : _ named) = match ua.item with + | Types.Unit -> Unit + | Types.Named (from, mty) -> + Named (from, modtype { ua with item = mty }) + + (** Printing of arguments with shorthands *) + let pp ppx = function + | Original x -> ppx x + | Synthetic s -> Format.dprintf "%s" s.name + + let pp_orig ppx = function + | Original x | Synthetic { item=x; _ } -> ppx x + + let definition x = match functor_param x with + | Unit -> Format.dprintf "()" + | Named(_,short_mty) -> + match short_mty with + | Original mty -> dmodtype mty + | Synthetic {name; item = mty} -> + Format.dprintf + "%s@ =@ %t" name (dmodtype mty) + + let param x = match functor_param x with + | Unit -> Format.dprintf "()" + | Named (_, short_mty) -> + pp dmodtype short_mty + + let qualified_param x = match functor_param x with + | Unit -> Format.dprintf "()" + | Named (None, Original (Mty_signature []) ) -> + Format.dprintf "(sig end)" + | Named (None, short_mty) -> + pp dmodtype short_mty + | Named (Some p, short_mty) -> + Format.dprintf "(%s : %t)" + (Ident.name p) (pp dmodtype short_mty) + + let definition_of_argument ua = + let arg, mty = ua.item in + match (arg: Err.functor_arg_descr) with + | Unit -> Format.dprintf "()" + | Named p -> + let mty = modtype { ua with item = mty } in + Format.dprintf + "%a@ :@ %t" + Printtyp.path p + (pp_orig dmodtype mty) + | Anonymous -> + let short_mty = modtype { ua with item = mty } in + begin match short_mty with + | Original mty -> dmodtype mty + | Synthetic {name; item=mty} -> + Format.dprintf "%s@ :@ %t" name (dmodtype mty) + end + + let arg ua = + let arg, mty = ua.item in + match (arg: Err.functor_arg_descr) with + | Unit -> Format.dprintf "()" + | Named p -> fun ppf -> Printtyp.path ppf p + | Anonymous -> + let short_mty = modtype { ua with item=mty } in + pp dmodtype short_mty + +end + + +module Functor_suberror = struct + open Err + + let param_id x = match x.With_shorthand.item with + | Types.Named (Some _ as x,_) -> x + | Types.(Unit | Named(None,_)) -> None + + (** Print the list of params with style *) + let pretty_params sep proj printer patch = + let elt (x,param) = + let sty = Diffing.(style @@ classify x) in + Format.dprintf "%a%t%a" + Format.pp_open_stag (Misc.Color.Style sty) + (printer param) + Format.pp_close_stag () + in + let params = List.filter_map proj @@ List.map snd patch in + Printtyp.functor_parameters ~sep elt params + + let expected d = + let extract: _ Diffing.change -> _ = function + | Insert mty + | Keep(_,mty,_) + | Change (_,mty,_) as x -> + Some (param_id mty,(x, mty)) + | Delete _ -> None + in + pretty_params space extract With_shorthand.qualified_param d + + let drop_inserted_suffix patch = + let rec drop = function + | Diffing.Insert _ :: q -> drop q + | rest -> List.rev rest in + drop (List.rev patch) + + let prepare_patch ~drop ~ctx patch = + let drop_suffix x = if drop then drop_inserted_suffix x else x in + patch |> drop_suffix |> With_shorthand.patch ctx + + + module Inclusion = struct + + let got d = + let extract: _ Diffing.change -> _ = function + | Delete mty + | Keep (mty,_,_) + | Change (mty,_,_) as x -> + Some (param_id mty,(x,mty)) + | Insert _ -> None + in + pretty_params space extract With_shorthand.qualified_param d + + let insert mty = + Format.dprintf + "An argument appears to be missing with module type@;<1 2>@[%t@]" + (With_shorthand.definition mty) + + let delete mty = + Format.dprintf + "An extra argument is provided of module type@;<1 2>@[%t@]" + (With_shorthand.definition mty) + + let ok x y = + Format.dprintf + "Module types %t and %t match" + (With_shorthand.param x) + (With_shorthand.param y) + + let diff g e more = + let g = With_shorthand.definition g in + let e = With_shorthand.definition e in + Format.dprintf + "Module types do not match:@ @[%t@]@;<1 -2>does not include@ \ + @[%t@]%t" + g e (more ()) + + let incompatible = function + | Types.Unit -> + Format.dprintf + "The functor was expected to be applicative at this position" + | Types.Named _ -> + Format.dprintf + "The functor was expected to be generative at this position" + + let patch env got expected = + Includemod.Functor_inclusion_diff.diff env got expected + |> prepare_patch ~drop:false ~ctx:Inclusion + + end + + module App = struct + + let patch env ~f ~args = + Includemod.Functor_app_diff.diff env ~f ~args + |> prepare_patch ~drop:true ~ctx:App + + let got d = + let extract: _ Diffing.change -> _ = function + | Delete mty + | Keep (mty,_,_) + | Change (mty,_,_) as x -> + Some (None,(x,mty)) + | Insert _ -> None + in + pretty_params space extract With_shorthand.arg d + + let delete mty = + Format.dprintf + "The following extra argument is provided@;<1 2>@[%t@]" + (With_shorthand.definition_of_argument mty) + + let insert = Inclusion.insert + + let ok x y = + let pp_orig_name = match With_shorthand.functor_param y with + | With_shorthand.Named (_, Original mty) -> + Format.dprintf " %t" (dmodtype mty) + | _ -> ignore + in + Format.dprintf + "Module %t matches the expected module type%t" + (With_shorthand.arg x) + pp_orig_name + + let diff g e more = + let g = With_shorthand.definition_of_argument g in + let e = With_shorthand.definition e in + Format.dprintf + "Modules do not match:@ @[%t@]@;<1 -2>\ + is not included in@ @[%t@]%t" + g e (more ()) + + (** Specialized to avoid introducing shorthand names + for single change difference + *) + let single_diff g e more = + let _arg, mty = g.With_shorthand.item in + let e = match e.With_shorthand.item with + | Types.Unit -> Format.dprintf "()" + | Types.Named(_, mty) -> dmodtype mty + in + Format.dprintf + "Modules do not match:@ @[%t@]@;<1 -2>\ + is not included in@ @[%t@]%t" + (dmodtype mty) e (more ()) + + + let incompatible = function + | Unit -> + Format.dprintf + "The functor was expected to be applicative at this position" + | Named _ | Anonymous -> + Format.dprintf + "The functor was expected to be generative at this position" + + end + + let subcase sub ~expansion_token env (pos, diff) = + Location.msg "%a%a%a%a@[%t@]%a" + Format.pp_print_tab () + Format.pp_open_tbox () + Diffing.prefix (pos, Diffing.classify diff) + Format.pp_set_tab () + (Printtyp.wrap_printing_env env ~error:true + (fun () -> sub ~expansion_token env diff) + ) + Format.pp_close_tbox () + + let onlycase sub ~expansion_token env (_, diff) = + Location.msg "%a@[%t@]" + Format.pp_print_tab () + (Printtyp.wrap_printing_env env ~error:true + (fun () -> sub ~expansion_token env diff) + ) + + let params sub ~expansion_token env l = + let rec aux subcases = function + | [] -> subcases + | (_, Diffing.Keep _) as a :: q -> + aux (subcase sub ~expansion_token env a :: subcases) q + | a :: q -> + List.fold_left (fun acc x -> + (subcase sub ~expansion_token:false env x) :: acc + ) + (subcase sub ~expansion_token env a :: subcases) + q + in + match l with + | [a] -> [onlycase sub ~expansion_token env a] + | l -> aux [] l +end + + +(** Construct a linear presentation of the error tree *) + +open Err + +(* Context helper functions *) +let with_context ?loc ctx printer diff = + Location.msg ?loc "%a%a" Context.pp (List.rev ctx) + printer diff + +let dwith_context ?loc ctx printer = + Location.msg ?loc "%a%t" Context.pp (List.rev ctx) printer + +let dwith_context_and_elision ?loc ctx printer diff = + if is_big (diff.got,diff.expected) then + Location.msg ?loc "..." + else + dwith_context ?loc ctx (printer diff) + +(* Merge sub msgs into one printer *) +let coalesce msgs = + match List.rev msgs with + | [] -> ignore + | before -> + let ctx ppf = + Format.pp_print_list ~pp_sep:space + (fun ppf x -> x.Location.txt ppf) + ppf before in + ctx + +let subcase_list l ppf = match l with + | [] -> () + | _ :: _ -> + Format.fprintf ppf "@;<1 -2>@[%a@]" + (Format.pp_print_list ~pp_sep:space + (fun ppf f -> f.Location.txt ppf) + ) + (List.rev l) + +(* Printers for leaves *) +let core env id x = + match x with + | Err.Value_descriptions diff -> + Format.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a%t@]" + "Values do not match" + !Oprint.out_sig_item + (Printtyp.tree_of_value_description id diff.got) + "is not included in" + !Oprint.out_sig_item + (Printtyp.tree_of_value_description id diff.expected) + (Includecore.report_value_mismatch + "the first" "the second" env) diff.symptom + show_locs (diff.got.val_loc, diff.expected.val_loc) + Printtyp.Conflicts.print_explanations + | Err.Type_declarations diff -> + Format.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]%a%a%t@]" + "Type declarations do not match" + !Oprint.out_sig_item + (Printtyp.tree_of_type_declaration id diff.got Trec_first) + "is not included in" + !Oprint.out_sig_item + (Printtyp.tree_of_type_declaration id diff.expected Trec_first) + (Includecore.report_type_mismatch + "the first" "the second" "declaration" env) diff.symptom + show_locs (diff.got.type_loc, diff.expected.type_loc) + Printtyp.Conflicts.print_explanations + | Err.Extension_constructors diff -> + Format.dprintf "@[@[%s:@;<1 2>%a@ %s@;<1 2>%a@]@ %a%a%t@]" + "Extension declarations do not match" + !Oprint.out_sig_item + (Printtyp.tree_of_extension_constructor id diff.got Text_first) + "is not included in" + !Oprint.out_sig_item + (Printtyp.tree_of_extension_constructor id diff.expected Text_first) + (Includecore.report_extension_constructor_mismatch + "the first" "the second" "declaration" env) diff.symptom + show_locs (diff.got.ext_loc, diff.expected.ext_loc) + Printtyp.Conflicts.print_explanations + | Err.Class_type_declarations diff -> + Format.dprintf + "@[Class type declarations do not match:@ \ + %a@;<1 -2>does not match@ %a@]@ %a%t" + !Oprint.out_sig_item + (Printtyp.tree_of_cltype_declaration id diff.got Trec_first) + !Oprint.out_sig_item + (Printtyp.tree_of_cltype_declaration id diff.expected Trec_first) + (Includeclass.report_error Type_scheme) diff.symptom + Printtyp.Conflicts.print_explanations + | Err.Class_declarations {got;expected;symptom} -> + let t1 = Printtyp.tree_of_class_declaration id got Trec_first in + let t2 = Printtyp.tree_of_class_declaration id expected Trec_first in + Format.dprintf + "@[Class declarations do not match:@ \ + %a@;<1 -2>does not match@ %a@]@ %a%t" + !Oprint.out_sig_item t1 + !Oprint.out_sig_item t2 + (Includeclass.report_error Type_scheme) symptom + Printtyp.Conflicts.print_explanations + +let missing_field ppf item = + let id, loc, kind = Includemod.item_ident_name item in + Format.fprintf ppf "The %s `%a' is required but not provided%a" + (Includemod.kind_of_field_desc kind) Printtyp.ident id + (show_loc "Expected declaration") loc + +let module_types {Err.got=mty1; expected=mty2} = + Format.dprintf + "@[Modules do not match:@ \ + %a@;<1 -2>is not included in@ %a@]" + !Oprint.out_module_type (Printtyp.tree_of_modtype mty1) + !Oprint.out_module_type (Printtyp.tree_of_modtype mty2) + +let eq_module_types {Err.got=mty1; expected=mty2} = + Format.dprintf + "@[Module types do not match:@ \ + %a@;<1 -2>is not equal to@ %a@]" + !Oprint.out_module_type (Printtyp.tree_of_modtype mty1) + !Oprint.out_module_type (Printtyp.tree_of_modtype mty2) + +let module_type_declarations id {Err.got=d1 ; expected=d2} = + Format.dprintf + "@[Module type declarations do not match:@ \ + %a@;<1 -2>does not match@ %a@]" + !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d1) + !Oprint.out_sig_item (Printtyp.tree_of_modtype_declaration id d2) + +let interface_mismatch ppf (diff: _ Err.diff) = + Format.fprintf ppf + "The implementation %s@ does not match the interface %s:@ " + diff.got diff.expected + +let core_module_type_symptom (x:Err.core_module_type_symptom) = + match x with + | Not_an_alias | Not_an_identifier | Abstract_module_type + | Incompatible_aliases -> + if Printtyp.Conflicts.exists () then + Some Printtyp.Conflicts.print_explanations + else None + | Unbound_module_path path -> + Some(Format.dprintf "Unbound module %a" Printtyp.path path) + +(* Construct a linearized error message from the error tree *) + +let rec module_type ~expansion_token ~eqmode ~env ~before ~ctx diff = + match diff.symptom with + | Invalid_module_alias _ (* the difference is non-informative here *) + | After_alias_expansion _ (* we print only the expanded module types *) -> + module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx + diff.symptom + | Functor Params d -> (* We jump directly to the functor param error *) + functor_params ~expansion_token ~env ~before ~ctx d + | _ -> + let inner = if eqmode then eq_module_types else module_types in + let next = + match diff.symptom with + | Mt_core _ -> + (* In those cases, the refined error messages for the current error + will at most add some minor comments on the current error. + It is thus better to avoid eliding the current error message. + *) + dwith_context ctx (inner diff) + | _ -> dwith_context_and_elision ctx inner diff + in + let before = next :: before in + module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx + diff.symptom + +and module_type_symptom ~eqmode ~expansion_token ~env ~before ~ctx = function + | Mt_core core -> + begin match core_module_type_symptom core with + | None -> before + | Some msg -> Location.msg "%t" msg :: before + end + | Signature s -> signature ~expansion_token ~env ~before ~ctx s + | Functor f -> functor_symptom ~expansion_token ~env ~before ~ctx f + | After_alias_expansion diff -> + module_type ~eqmode ~expansion_token ~env ~before ~ctx diff + | Invalid_module_alias path -> + let printer = + Format.dprintf "Module %a cannot be aliased" Printtyp.path path + in + dwith_context ctx printer :: before + +and functor_params ~expansion_token ~env ~before ~ctx {got;expected;_} = + let d = Functor_suberror.Inclusion.patch env got expected in + let actual = Functor_suberror.Inclusion.got d in + let expected = Functor_suberror.expected d in + let main = + Format.dprintf + "@[Modules do not match:@ \ + @[functor@ %t@ -> ...@]@;<1 -2>is not included in@ \ + @[functor@ %t@ -> ...@]@]" + actual expected + in + let msgs = dwith_context ctx main :: before in + let functor_suberrors = + if expansion_token then + Functor_suberror.params functor_arg_diff ~expansion_token env d + else [] + in + functor_suberrors @ msgs + +and functor_symptom ~expansion_token ~env ~before ~ctx = function + | Result res -> + module_type ~expansion_token ~eqmode:false ~env ~before ~ctx res + | Params d -> functor_params ~expansion_token ~env ~before ~ctx d + +and signature ~expansion_token ~env:_ ~before ~ctx sgs = + Printtyp.wrap_printing_env ~error:true sgs.env (fun () -> + match sgs.missings, sgs.incompatibles with + | a :: l , _ -> + if expansion_token then + with_context ctx missing_field a + :: List.map (Location.msg "%a" missing_field) l + @ before + else + before + | [], a :: _ -> sigitem ~expansion_token ~env:sgs.env ~before ~ctx a + | [], [] -> assert false + ) +and sigitem ~expansion_token ~env ~before ~ctx (name,s) = match s with + | Core c -> + dwith_context ctx (core env name c) :: before + | Module_type diff -> + module_type ~expansion_token ~eqmode:false ~env ~before + ~ctx:(Context.Module name :: ctx) diff + | Module_type_declaration diff -> + module_type_decl ~expansion_token ~env ~before ~ctx name diff +and module_type_decl ~expansion_token ~env ~before ~ctx id diff = + let next = + dwith_context_and_elision ctx (module_type_declarations id) diff in + let before = next :: before in + match diff.symptom with + | Not_less_than mts -> + let before = + Location.msg "The first module type is not included in the second" + :: before + in + module_type ~expansion_token ~eqmode:true ~before ~env + ~ctx:(Context.Modtype id :: ctx) mts + | Not_greater_than mts -> + let before = + Location.msg "The second module type is not included in the first" + :: before in + module_type ~expansion_token ~eqmode:true ~before ~env + ~ctx:(Context.Modtype id :: ctx) mts + | Incomparable mts -> + module_type ~expansion_token ~eqmode:true ~env ~before + ~ctx:(Context.Modtype id :: ctx) mts.less_than + | Illegal_permutation c -> + begin match diff.got.Types.mtd_type with + | None -> assert false + | Some mty -> + with_context (Modtype id::ctx) + (Illegal_permutation.pp Context.alt_pp env) (mty,c) + :: before + end + +and functor_arg_diff ~expansion_token env (patch: _ Diffing.change) = + match patch with + | Insert mty -> Functor_suberror.Inclusion.insert mty + | Delete mty -> Functor_suberror.Inclusion.delete mty + | Keep (x, y, _) -> Functor_suberror.Inclusion.ok x y + | Change (_, _, Err.Incompatible_params (i,_)) -> + Functor_suberror.Inclusion.incompatible i + | Change (g, e, Err.Mismatch mty_diff) -> + let more () = + subcase_list @@ + module_type_symptom ~eqmode:false ~expansion_token ~env ~before:[] + ~ctx:[] mty_diff.symptom + in + Functor_suberror.Inclusion.diff g e more + +let functor_app_diff ~expansion_token env (patch: _ Diffing.change) = + match patch with + | Insert mty -> Functor_suberror.App.insert mty + | Delete mty -> Functor_suberror.App.delete mty + | Keep (x, y, _) -> Functor_suberror.App.ok x y + | Change (_, _, Err.Incompatible_params (i,_)) -> + Functor_suberror.App.incompatible i + | Change (g, e, Err.Mismatch mty_diff) -> + let more () = + subcase_list @@ + module_type_symptom ~eqmode:false ~expansion_token ~env ~before:[] + ~ctx:[] mty_diff.symptom + in + Functor_suberror.App.diff g e more + +let module_type_subst ~env id diff = + match diff.symptom with + | Not_less_than mts -> + module_type ~expansion_token:true ~eqmode:true ~before:[] ~env + ~ctx:[Modtype id] mts + | Not_greater_than mts -> + module_type ~expansion_token:true ~eqmode:true ~before:[] ~env + ~ctx:[Modtype id] mts + | Incomparable mts -> + module_type ~expansion_token:true ~eqmode:true ~env ~before:[] + ~ctx:[Modtype id] mts.less_than + | Illegal_permutation c -> + let mty = diff.got in + let main = + with_context [Modtype id] + (Illegal_permutation.pp Context.alt_pp env) (mty,c) in + [main] + +let all env = function + | In_Compilation_unit diff -> + let first = Location.msg "%a" interface_mismatch diff in + signature ~expansion_token:true ~env ~before:[first] ~ctx:[] diff.symptom + | In_Type_declaration (id,reason) -> + [Location.msg "%t" (core env id reason)] + | In_Module_type diff -> + module_type ~expansion_token:true ~eqmode:false ~before:[] ~env ~ctx:[] + diff + | In_Module_type_substitution (id,diff) -> + module_type_subst ~env id diff + | In_Signature diff -> + signature ~expansion_token:true ~before:[] ~env ~ctx:[] diff + | In_Include_functor_signature diff -> + signature ~expansion_token:true ~before:[] ~env ~ctx:[] diff + | In_Expansion cmts -> + match core_module_type_symptom cmts with + | None -> assert false + | Some main -> [Location.msg "%t" main] + +(* General error reporting *) + +let err_msgs (env, err) = + Printtyp.Conflicts.reset(); + Printtyp.wrap_printing_env ~error:true env + (fun () -> coalesce @@ all env err) + +let report_error err = + let main = err_msgs err in + Location.errorf ~loc:Location.(in_file !input_name) "%t" main + +let report_apply_error ~loc env (lid_app, mty_f, args) = + let may_print_app ppf = match lid_app with + | None -> () + | Some lid -> Format.fprintf ppf "%a " Printtyp.longident lid + in + let d = Functor_suberror.App.patch env ~f:mty_f ~args in + match d with + (* We specialize the one change and one argument case to remove the + presentation of the functor arguments *) + | [ _, Change (_, _, Err.Incompatible_params (i,_)) ] -> + Location.errorf ~loc "%t" (Functor_suberror.App.incompatible i) + | [ _, Change (g, e, Err.Mismatch mty_diff) ] -> + let more () = + subcase_list @@ + module_type_symptom ~eqmode:false ~expansion_token:true ~env ~before:[] + ~ctx:[] mty_diff.symptom + in + Location.errorf ~loc "%t" (Functor_suberror.App.single_diff g e more) + | _ -> + let actual = Functor_suberror.App.got d in + let expected = Functor_suberror.expected d in + let sub = + List.rev @@ + Functor_suberror.params functor_app_diff env ~expansion_token:true d + in + Location.errorf ~loc ~sub + "@[The functor application %tis ill-typed.@ \ + These arguments:@;<1 2>\ + @[%t@]@ do not match these parameters:@;<1 2>@[functor@ %t@ -> ...@]@]" + may_print_app + actual expected + +let register () = + Location.register_error_of_exn + (function + | Includemod.Error err -> Some (report_error err) + | Includemod.Apply_error {loc; env; lid_app; mty_f; args} -> + Some (Printtyp.wrap_printing_env env ~error:true (fun () -> + report_apply_error ~loc env (lid_app, mty_f, args)) + ) + | _ -> None + ) diff --git a/ocaml/toplevel/opttopmain.mli b/ocaml/typing/includemod_errorprinter.mli similarity index 81% rename from ocaml/toplevel/opttopmain.mli rename to ocaml/typing/includemod_errorprinter.mli index 8be7680ee98..12ea2169b0a 100644 --- a/ocaml/toplevel/opttopmain.mli +++ b/ocaml/typing/includemod_errorprinter.mli @@ -2,9 +2,9 @@ (* *) (* OCaml *) (* *) -(* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) +(* Florian Angeletti, projet Cambium, Inria Paris *) (* *) -(* Copyright 1996 Institut National de Recherche en Informatique et *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) @@ -13,6 +13,5 @@ (* *) (**************************************************************************) -(* Start the [ocaml] toplevel loop *) - -val main: unit -> int +val err_msgs: Includemod.explanation -> Format.formatter -> unit +val register: unit -> unit diff --git a/ocaml/typing/mtype.ml b/ocaml/typing/mtype.ml index 0a7e26804a4..7145f871ce5 100644 --- a/ocaml/typing/mtype.ml +++ b/ocaml/typing/mtype.ml @@ -46,6 +46,9 @@ let rec strengthen_lazy ~aliasable env mty p = MtyL_signature(strengthen_lazy_sig ~aliasable env sg p) | MtyL_functor(Named (Some param, arg), res) when !Clflags.applicative_functors -> + let env = + Env.add_module_lazy ~update_summary:false param Mp_present arg env + in MtyL_functor(Named (Some param, arg), strengthen_lazy ~aliasable:false env res (Papply(p, Pident param))) | MtyL_functor(Named (None, arg), res) @@ -62,9 +65,8 @@ and strengthen_lazy_sig' ~aliasable env sg p = [] -> [] | (SigL_value(_, _, _) as sigelt) :: rem -> sigelt :: strengthen_lazy_sig' ~aliasable env rem p - | SigL_type(id, {type_kind=Type_abstract}, _, _) :: - (SigL_type(id', {type_private=Private}, _, _) :: _ as rem) - when Ident.name id = Ident.name id' ^ "#row" -> + | SigL_type(id, {type_kind=Type_abstract}, _, _) :: rem + when Btype.is_row_name (Ident.name id) -> strengthen_lazy_sig' ~aliasable env rem p | SigL_type(id, decl, rs, vis) :: rem -> let newdecl = @@ -303,11 +305,14 @@ let enrich_typedecl env p id decl = match decl.type_manifest with Some _ -> decl | None -> - try - let orig_decl = Env.find_type p env in + match Env.find_type p env with + | exception Not_found -> decl + (* Type which was not present in the signature, so we don't have + anything to do. *) + | orig_decl -> if decl.type_arity <> orig_decl.type_arity then decl - else + else begin let orig_ty = Ctype.reify_univars env (Btype.newgenty(Tconstr(p, orig_decl.type_params, ref Mnil))) @@ -317,19 +322,18 @@ let enrich_typedecl env p id decl = (Btype.newgenty(Tconstr(Pident id, decl.type_params, ref Mnil))) in let env = Env.add_type ~check:false id decl env in - Ctype.mcomp env orig_ty new_ty; - let orig_ty = - Btype.newgenty(Tconstr(p, decl.type_params, ref Mnil)) - in - {decl with type_manifest = Some orig_ty} - with Not_found | Ctype.Unify _ -> - (* - Not_found: type which was not present in the signature, so we don't - have anything to do. - - Unify: the current declaration is not compatible with the one we - got from the signature. We should just fail now, but then, we could - also have failed if the arities of the two decls were different, - which we didn't. *) - decl + match Ctype.mcomp env orig_ty new_ty with + | exception Ctype.Incompatible -> decl + (* The current declaration is not compatible with the one we got + from the signature. We should just fail now, but then, we could + also have failed if the arities of the two decls were + different, which we didn't. *) + | () -> + let orig_ty = + Btype.newgenty(Tconstr(p, decl.type_params, ref Mnil)) + in + {decl with type_manifest = Some orig_ty} + end let rec enrich_modtype env p mty = match mty with @@ -584,9 +588,9 @@ let scrape_for_type_of ~remove_aliases env mty = let lower_nongen nglev mty = let open Btype in let it_type_expr it ty = - let ty = repr ty in - match ty with - {desc=Tvar _; level} -> + match get_desc ty with + Tvar _ -> + let level = get_level ty in if level < generic_level && level > nglev then set_level ty nglev | _ -> type_iterators.it_type_expr it ty diff --git a/ocaml/typing/oprint.ml b/ocaml/typing/oprint.ml index d6520f98732..121bb77c416 100644 --- a/ocaml/typing/oprint.ml +++ b/ocaml/typing/oprint.ml @@ -138,6 +138,16 @@ let escape_string s = Bytes.to_string s' end +let rec print_typlist print_elem sep ppf = + function + [] -> () + | [ty] -> print_elem ppf ty + | ty :: tyl -> + print_elem ppf ty; + pp_print_string ppf sep; + pp_print_space ppf (); + print_typlist print_elem sep ppf tyl + let print_out_string ppf s = let not_escaped = @@ -188,6 +198,7 @@ let print_out_value ppf tree = | Oval_string (s, maxlen, kind) -> begin try let len = String.length s in + let maxlen = max maxlen 8 in (* always show a little prefix *) let s = if len > maxlen then String.sub s 0 maxlen else s in begin match kind with | Ostr_bytes -> fprintf ppf "Bytes.of_string %S" s @@ -369,15 +380,15 @@ and print_out_type_3 mode ppf = | Otyp_abstract | Otyp_open | Otyp_sum _ | Otyp_manifest (_, _) -> () | Otyp_record lbls -> print_record_decl ppf lbls - | Otyp_module (p, n, tyl) -> + | Otyp_module (p, fl) -> fprintf ppf "@[<1>(module %a" print_ident p; let first = ref true in - List.iter2 - (fun s t -> + List.iter + (fun (s, t) -> let sep = if !first then (first := false; "with") else "and" in fprintf ppf " %s type %s = %a" sep s print_out_type t ) - n tyl; + fl; fprintf ppf ")@]" | Otyp_attribute (t, attr) -> fprintf ppf "@[<1>(%a [@@%s])@]" @@ -413,15 +424,6 @@ and print_row_field ppf (l, opt_amp, tyl) = in fprintf ppf "@[`%s%t%a@]" l pr_of (print_typlist print_out_type " &") tyl -and print_typlist print_elem sep ppf = - function - [] -> () - | [ty] -> print_elem ppf ty - | ty :: tyl -> - print_elem ppf ty; - pp_print_string ppf sep; - pp_print_space ppf (); - print_typlist print_elem sep ppf tyl and print_typargs ppf = function [] -> () @@ -434,14 +436,23 @@ and print_typargs ppf = pp_close_box ppf (); pp_print_space ppf () and print_out_label ppf (name, mut_or_gbl, arg) = - let flag = + if Clflags.Extension.is_enabled Local then + let flag = + match mut_or_gbl with + | Ogom_mutable -> "mutable " + | Ogom_global -> "global_ " + | Ogom_nonlocal -> "nonlocal_ " + | Ogom_immutable -> "" + in + fprintf ppf "@[<2>%s%s :@ %a@];" flag name print_out_type arg + else match mut_or_gbl with - | Ogom_mutable -> "mutable " - | Ogom_global -> "global_ " - | Ogom_nonlocal -> "nonlocal_ " - | Ogom_immutable -> "" - in - fprintf ppf "@[<2>%s%s :@ %a@];" flag name print_out_type arg + | Ogom_mutable -> fprintf ppf "@[mutable %s :@ %a@];" name print_out_type arg + | Ogom_immutable -> fprintf ppf "@[%s :@ %a@];" name print_out_type arg + | Ogom_global -> fprintf ppf "@[%s :@ %a@];" name print_out_type + (Otyp_attribute (arg, {oattr_name="global"})) + | Ogom_nonlocal -> fprintf ppf "@[%s :@ %a@];" name print_out_type + (Otyp_attribute (arg, {oattr_name="nonlocal"})) let out_label = ref print_out_label @@ -512,6 +523,8 @@ let out_module_type = ref (fun _ -> failwith "Oprint.out_module_type") let out_sig_item = ref (fun _ -> failwith "Oprint.out_sig_item") let out_signature = ref (fun _ -> failwith "Oprint.out_signature") let out_type_extension = ref (fun _ -> failwith "Oprint.out_type_extension") +let out_functor_parameters = + ref (fun _ -> failwith "Oprint.out_functor_parameters") (* For anonymous functor arguments, the logic to choose between the long-form @@ -536,50 +549,66 @@ let out_type_extension = ref (fun _ -> failwith "Oprint.out_type_extension") (* take a module type that may be a functor type, and return the longest prefix list of arguments that should be printed in long form. *) -let collect_functor_arguments mty = - let rec collect_args acc = function - | Omty_functor (param, mty_res) -> - collect_args (param :: acc) mty_res - | non_functor -> (acc, non_functor) - in + +let rec collect_functor_args acc = function + | Omty_functor (param, mty_res) -> + collect_functor_args (param :: acc) mty_res + | non_functor -> (acc, non_functor) +let collect_functor_args mty = + let l, rest = collect_functor_args [] mty in + List.rev l, rest + +let constructor_of_extension_constructor + (ext : out_extension_constructor) : out_constructor += + { + ocstr_name = ext.oext_name; + ocstr_args = ext.oext_args; + ocstr_return_type = ext.oext_ret_type; + } + +let split_anon_functor_arguments params = let rec uncollect_anonymous_suffix acc rest = match acc with - | Some (None, mty_arg) :: acc -> - uncollect_anonymous_suffix acc - (Omty_functor (Some (None, mty_arg), rest)) - | _ :: _ | [] -> - (acc, rest) + | Some (None, mty_arg) :: acc -> + uncollect_anonymous_suffix acc + (Some (None, mty_arg) :: rest) + | _ :: _ | [] -> + (acc, rest) in - let (acc, non_functor) = collect_args [] mty in - let (acc, rest) = uncollect_anonymous_suffix acc non_functor in + let (acc, rest) = uncollect_anonymous_suffix (List.rev params) [] in (List.rev acc, rest) let rec print_out_module_type ppf mty = print_out_functor ppf mty -and print_out_functor ppf = function - | Omty_functor _ as t -> - let rec print_functor ppf = function - | Omty_functor (Some (None, mty_arg), mty_res) -> - fprintf ppf "%a ->@ %a" - print_simple_out_module_type mty_arg - print_functor mty_res - | Omty_functor _ as non_anonymous_functor -> - let (args, rest) = collect_functor_arguments non_anonymous_functor in - let print_arg ppf = function - | None -> - fprintf ppf "()" - | Some (param, mty) -> - fprintf ppf "(%s : %a)" - (Option.value param ~default:"_") - print_out_module_type mty - in - fprintf ppf "@[<2>functor@ %a@]@ ->@ %a" - (pp_print_list ~pp_sep:pp_print_space print_arg) args - print_functor rest - | non_functor -> - print_simple_out_module_type ppf non_functor - in - fprintf ppf "@[<2>%a@]" print_functor t - | t -> print_simple_out_module_type ppf t + +and print_out_functor_parameters ppf l = + let print_nonanon_arg ppf = function + | None -> + fprintf ppf "()" + | Some (param, mty) -> + fprintf ppf "(%s : %a)" + (Option.value param ~default:"_") + print_out_module_type mty + in + let rec print_args ppf = function + | [] -> () + | Some (None, mty_arg) :: l -> + fprintf ppf "%a ->@ %a" + print_simple_out_module_type mty_arg + print_args l + | _ :: _ as non_anonymous_functor -> + let args, anons = split_anon_functor_arguments non_anonymous_functor in + fprintf ppf "@[<2>functor@ %a@]@ ->@ %a" + (pp_print_list ~pp_sep:pp_print_space print_nonanon_arg) args + print_args anons + in + print_args ppf l + +and print_out_functor ppf t = + let params, non_functor = collect_functor_args t in + fprintf ppf "@[<2>%a%a@]" + print_out_functor_parameters params + print_simple_out_module_type non_functor and print_simple_out_module_type ppf = function Omty_abstract -> () @@ -603,13 +632,13 @@ and print_out_signature ppf = match items with Osig_typext(ext, Oext_next) :: items -> gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) + (constructor_of_extension_constructor ext :: acc) items | _ -> (List.rev acc, items) in let exts, items = gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] + [constructor_of_extension_constructor ext] items in let te = @@ -635,7 +664,7 @@ and print_out_sig_item ppf = name !out_class_type clt | Osig_typext (ext, Oext_exception) -> fprintf ppf "@[<2>exception %a@]" - print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type) + print_out_constr (constructor_of_extension_constructor ext) | Osig_typext (ext, _es) -> print_out_extension_constructor ppf ext | Osig_modtype (name, Omty_abstract) -> @@ -724,12 +753,12 @@ and print_out_type_decl kwd ppf td = print_private td.otype_private print_record_decl lbls | Otyp_sum constrs -> - let variants fmt constrs = + let variants fmt constrs = if constrs = [] then fprintf fmt "|" else fprintf fmt "%a" (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) constrs in - fprintf ppf " =%a@;<1 2>%a" - print_private td.otype_private variants constrs + fprintf ppf " =%a@;<1 2>%a" + print_private td.otype_private variants constrs | Otyp_open -> fprintf ppf " =%a .." print_private td.otype_private @@ -745,29 +774,58 @@ and print_out_type_decl kwd ppf td = print_immediate print_unboxed -and print_out_constr ppf (name, tyl,ret_type_opt) = +and print_simple_out_gf_type ppf (ty, gf) = + let locals_enabled = Clflags.Extension.is_enabled Local in + match gf with + | Ogf_global -> + if locals_enabled then begin + pp_print_string ppf "global_"; + pp_print_space ppf (); + print_simple_out_type ppf ty + end else begin + print_out_type ppf (Otyp_attribute (ty, {oattr_name="global"})) + end + | Ogf_nonlocal -> + if locals_enabled then begin + pp_print_string ppf "nonlocal_"; + pp_print_space ppf (); + print_simple_out_type ppf ty + end else begin + print_out_type ppf (Otyp_attribute (ty, {oattr_name="nonlocal"})) + end + | Ogf_unrestricted -> + print_simple_out_type ppf ty + +and print_out_constr_args ppf tyl = + print_typlist print_simple_out_gf_type " *" ppf tyl + +and print_out_constr ppf constr = + let { + ocstr_name = name; + ocstr_args = tyl; + ocstr_return_type = return_type; + } = constr in let name = match name with | "::" -> "(::)" (* #7200 *) | s -> s in - match ret_type_opt with + match return_type with | None -> begin match tyl with | [] -> pp_print_string ppf name | _ -> fprintf ppf "@[<2>%s of@ %a@]" name - (print_typlist print_simple_out_type " *") tyl + print_out_constr_args tyl end | Some ret_type -> begin match tyl with | [] -> - fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type ret_type + fprintf ppf "@[<2>%s :@ %a@]" name print_simple_out_type ret_type | _ -> fprintf ppf "@[<2>%s :@ %a -> %a@]" name - (print_typlist print_simple_out_type " *") - tyl print_simple_out_type ret_type + print_out_constr_args tyl print_simple_out_type ret_type end and print_out_extension_constructor ppf ext = @@ -788,7 +846,8 @@ and print_out_extension_constructor ppf ext = fprintf ppf "@[type %t +=%s@;<1 2>%a@]" print_extended_type (if ext.oext_private = Asttypes.Private then " private" else "") - print_out_constr (ext.oext_name, ext.oext_args, ext.oext_ret_type) + print_out_constr + (constructor_of_extension_constructor ext) and print_out_type_extension ppf te = let print_extended_type ppf = @@ -808,13 +867,15 @@ and print_out_type_extension ppf te = print_extended_type (if te.otyext_private = Asttypes.Private then " private" else "") (print_list print_out_constr (fun ppf -> fprintf ppf "@ | ")) - te.otyext_constructors + te.otyext_constructors let out_constr = ref print_out_constr +let out_constr_args = ref print_out_constr_args let _ = out_module_type := print_out_module_type let _ = out_signature := print_out_signature let _ = out_sig_item := print_out_sig_item let _ = out_type_extension := print_out_type_extension +let _ = out_functor_parameters := print_out_functor_parameters (* Phrases *) @@ -837,13 +898,13 @@ let rec print_items ppf = match items with (Osig_typext(ext, Oext_next), None) :: items -> gather_extensions - ((ext.oext_name, ext.oext_args, ext.oext_ret_type) :: acc) + (constructor_of_extension_constructor ext :: acc) items | _ -> (List.rev acc, items) in let exts, items = gather_extensions - [(ext.oext_name, ext.oext_args, ext.oext_ret_type)] + [constructor_of_extension_constructor ext] items in let te = diff --git a/ocaml/typing/oprint.mli b/ocaml/typing/oprint.mli index d42d0d12b5f..b977d9476c4 100644 --- a/ocaml/typing/oprint.mli +++ b/ocaml/typing/oprint.mli @@ -20,12 +20,17 @@ val out_ident : (formatter -> out_ident -> unit) ref val out_value : (formatter -> out_value -> unit) ref val out_label : (formatter -> string * out_mutable_or_global * out_type -> unit) ref val out_type : (formatter -> out_type -> unit) ref -val out_constr : - (formatter -> string * out_type list * out_type option -> unit) ref +val out_constr : (formatter -> out_constructor -> unit) ref +val out_constr_args : + (formatter -> ((out_type * out_global) list) -> unit) ref val out_class_type : (formatter -> out_class_type -> unit) ref val out_module_type : (formatter -> out_module_type -> unit) ref val out_sig_item : (formatter -> out_sig_item -> unit) ref val out_signature : (formatter -> out_sig_item list -> unit) ref +val out_functor_parameters : + (formatter -> + (string option * Outcometree.out_module_type) option list -> unit) + ref val out_type_extension : (formatter -> out_type_extension -> unit) ref val out_phrase : (formatter -> out_phrase -> unit) ref diff --git a/ocaml/typing/outcometree.mli b/ocaml/typing/outcometree.mli index 26292a8ae5f..895295964e6 100644 --- a/ocaml/typing/outcometree.mli +++ b/ocaml/typing/outcometree.mli @@ -64,6 +64,11 @@ type out_mutable_or_global = | Ogom_nonlocal | Ogom_immutable +type out_global = + | Ogf_global + | Ogf_nonlocal + | Ogf_unrestricted + type out_type = | Otyp_abstract | Otyp_open @@ -75,15 +80,21 @@ type out_type = | Otyp_object of (string * out_type) list * bool option | Otyp_record of (string * out_mutable_or_global * out_type) list | Otyp_stuff of string - | Otyp_sum of (string * out_type list * out_type option) list + | Otyp_sum of out_constructor list | Otyp_tuple of out_type list | Otyp_var of bool * string | Otyp_variant of bool * out_variant * bool * (string list) option | Otyp_poly of string list * out_type - | Otyp_module of out_ident * string list * out_type list + | Otyp_module of out_ident * (string * out_type) list | Otyp_attribute of out_type * out_attribute +and out_constructor = { + ocstr_name: string; + ocstr_args: (out_type * out_global) list; + ocstr_return_type: out_type option; +} + and out_variant = | Ovar_fields of (string * bool * out_type list) list | Ovar_typ of out_type @@ -133,13 +144,13 @@ and out_extension_constructor = { oext_name: string; oext_type_name: string; oext_type_params: string list; - oext_args: out_type list; + oext_args: (out_type * out_global) list; oext_ret_type: out_type option; oext_private: Asttypes.private_flag } and out_type_extension = { otyext_name: string; otyext_params: string list; - otyext_constructors: (string * out_type list * out_type option) list; + otyext_constructors: out_constructor list; otyext_private: Asttypes.private_flag } and out_val_decl = { oval_name: string; diff --git a/ocaml/typing/parmatch.ml b/ocaml/typing/parmatch.ml index 5be766c9725..1207847f491 100644 --- a/ocaml/typing/parmatch.ml +++ b/ocaml/typing/parmatch.ml @@ -19,7 +19,6 @@ open Misc open Asttypes open Types open Typedtree -module Value_mode = Btype.Value_mode (*************************************) (* Utilities for building patterns *) @@ -231,7 +230,7 @@ let first_column simplified_matrix = *) -let is_absent tag row = Btype.row_field tag !row = Rabsent +let is_absent tag row = row_field_repr (get_row_field tag !row) = Rabsent let is_absent_pat d = match d.pat_desc with @@ -290,7 +289,7 @@ module Compat | _,Tpat_or (q1,q2,_) -> (compat p q1 || compat p q2) (* Constructors, with special case for extension *) - | Tpat_construct (_, c1,ps1), Tpat_construct (_, c2,ps2) -> + | Tpat_construct (_, c1, ps1, _), Tpat_construct (_, c2, ps2, _) -> Constr.equal c1 c2 && compats ps1 ps2 (* More standard stuff *) | Tpat_variant(l1,op1, _), Tpat_variant(l2,op2,_) -> @@ -339,12 +338,12 @@ exception Empty (* Empty pattern *) (* May need a clean copy, cf. PR#4745 *) let clean_copy ty = - if ty.level = Btype.generic_level then ty + if get_level ty = Btype.generic_level then ty else Subst.type_expr Subst.identity ty let get_constructor_type_path ty tenv = - let ty = Ctype.repr (Ctype.expand_head tenv (clean_copy ty)) in - match ty.desc with + let ty = Ctype.expand_head tenv (clean_copy ty) in + match get_desc ty with | Tconstr (path,_,_) -> path | _ -> assert false @@ -506,10 +505,10 @@ let do_set_args ~erase_mutable q r = match q with omegas args, closed)) q.pat_type q.pat_mode q.pat_env:: rest -| {pat_desc = Tpat_construct (lid, c,omegas)} -> +| {pat_desc = Tpat_construct (lid, c, omegas, _)} -> let args,rest = read_args omegas r in make_pat - (Tpat_construct (lid, c,args)) + (Tpat_construct (lid, c, args, None)) q.pat_type q.pat_mode q.pat_env:: rest | {pat_desc = Tpat_variant (l, omega, row)} -> @@ -719,23 +718,26 @@ let mark_partial = ) let close_variant env row = - let row = Btype.row_repr row in - let nm = + let Row {fields; more; name=orig_name; closed; fixed} = row_repr row in + let name, static = List.fold_left - (fun nm (_tag,f) -> - match Btype.row_field_repr f with - | Reither(_, _, false, e) -> - (* m=false means that this tag is not explicitly matched *) - Btype.set_row_field e Rabsent; - None - | Rabsent | Reither (_, _, true, _) | Rpresent _ -> nm) - row.row_name row.row_fields in - if not row.row_closed || nm != row.row_name then begin + (fun (nm, static) (_tag,f) -> + match row_field_repr f with + | Reither(_, _, false) -> + (* fixed=false means that this tag is not explicitly matched *) + link_row_field_ext ~inside:f rf_absent; + (None, static) + | Reither (_, _, true) -> (nm, false) + | Rabsent | Rpresent _ -> (nm, static)) + (orig_name, true) fields in + if not closed || name != orig_name then begin + let more' = if static then Btype.newgenty Tnil else Btype.newgenvar () in (* this unification cannot fail *) - Ctype.unify env row.row_more + Ctype.unify env more (Btype.newgenty - (Tvariant {row with row_fields = []; row_more = Btype.newgenvar(); - row_closed = true; row_name = nm})) + (Tvariant + (create_row ~fields:[] ~more:more' + ~closed:true ~name ~fixed))) end (* @@ -761,22 +763,22 @@ let full_match closing env = match env with env in let row = type_row () in - if closing && not (Btype.row_fixed row) then + if closing && not (Btype.has_fixed_explanation row) then (* closing=true, we are considering the variant as closed *) List.for_all (fun (tag,f) -> - match Btype.row_field_repr f with - Rabsent | Reither(_, _, false, _) -> true - | Reither (_, _, true, _) + match row_field_repr f with + Rabsent | Reither(_, _, false) -> true + | Reither (_, _, true) (* m=true, do not discard matched tags, rather warn *) | Rpresent _ -> List.mem tag fields) - row.row_fields + (row_fields row) else - row.row_closed && + row_closed row && List.for_all (fun (tag,f) -> - Btype.row_field_repr f = Rabsent || List.mem tag fields) - row.row_fields + row_field_repr f = Rabsent || List.mem tag fields) + (row_fields row) | Constant Const_char _ -> List.length env = 256 | Constant _ @@ -803,40 +805,11 @@ let should_extend ext env = match ext with end end -module ConstructorTagHashtbl = Hashtbl.Make( - struct - type t = Types.constructor_tag - let hash = Hashtbl.hash - let equal = Types.equal_tag - end -) - -(* complement constructor tags *) -let complete_tags nconsts nconstrs tags = - let seen_const = Array.make nconsts false - and seen_constr = Array.make nconstrs false in - List.iter - (function - | Cstr_constant i -> seen_const.(i) <- true - | Cstr_block i -> seen_constr.(i) <- true - | _ -> assert false) - tags ; - let r = ConstructorTagHashtbl.create (nconsts+nconstrs) in - for i = 0 to nconsts-1 do - if not seen_const.(i) then - ConstructorTagHashtbl.add r (Cstr_constant i) () - done ; - for i = 0 to nconstrs-1 do - if not seen_constr.(i) then - ConstructorTagHashtbl.add r (Cstr_block i) () - done ; - r - (* build a pattern from a constructor description *) let pat_of_constr ex_pat cstr = {ex_pat with pat_desc = Tpat_construct (mknoloc (Longident.Lident cstr.cstr_name), - cstr, omegas cstr.cstr_arity)} + cstr, omegas cstr.cstr_arity, None)} let orify x y = make_pat (Tpat_or (x, y, None)) x.pat_type x.pat_mode x.pat_env @@ -854,36 +827,33 @@ let pat_of_constrs ex_pat cstrs = let pats_of_type ?(always=false) env ty mode = let ty' = Ctype.expand_head env ty in - match ty'.desc with + match get_desc ty' with | Tconstr (path, _, _) -> - begin try match (Env.find_type path env).type_kind with - | Type_variant cl when always || List.length cl <= 1 || + begin match Env.find_type_descrs path env with + | exception Not_found -> [omega] + | Type_variant (cstrs,_) when always || List.length cstrs <= 1 || (* Only explode when all constructors are GADTs *) - List.for_all (fun cd -> cd.Types.cd_res <> None) cl -> - let cstrs = fst (Env.find_type_descrs path env) in + List.for_all (fun cd -> cd.cstr_generalized) cstrs -> List.map (pat_of_constr (make_pat Tpat_any ty mode env)) cstrs - | Type_record _ -> - let labels = snd (Env.find_type_descrs path env) in + | Type_record (labels, _) -> let fields = List.map (fun ld -> mknoloc (Longident.Lident ld.lbl_name), ld, omega) labels in [make_pat (Tpat_record (fields, Closed)) ty mode env] - | _ -> [omega] - with Not_found -> [omega] + | Type_variant _ | Type_abstract | Type_open -> [omega] end | Ttuple tl -> [make_pat (Tpat_tuple (omegas (List.length tl))) ty mode env] | _ -> [omega] let rec get_variant_constructors env ty = - match (Ctype.repr ty).desc with + match get_desc ty with | Tconstr (path,_,_) -> begin - try match Env.find_type path env with - | {type_kind=Type_variant _} -> - fst (Env.find_type_descrs path env) - | {type_manifest = Some _} -> + try match Env.find_type path env, Env.find_type_descrs path env with + | _, Type_variant (cstrs,_) -> cstrs + | {type_manifest = Some _}, _ -> get_variant_constructors env (Ctype.expand_head_once env (clean_copy ty)) | _ -> fatal_error "Parmatch.get_variant_constructors" @@ -892,15 +862,21 @@ let rec get_variant_constructors env ty = end | _ -> fatal_error "Parmatch.get_variant_constructors" -(* Sends back a pattern that complements constructor tags all_tag *) -let complete_constrs constr all_tags = +module ConstructorSet = Set.Make(struct + type t = constructor_description + let compare c1 c2 = String.compare c1.cstr_name c2.cstr_name +end) + +(* Sends back a pattern that complements the given constructors used_constrs *) +let complete_constrs constr used_constrs = let c = constr.pat_desc in - let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in let constrs = get_variant_constructors constr.pat_env c.cstr_res in + let used_constrs = ConstructorSet.of_list used_constrs in let others = List.filter - (fun cnstr -> ConstructorTagHashtbl.mem not_tags cnstr.cstr_tag) + (fun cnstr -> not (ConstructorSet.mem cnstr used_constrs)) constrs in + (* Split constructors to put constant ones first *) let const, nonconst = List.partition (fun cnstr -> cnstr.cstr_arity = 0) others in const @ nonconst @@ -908,14 +884,16 @@ let complete_constrs constr all_tags = let build_other_constrs env p = let open Patterns.Head in match p.pat_desc with - | Construct ({ cstr_tag = Cstr_constant _ | Cstr_block _ } as c) -> - let constr = { p with pat_desc = c } in - let get_tag q = - match q.pat_desc with - | Construct c -> c.cstr_tag - | _ -> fatal_error "Parmatch.get_tag" in - let all_tags = List.map (fun (p,_) -> get_tag p) env in - pat_of_constrs p (complete_constrs constr all_tags) + | Construct ({ cstr_tag = Cstr_extension _ }) -> extra_pat + | Construct + ({ cstr_tag = Cstr_constant _ | Cstr_block _ | Cstr_unboxed } as c) -> + let constr = { p with pat_desc = c } in + let get_constr q = + match q.pat_desc with + | Construct c -> c + | _ -> fatal_error "Parmatch.get_constr" in + let used_constrs = List.map (fun (p,_) -> get_constr p) env in + pat_of_constrs p (complete_constrs constr used_constrs) | _ -> extra_pat (* Auxiliary for build_other *) @@ -977,16 +955,16 @@ let build_other ext env = List.fold_left (fun others (tag,f) -> if List.mem tag tags then others else - match Btype.row_field_repr f with + match row_field_repr f with Rabsent (* | Reither _ *) -> others (* This one is called after erasing pattern info *) - | Reither (c, _, _, _) -> make_other_pat tag c :: others + | Reither (c, _, _) -> make_other_pat tag c :: others | Rpresent arg -> make_other_pat tag (arg = None) :: others) - [] row.row_fields + [] (row_fields row) with [] -> let tag = - if Btype.row_fixed row then some_private_tag else + if Btype.has_fixed_explanation row then some_private_tag else let rec mktag tag = if List.mem tag tags then mktag (tag ^ "'") else tag in mktag "AnyOtherTag" @@ -1081,7 +1059,7 @@ let rec has_instance p = match p.pat_desc with | Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true | Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p | Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2 - | Tpat_construct (_,_,ps) | Tpat_tuple ps | Tpat_array ps -> + | Tpat_construct (_,_,ps,_) | Tpat_tuple ps | Tpat_array ps -> has_instances ps | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps) | Tpat_lazy p @@ -1465,7 +1443,7 @@ let rec pressure_variants tdefs = function match d.pat_desc with | Variant { type_row; _ } -> let row = type_row () in - if Btype.row_fixed row + if Btype.has_fixed_explanation row || pressure_variants None default then () else close_variant env row | _ -> () @@ -1716,7 +1694,7 @@ let rec le_pat p q = | Tpat_alias(p,_,_), _ -> le_pat p q | _, Tpat_alias(q,_,_) -> le_pat p q | Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0 - | Tpat_construct(_,c1,ps), Tpat_construct(_,c2,qs) -> + | Tpat_construct(_,c1,ps,_), Tpat_construct(_,c2,qs,_) -> Types.equal_tag c1.cstr_tag c2.cstr_tag && le_pats ps qs | Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) -> (l1 = l2 && le_pat p1 p2) @@ -1766,10 +1744,10 @@ let rec lub p q = match p.pat_desc,q.pat_desc with | Tpat_lazy p, Tpat_lazy q -> let r = lub p q in make_pat (Tpat_lazy r) p.pat_type p.pat_mode p.pat_env -| Tpat_construct (lid, c1,ps1), Tpat_construct (_,c2,ps2) +| Tpat_construct (lid,c1,ps1,_), Tpat_construct (_,c2,ps2,_) when Types.equal_tag c1.cstr_tag c2.cstr_tag -> let rs = lubs ps1 ps2 in - make_pat (Tpat_construct (lid, c1,rs)) + make_pat (Tpat_construct (lid, c1, rs, None)) p.pat_type p.pat_mode p.pat_env | Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_) when l1=l2 -> @@ -1902,15 +1880,15 @@ module Conv = struct | Tpat_alias (p,_,_) -> loop p | Tpat_tuple lst -> mkpat (Ppat_tuple (List.map loop lst)) - | Tpat_construct (cstr_lid, cstr, lst) -> + | Tpat_construct (cstr_lid, cstr, lst, _) -> let id = fresh cstr.cstr_name in let lid = { cstr_lid with txt = Longident.Lident id } in Hashtbl.add constrs id cstr; let arg = match List.map loop lst with | [] -> None - | [p] -> Some p - | lst -> Some (mkpat (Ppat_tuple lst)) + | [p] -> Some ([], p) + | lst -> Some ([], mkpat (Ppat_tuple lst)) in mkpat (Ppat_construct(lid, arg)) | Tpat_variant(label,p_opt,_row_desc) -> @@ -2037,8 +2015,8 @@ let extendable_path path = Path.same path Predef.path_option) let rec collect_paths_from_pat r p = match p.pat_desc with -| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)},ps) - -> +| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _|Cstr_unboxed)}, + ps, _) -> let path = get_constructor_type_path p.pat_type p.pat_env in List.fold_left collect_paths_from_pat @@ -2046,7 +2024,7 @@ let rec collect_paths_from_pat r p = match p.pat_desc with ps | Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r | Tpat_tuple ps | Tpat_array ps -| Tpat_construct (_, {cstr_tag=Cstr_extension _}, ps)-> +| Tpat_construct (_, {cstr_tag=Cstr_extension _}, ps, _)-> List.fold_left collect_paths_from_pat r ps | Tpat_record (lps,_) -> List.fold_left @@ -2184,7 +2162,7 @@ let inactive ~partial pat = | Const_int _ | Const_char _ | Const_float _ | Const_int32 _ | Const_int64 _ | Const_nativeint _ -> true end - | Tpat_tuple ps | Tpat_construct (_, _, ps) -> + | Tpat_tuple ps | Tpat_construct (_, _, ps, _) -> List.for_all (fun p -> loop p) ps | Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) -> loop p diff --git a/ocaml/typing/parmatch.mli b/ocaml/typing/parmatch.mli index 8736ed2e3a2..fc81476bc48 100644 --- a/ocaml/typing/parmatch.mli +++ b/ocaml/typing/parmatch.mli @@ -68,7 +68,7 @@ val set_args_erase_mutable : pattern -> pattern list -> pattern list val pat_of_constr : pattern -> constructor_description -> pattern val complete_constrs : constructor_description pattern_data -> - constructor_tag list -> + constructor_description list -> constructor_description list (** [ppat_of_type] builds an untyped pattern from its expected type, diff --git a/ocaml/typing/path.ml b/ocaml/typing/path.ml index e5a8d7ebae7..d54b85b4a14 100644 --- a/ocaml/typing/path.ml +++ b/ocaml/typing/path.ml @@ -56,7 +56,7 @@ let exists_free ids p = let rec scope = function Pident id -> Ident.scope id | Pdot(p, _s) -> scope p - | Papply(p1, p2) -> max (scope p1) (scope p2) + | Papply(p1, p2) -> Misc.Stdlib.Int.max (scope p1) (scope p2) let kfalse _ = false diff --git a/ocaml/typing/patterns.ml b/ocaml/typing/patterns.ml index 990d2abf7b7..f7e8537bef6 100644 --- a/ocaml/typing/patterns.ml +++ b/ocaml/typing/patterns.ml @@ -17,7 +17,6 @@ open Asttypes open Types open Typedtree -module Value_mode = Btype.Value_mode (* useful pattern auxiliary functions *) @@ -97,7 +96,7 @@ module General = struct `Constant cst | Tpat_tuple ps -> `Tuple ps - | Tpat_construct (cstr, cstr_descr, args) -> + | Tpat_construct (cstr, cstr_descr, args, _) -> `Construct (cstr, cstr_descr, args) | Tpat_variant (cstr, arg, row_desc) -> `Variant (cstr, arg, row_desc) @@ -117,7 +116,7 @@ module General = struct | `Constant cst -> Tpat_constant cst | `Tuple ps -> Tpat_tuple ps | `Construct (cstr, cst_descr, args) -> - Tpat_construct (cstr, cst_descr, args) + Tpat_construct (cstr, cst_descr, args, None) | `Variant (cstr, arg, row_desc) -> Tpat_variant (cstr, arg, row_desc) | `Record (fields, closed) -> @@ -196,9 +195,9 @@ end = struct | Some a -> true, [a] in let type_row () = - match Ctype.expand_head q.pat_env q.pat_type with - | {desc = Tvariant type_row} -> Btype.row_repr type_row - | _ -> assert false + match get_desc (Ctype.expand_head q.pat_env q.pat_type) with + | Tvariant type_row -> type_row + | _ -> assert false in Variant {tag; has_arg; cstr_row; type_row}, pats | `Array args -> @@ -234,7 +233,7 @@ end = struct | Array n -> Tpat_array (omegas n) | Construct c -> let lid_loc = mkloc (Longident.Lident c.cstr_name) in - Tpat_construct (lid_loc, c, omegas c.cstr_arity) + Tpat_construct (lid_loc, c, omegas c.cstr_arity, None) | Variant { tag; has_arg; cstr_row } -> let arg_opt = if has_arg then Some omega else None in Tpat_variant (tag, arg_opt, cstr_row) diff --git a/ocaml/typing/persistent_env.ml b/ocaml/typing/persistent_env.ml index 1931f5f3aee..1a4c63dbe3c 100644 --- a/ocaml/typing/persistent_env.ml +++ b/ocaml/typing/persistent_env.ml @@ -19,15 +19,21 @@ open Misc open Cmi_format -module Consistbl = Consistbl.Make (Misc.Stdlib.String) +module CU = Compilation_unit +module Consistbl = Consistbl.Make (CU.Name) (CU) let add_delayed_check_forward = ref (fun _ -> assert false) type error = - | Illegal_renaming of modname * modname * filepath - | Inconsistent_import of modname * filepath * filepath - | Need_recursive_types of modname - | Depend_on_unsafe_string_unit of modname + | Illegal_renaming of CU.Name.t * CU.Name.t * filepath + | Inconsistent_import of CU.Name.t * filepath * filepath + | Need_recursive_types of CU.t + | Depend_on_unsafe_string_unit of CU.t + | Inconsistent_package_declaration of CU.t * filepath + | Inconsistent_package_declaration_between_imports of + filepath * CU.t * CU.t + | Direct_reference_from_wrong_package of + CU.t * filepath * CU.Prefix.t exception Error of error let error err = raise (Error err) @@ -38,6 +44,7 @@ module Persistent_signature = struct cmi : Cmi_format.cmi_infos } let load = ref (fun ~unit_name -> + let unit_name = CU.Name.to_string unit_name in match Load_path.find_uncap (unit_name ^ ".cmi") with | filename -> Some { filename; cmi = read_cmi filename } | exception Not_found -> None) @@ -45,17 +52,15 @@ end type can_load_cmis = | Can_load_cmis - | Cannot_load_cmis of EnvLazy.log + | Cannot_load_cmis of Lazy_backtrack.log type pers_struct = { - ps_name: string; - ps_crcs: (string * Digest.t option) list; + ps_name: CU.t; + ps_crcs: Import_info.t array; ps_filename: string; ps_flags: pers_flags list; } -module String = Misc.Stdlib.String - (* If a .cmi file is missing (or invalid), we store it as Missing in the cache. *) type 'a pers_struct_info = @@ -63,17 +68,18 @@ type 'a pers_struct_info = | Found of pers_struct * 'a type 'a t = { - persistent_structures : (string, 'a pers_struct_info) Hashtbl.t; - imported_units: String.Set.t ref; - imported_opaque_units: String.Set.t ref; + persistent_structures : + (CU.Name.t, 'a pers_struct_info) Hashtbl.t; + imported_units: CU.Name.Set.t ref; + imported_opaque_units: CU.Name.Set.t ref; crc_units: Consistbl.t; can_load_cmis: can_load_cmis ref; } let empty () = { persistent_structures = Hashtbl.create 17; - imported_units = ref String.Set.empty; - imported_opaque_units = ref String.Set.empty; + imported_units = ref CU.Name.Set.empty; + imported_opaque_units = ref CU.Name.Set.empty; crc_units = Consistbl.create (); can_load_cmis = ref Can_load_cmis; } @@ -87,8 +93,8 @@ let clear penv = can_load_cmis; } = penv in Hashtbl.clear persistent_structures; - imported_units := String.Set.empty; - imported_opaque_units := String.Set.empty; + imported_units := CU.Name.Set.empty; + imported_opaque_units := CU.Name.Set.empty; Consistbl.clear crc_units; can_load_cmis := Can_load_cmis; () @@ -102,10 +108,10 @@ let clear_missing {persistent_structures; _} = List.iter (Hashtbl.remove persistent_structures) missing_entries let add_import {imported_units; _} s = - imported_units := String.Set.add s !imported_units + imported_units := CU.Name.Set.add s !imported_units let register_import_as_opaque {imported_opaque_units; _} s = - imported_opaque_units := String.Set.add s !imported_opaque_units + imported_opaque_units := CU.Name.Set.add s !imported_opaque_units let find_in_cache {persistent_structures; _} s = match Hashtbl.find persistent_structures s with @@ -115,13 +121,15 @@ let find_in_cache {persistent_structures; _} s = let import_crcs penv ~source crcs = let {crc_units; _} = penv in - let import_crc (name, crco) = + let import_crc import_info = + let name = Import_info.name import_info in + let crco = Import_info.crc_with_unit import_info in match crco with | None -> () - | Some crc -> + | Some (unit, crc) -> add_import penv name; - Consistbl.check crc_units name crc source - in List.iter import_crc crcs + Consistbl.check crc_units name unit crc source + in Array.iter import_crc crcs let check_consistency penv ps = try import_crcs penv ~source:ps.ps_filename ps.ps_crcs @@ -129,8 +137,13 @@ let check_consistency penv ps = unit_name = name; inconsistent_source = source; original_source = auth; + inconsistent_data = source_unit; + original_data = auth_unit; } -> - error (Inconsistent_import(name, auth, source)) + if CU.equal source_unit auth_unit + then error (Inconsistent_import(name, auth, source)) + else error (Inconsistent_package_declaration_between_imports( + ps.ps_filename, auth_unit, source_unit)) let can_load_cmis penv = !(penv.can_load_cmis) @@ -138,13 +151,13 @@ let set_can_load_cmis penv setting = penv.can_load_cmis := setting let without_cmis penv f x = - let log = EnvLazy.log () in + let log = Lazy_backtrack.log () in let res = Misc.(protect_refs [R (penv.can_load_cmis, Cannot_load_cmis log)] (fun () -> f x)) in - EnvLazy.backtrack log; + Lazy_backtrack.backtrack log; res let fold {persistent_structures; _} f x = @@ -157,7 +170,7 @@ let fold {persistent_structures; _} f x = let save_pers_struct penv crc ps pm = let {persistent_structures; crc_units; _} = penv in - let modname = ps.ps_name in + let modname = CU.name ps.ps_name in Hashtbl.add persistent_structures modname (Found (ps, pm)); List.iter (function @@ -166,7 +179,7 @@ let save_pers_struct penv crc ps pm = | Unsafe_string -> () | Opaque -> register_import_as_opaque penv modname) ps.ps_flags; - Consistbl.set crc_units modname crc ps.ps_filename; + Consistbl.set crc_units modname ps.ps_name crc ps.ps_filename; add_import penv modname let acknowledge_pers_struct penv check modname pers_sig pm = @@ -179,8 +192,9 @@ let acknowledge_pers_struct penv check modname pers_sig pm = ps_filename = filename; ps_flags = flags; } in - if ps.ps_name <> modname then - error (Illegal_renaming(modname, ps.ps_name, filename)); + let found_name = CU.name name in + if not (CU.Name.equal modname found_name) then + error (Illegal_renaming(modname, found_name, filename)); List.iter (function | Rectypes -> @@ -193,6 +207,16 @@ let acknowledge_pers_struct penv check modname pers_sig pm = | Opaque -> register_import_as_opaque penv modname) ps.ps_flags; if check then check_consistency penv ps; + begin match CU.get_current () with + | Some current_unit -> + let access_allowed = + CU.can_access_by_name name ~accessed_by:current_unit + in + if not access_allowed then + let prefix = CU.for_pack_prefix current_unit in + error (Direct_reference_from_wrong_package (name, filename, prefix)); + | None -> () + end; let {persistent_structures; _} = penv in Hashtbl.add persistent_structures modname (Found (ps, pm)); ps @@ -207,7 +231,7 @@ let read_pers_struct penv val_of_pers_sig check modname filename = let find_pers_struct penv val_of_pers_sig check name = let {persistent_structures; _} = penv in - if name = "*predef*" then raise Not_found; + if CU.Name.equal name CU.Name.predef_exn then raise Not_found; match Hashtbl.find persistent_structures name with | Found (ps, pm) -> (ps, pm) | Missing -> raise Not_found @@ -227,17 +251,24 @@ let find_pers_struct penv val_of_pers_sig check name = let ps = acknowledge_pers_struct penv check name psig pm in (ps, pm) +let describe_prefix ppf prefix = + if CU.Prefix.is_empty prefix then + Format.fprintf ppf "outside of any package" + else + Format.fprintf ppf "package %a" CU.Prefix.print prefix + (* Emits a warning if there is no valid cmi for name *) let check_pers_struct penv f ~loc name = + let name_as_string = CU.Name.to_string name in try ignore (find_pers_struct penv f false name) with | Not_found -> - let warn = Warnings.No_cmi_file(name, None) in + let warn = Warnings.No_cmi_file(name_as_string, None) in Location.prerr_warning loc warn | Cmi_format.Error err -> let msg = Format.asprintf "%a" Cmi_format.report_error err in - let warn = Warnings.No_cmi_file(name, Some msg) in + let warn = Warnings.No_cmi_file(name_as_string, Some msg) in Location.prerr_warning loc warn | Error err -> let msg = @@ -245,18 +276,26 @@ let check_pers_struct penv f ~loc name = | Illegal_renaming(name, ps_name, filename) -> Format.asprintf " %a@ contains the compiled interface for @ \ - %s when %s was expected" - Location.print_filename filename ps_name name + %a when %a was expected" + Location.print_filename filename + CU.Name.print ps_name + CU.Name.print name | Inconsistent_import _ -> assert false | Need_recursive_types name -> - Format.sprintf - "%s uses recursive types" - name + Format.asprintf + "%a uses recursive types" + CU.print name | Depend_on_unsafe_string_unit name -> - Printf.sprintf "%s uses -unsafe-string" - name + Format.asprintf "%a uses -unsafe-string" + CU.print name + | Inconsistent_package_declaration _ -> assert false + | Inconsistent_package_declaration_between_imports _ -> assert false + | Direct_reference_from_wrong_package (unit, _filename, prefix) -> + Format.asprintf "%a is inaccessible from %a" + CU.print unit + describe_prefix prefix in - let warn = Warnings.No_cmi_file(name, Some msg) in + let warn = Warnings.No_cmi_file(name_as_string, Some msg) in Location.prerr_warning loc warn let read penv f modname filename = @@ -277,29 +316,49 @@ let check penv f ~loc name = (fun () -> check_pers_struct penv f ~loc name) end +(* CR mshinwell: delete this having moved to 4.14 build compilers *) +module Array = struct + include Array + + (* From stdlib/array.ml *) + let find_opt p a = + let n = Array.length a in + let rec loop i = + if i = n then None + else + let x = Array.unsafe_get a i in + if p x then Some x + else loop (succ i) + in + loop 0 +end + let crc_of_unit penv f name = let (ps, _pm) = find_pers_struct penv f true name in - let crco = - try - List.assoc name ps.ps_crcs - with Not_found -> - assert false - in - match crco with - None -> assert false + match Array.find_opt (Import_info.has_name ~name) ps.ps_crcs with + | None -> assert false + | Some import_info -> + match Import_info.crc import_info with + | None -> assert false | Some crc -> crc let imports {imported_units; crc_units; _} = - Consistbl.extract (String.Set.elements !imported_units) crc_units + let imports = + Consistbl.extract (CU.Name.Set.elements !imported_units) + crc_units + in + List.map (fun (cu_name, crc_with_unit) -> + Import_info.create cu_name ~crc_with_unit) + imports let looked_up {persistent_structures; _} modname = Hashtbl.mem persistent_structures modname let is_imported {imported_units; _} s = - String.Set.mem s !imported_units + CU.Name.Set.mem s !imported_units let is_imported_opaque {imported_opaque_units; _} s = - String.Set.mem s !imported_opaque_units + CU.Name.Set.mem s !imported_opaque_units let make_cmi penv modname sign alerts = let flags = @@ -314,7 +373,7 @@ let make_cmi penv modname sign alerts = { cmi_name = modname; cmi_sign = sign; - cmi_crcs = crcs; + cmi_crcs = Array.of_list crcs; cmi_flags = flags } @@ -335,7 +394,10 @@ let save_cmi penv psig pm = will also return its crc *) let ps = { ps_name = modname; - ps_crcs = (cmi.cmi_name, Some crc) :: imports; + ps_crcs = + Array.append + [| Import_info.create_normal cmi.cmi_name ~crc:(Some crc) |] + imports; ps_filename = filename; ps_flags = flags; } in @@ -348,21 +410,44 @@ let report_error ppf = function | Illegal_renaming(modname, ps_name, filename) -> fprintf ppf "Wrong file naming: %a@ contains the compiled interface for@ \ - %s when %s was expected" - Location.print_filename filename ps_name modname + %a when %a was expected" + Location.print_filename filename + CU.Name.print ps_name + CU.Name.print modname | Inconsistent_import(name, source1, source2) -> fprintf ppf "@[The files %a@ and %a@ \ - make inconsistent assumptions@ over interface %s@]" - Location.print_filename source1 Location.print_filename source2 name + make inconsistent assumptions@ over interface %a@]" + Location.print_filename source1 Location.print_filename source2 + CU.Name.print name | Need_recursive_types(import) -> fprintf ppf - "@[Invalid import of %s, which uses recursive types.@ %s@]" - import "The compilation flag -rectypes is required" + "@[Invalid import of %a, which uses recursive types.@ %s@]" + CU.print import + "The compilation flag -rectypes is required" | Depend_on_unsafe_string_unit(import) -> fprintf ppf - "@[Invalid import of %s, compiled with -unsafe-string.@ %s@]" - import "This compiler has been configured in strict \ - safe-string mode (-force-safe-string)" + "@[Invalid import of %a, compiled with -unsafe-string.@ %s@]" + CU.print import + "This compiler has been configured in strict \ + safe-string mode (-force-safe-string)" + | Inconsistent_package_declaration(intf_package, intf_filename) -> + fprintf ppf + "@[The interface %a@ is compiled for package %s.@ %s@]" + CU.print intf_package intf_filename + "The compilation flag -for-pack with the same package is required" + | Inconsistent_package_declaration_between_imports (filename, unit1, unit2) -> + fprintf ppf + "@[The file %s@ is imported both as %a@ and as %a.@]" + filename + CU.print unit1 + CU.print unit2 + | Direct_reference_from_wrong_package(unit, filename, prefix) -> + fprintf ppf + "@[Invalid reference to %a (in file %s) from %a.@ %s]" + CU.print unit + filename + describe_prefix prefix + "Can only access members of this library's package or a containing package" let () = Location.register_error_of_exn diff --git a/ocaml/typing/persistent_env.mli b/ocaml/typing/persistent_env.mli index ac3109c37eb..59437bf76b5 100644 --- a/ocaml/typing/persistent_env.mli +++ b/ocaml/typing/persistent_env.mli @@ -17,14 +17,19 @@ open Misc module Consistbl : module type of struct - include Consistbl.Make (Misc.Stdlib.String) + include Consistbl.Make (Compilation_unit.Name) (Compilation_unit) end type error = - | Illegal_renaming of modname * modname * filepath - | Inconsistent_import of modname * filepath * filepath - | Need_recursive_types of modname - | Depend_on_unsafe_string_unit of modname + | Illegal_renaming of Compilation_unit.Name.t * Compilation_unit.Name.t * filepath + | Inconsistent_import of Compilation_unit.Name.t * filepath * filepath + | Need_recursive_types of Compilation_unit.t + | Depend_on_unsafe_string_unit of Compilation_unit.t + | Inconsistent_package_declaration of Compilation_unit.t * filepath + | Inconsistent_package_declaration_between_imports of + filepath * Compilation_unit.t * Compilation_unit.t + | Direct_reference_from_wrong_package of + Compilation_unit.t * filepath * Compilation_unit.Prefix.t exception Error of error @@ -38,12 +43,12 @@ module Persistent_signature : sig (** Function used to load a persistent signature. The default is to look for the .cmi file in the load path. This function can be overridden to load it from memory, for instance to build a self-contained toplevel. *) - val load : (unit_name:string -> t option) ref + val load : (unit_name:Compilation_unit.Name.t -> t option) ref end type can_load_cmis = | Can_load_cmis - | Cannot_load_cmis of Misc.EnvLazy.log + | Cannot_load_cmis of Lazy_backtrack.log type 'a t @@ -52,36 +57,36 @@ val empty : unit -> 'a t val clear : 'a t -> unit val clear_missing : 'a t -> unit -val fold : 'a t -> (modname -> 'a -> 'b -> 'b) -> 'b -> 'b +val fold : 'a t -> (Compilation_unit.Name.t -> 'a -> 'b -> 'b) -> 'b -> 'b val read : 'a t -> (Persistent_signature.t -> 'a) - -> modname -> filepath -> 'a + -> Compilation_unit.Name.t -> filepath -> 'a val find : 'a t -> (Persistent_signature.t -> 'a) - -> modname -> 'a + -> Compilation_unit.Name.t -> 'a -val find_in_cache : 'a t -> modname -> 'a option +val find_in_cache : 'a t -> Compilation_unit.Name.t -> 'a option val check : 'a t -> (Persistent_signature.t -> 'a) - -> loc:Location.t -> modname -> unit + -> loc:Location.t -> Compilation_unit.Name.t -> unit (* [looked_up penv md] checks if one has already tried to read the signature for [md] in the environment [penv] (it may have failed) *) -val looked_up : 'a t -> modname -> bool +val looked_up : 'a t -> Compilation_unit.Name.t -> bool (* [is_imported penv md] checks if [md] has been successfully imported in the environment [penv] *) -val is_imported : 'a t -> modname -> bool +val is_imported : 'a t -> Compilation_unit.Name.t -> bool (* [is_imported_opaque penv md] checks if [md] has been imported in [penv] as an opaque module *) -val is_imported_opaque : 'a t -> modname -> bool +val is_imported_opaque : 'a t -> Compilation_unit.Name.t -> bool (* [register_import_as_opaque penv md] registers [md] in [penv] as an opaque module *) -val register_import_as_opaque : 'a t -> modname -> unit +val register_import_as_opaque : 'a t -> Compilation_unit.Name.t -> unit -val make_cmi : 'a t -> modname -> Types.signature -> alerts +val make_cmi : 'a t -> Compilation_unit.t -> Types.signature -> alerts -> Cmi_format.cmi_infos val save_cmi : 'a t -> Persistent_signature.t -> 'a -> unit @@ -93,13 +98,15 @@ val without_cmis : 'a t -> ('b -> 'c) -> 'b -> 'c allow [penv] to openi cmis during its execution *) (* may raise Consistbl.Inconsistency *) -val import_crcs : 'a t -> source:filepath -> crcs -> unit +val import_crcs : 'a t -> source:filepath -> + Import_info.t array -> unit (* Return the set of compilation units imported, with their CRC *) -val imports : 'a t -> crcs +val imports : 'a t -> Import_info.t list (* Return the CRC of the interface of the given compilation unit *) -val crc_of_unit: 'a t -> (Persistent_signature.t -> 'a) -> modname -> Digest.t +val crc_of_unit: 'a t -> (Persistent_signature.t -> 'a) + -> Compilation_unit.Name.t -> Digest.t (* Forward declaration to break mutual recursion with Typecore. *) val add_delayed_check_forward: ((unit -> unit) -> unit) ref diff --git a/ocaml/typing/predef.ml b/ocaml/typing/predef.ml index 786d1dc21f1..9c7aa5ba916 100644 --- a/ocaml/typing/predef.ml +++ b/ocaml/typing/predef.ml @@ -134,8 +134,9 @@ and ident_cons = ident_create "::" and ident_none = ident_create "None" and ident_some = ident_create "Some" -let mk_add_type add_type type_ident - ?manifest ?(immediate=Type_immediacy.Unknown) ?(kind=Type_abstract) env = +let mk_add_type add_type + ?manifest ?(immediate=Type_immediacy.Unknown) ?(kind=Type_abstract) + type_ident env = let decl = {type_params = []; type_arity = 0; @@ -149,7 +150,7 @@ let mk_add_type add_type type_ident type_expansion_scope = lowest_level; type_attributes = []; type_immediate = immediate; - type_unboxed = unboxed_false_default_false; + type_unboxed_default = false; type_uid = Uid.of_predef_id type_ident; } in @@ -157,8 +158,8 @@ let mk_add_type add_type type_ident let common_initial_env add_type add_extension empty_env = let add_type = mk_add_type add_type - and add_type1 type_ident - ~variance ~separability ?(kind=fun _ -> Type_abstract) env = + and add_type1 ?(kind=fun _ -> Type_abstract) type_ident + ~variance ~separability env = let param = newgenvar () in let decl = {type_params = [param]; @@ -173,7 +174,7 @@ let common_initial_env add_type add_extension empty_env = type_expansion_scope = lowest_level; type_attributes = []; type_immediate = Unknown; - type_unboxed = unboxed_false_default_false; + type_unboxed_default = false; type_uid = Uid.of_predef_id type_ident; } in @@ -183,7 +184,7 @@ let common_initial_env add_type add_extension empty_env = add_extension id { ext_type_path = path_exn; ext_type_params = []; - ext_args = Cstr_tuple l; + ext_args = Cstr_tuple (List.map (fun x -> (x, Unrestricted)) l); ext_ret_type = None; ext_private = Asttypes.Public; ext_loc = Location.none; @@ -193,49 +194,57 @@ let common_initial_env add_type add_extension empty_env = ext_uid = Uid.of_predef_id id; } in - add_extension ident_match_failure - [newgenty (Ttuple[type_string; type_int; type_int])] ( - add_extension ident_out_of_memory [] ( - add_extension ident_stack_overflow [] ( - add_extension ident_invalid_argument [type_string] ( - add_extension ident_failure [type_string] ( - add_extension ident_not_found [] ( - add_extension ident_sys_blocked_io [] ( - add_extension ident_sys_error [type_string] ( - add_extension ident_end_of_file [] ( - add_extension ident_division_by_zero [] ( - add_extension ident_assert_failure - [newgenty (Ttuple[type_string; type_int; type_int])] ( - add_extension ident_undefined_recursive_module - [newgenty (Ttuple[type_string; type_int; type_int])] ( - add_type ident_int64 ( - add_type ident_int32 ( - add_type ident_nativeint ( - add_type1 ident_lazy_t ~variance:Variance.covariant - ~separability:Separability.Ind ( - add_type1 ident_option ~variance:Variance.covariant - ~separability:Separability.Ind - ~kind:(fun tvar -> - Type_variant([cstr ident_none []; cstr ident_some [tvar]]) - ) ( - add_type1 ident_list ~variance:Variance.covariant - ~separability:Separability.Ind - ~kind:(fun tvar -> - Type_variant([cstr ident_nil []; cstr ident_cons [tvar; type_list tvar]]) - ) ( - add_type1 ident_array ~variance:Variance.full ~separability:Separability.Ind ( - add_type ident_exn ~kind:Type_open ( - add_type ident_unit ~immediate:Always - ~kind:(Type_variant([cstr ident_void []])) ( - add_type ident_bool ~immediate:Always - ~kind:(Type_variant([cstr ident_false []; cstr ident_true []])) ( - add_type ident_float ( - add_type ident_string ( - add_type ident_char ~immediate:Always ( - add_type ident_int ~immediate:Always ( - add_type ident_extension_constructor ( - add_type ident_floatarray ( - empty_env)))))))))))))))))))))))))))) + let variant constrs = Type_variant (constrs, Variant_regular) in + empty_env + (* Predefined types - alphabetical order *) + |> add_type1 ident_array + ~variance:Variance.full + ~separability:Separability.Ind + |> add_type ident_bool + ~immediate:Always + ~kind:(variant [cstr ident_false []; cstr ident_true []]) + |> add_type ident_char ~immediate:Always + |> add_type ident_exn ~kind:Type_open + |> add_type ident_extension_constructor + |> add_type ident_float + |> add_type ident_floatarray + |> add_type ident_int ~immediate:Always + |> add_type ident_int32 + |> add_type ident_int64 + |> add_type1 ident_lazy_t + ~variance:Variance.covariant + ~separability:Separability.Ind + |> add_type1 ident_list + ~variance:Variance.covariant + ~separability:Separability.Ind + ~kind:(fun tvar -> + variant [cstr ident_nil []; cstr ident_cons [tvar, Unrestricted; type_list tvar, Unrestricted]]) + |> add_type ident_nativeint + |> add_type1 ident_option + ~variance:Variance.covariant + ~separability:Separability.Ind + ~kind:(fun tvar -> + variant [cstr ident_none []; cstr ident_some [tvar, Unrestricted]]) + |> add_type ident_string + |> add_type ident_unit + ~immediate:Always + ~kind:(variant [cstr ident_void []]) + (* Predefined exceptions - alphabetical order *) + |> add_extension ident_assert_failure + [newgenty (Ttuple[type_string; type_int; type_int])] + |> add_extension ident_division_by_zero [] + |> add_extension ident_end_of_file [] + |> add_extension ident_failure [type_string] + |> add_extension ident_invalid_argument [type_string] + |> add_extension ident_match_failure + [newgenty (Ttuple[type_string; type_int; type_int])] + |> add_extension ident_not_found [] + |> add_extension ident_out_of_memory [] + |> add_extension ident_stack_overflow [] + |> add_extension ident_sys_blocked_io [] + |> add_extension ident_sys_error [type_string] + |> add_extension ident_undefined_recursive_module + [newgenty (Ttuple[type_string; type_int; type_int])] let build_initial_env add_type add_exception empty_env = let common = common_initial_env add_type add_exception empty_env in diff --git a/ocaml/typing/printpat.ml b/ocaml/typing/printpat.ml index 43a18649eb4..64094b63ec3 100644 --- a/ocaml/typing/printpat.ml +++ b/ocaml/typing/printpat.ml @@ -56,17 +56,23 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> | Tpat_constant c -> fprintf ppf "%s" (pretty_const c) | Tpat_tuple vs -> fprintf ppf "@[(%a)@]" (pretty_vals ",") vs - | Tpat_construct (_, cstr, []) -> + | Tpat_construct (_, cstr, [], _) -> fprintf ppf "%s" cstr.cstr_name - | Tpat_construct (_, cstr, [w]) -> + | Tpat_construct (_, cstr, [w], None) -> fprintf ppf "@[<2>%s@ %a@]" cstr.cstr_name pretty_arg w - | Tpat_construct (_, cstr, vs) -> + | Tpat_construct (_, cstr, vs, vto) -> let name = cstr.cstr_name in - begin match (name, vs) with - ("::", [v1;v2]) -> + begin match (name, vs, vto) with + ("::", [v1;v2], None) -> fprintf ppf "@[%a::@,%a@]" pretty_car v1 pretty_cdr v2 - | _ -> + | (_, _, None) -> fprintf ppf "@[<2>%s@ @[(%a)@]@]" name (pretty_vals ",") vs + | (_, _, Some ([], _t)) -> + fprintf ppf "@[<2>%s@ @[(%a : _)@]@]" name (pretty_vals ",") vs + | (_, _, Some (vl, _t)) -> + let vars = List.map (fun x -> Ident.name x.txt) vl in + fprintf ppf "@[<2>%s@ (type %s)@ @[(%a : _)@]@]" + name (String.concat " " vars) (pretty_vals ",") vs end | Tpat_variant (l, None, _) -> fprintf ppf "`%s" l @@ -102,19 +108,19 @@ let rec pretty_val : type k . _ -> k general_pattern -> _ = fun ppf v -> fprintf ppf "@[(%a)@]" pretty_or v and pretty_car ppf v = match v.pat_desc with -| Tpat_construct (_,cstr, [_ ; _]) +| Tpat_construct (_,cstr, [_ ; _], None) when is_cons cstr -> fprintf ppf "(%a)" pretty_val v | _ -> pretty_val ppf v and pretty_cdr ppf v = match v.pat_desc with -| Tpat_construct (_,cstr, [v1 ; v2]) +| Tpat_construct (_,cstr, [v1 ; v2], None) when is_cons cstr -> fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2 | _ -> pretty_val ppf v and pretty_arg ppf v = match v.pat_desc with -| Tpat_construct (_,_,_::_) +| Tpat_construct (_,_,_::_,None) | Tpat_variant (_, Some _, _) -> fprintf ppf "(%a)" pretty_val v | _ -> pretty_val ppf v diff --git a/ocaml/typing/printtyp.ml b/ocaml/typing/printtyp.ml index 96550fd3b4c..75beaa1f2fc 100644 --- a/ocaml/typing/printtyp.ml +++ b/ocaml/typing/printtyp.ml @@ -26,6 +26,7 @@ open Btype open Outcometree module String = Misc.Stdlib.String +module Int = Misc.Stdlib.Int (* Print a long identifier *) @@ -44,6 +45,9 @@ module Out_name = struct let set out_name x = out_name.printed_name <- x end +(** Some identifiers may require hiding when printing *) +type bound_ident = { hide:bool; ident:Ident.t } + (* printing environment for path shortening and naming *) let printing_env = ref Env.empty @@ -195,7 +199,7 @@ module Conflicts = struct in begin match l with | [] -> () - | l -> Format.fprintf ppf "@ %a" print_located_explanations l + | l -> Format.fprintf ppf "@,%a" print_located_explanations l end; (* if there are name collisions in a toplevel session, display at least one generic hint by namespace *) @@ -204,7 +208,6 @@ module Conflicts = struct let exists () = M.cardinal !explanations >0 end - module Naming_context = struct module M = String.Map @@ -233,7 +236,7 @@ type mapping = let hid_start = 0 let add_hid_id id map = - let new_id = 1 + Ident.Map.fold (fun _ -> max) map hid_start in + let new_id = 1 + Ident.Map.fold (fun _ -> Int.max) map hid_start in new_id, Ident.Map.add id new_id map let find_hid id map = @@ -248,12 +251,21 @@ let set namespace x = map.(Namespace.id namespace) <- x (* Names used in recursive definitions are not considered when determining if a name is already attributed in the current environment. - This is a weaker version of hidden_rec_items used by short-path. *) + This is a complementary version of hidden_rec_items used by short-path. *) let protected = ref S.empty -let add_protected id = protected := S.add (Ident.name id) !protected -let reset_protected () = protected := S.empty -let with_hidden id f = - protect_refs [ R(protected,S.add (Ident.name id) !protected)] f + +(* When dealing with functor arguments, identity becomes fuzzy because the same + syntactic argument may be represented by different identifiers during the + error processing, we are thus disabling disambiguation on the argument name +*) +let fuzzy = ref S.empty +let with_arg id f = + protect_refs [ R(fuzzy, S.add (Ident.name id) !fuzzy) ] f +let fuzzy_id namespace id = namespace = Module && S.mem (Ident.name id) !fuzzy + +let with_hidden ids f = + let update m id = S.add (Ident.name id.ident) m in + protect_refs [ R(protected, List.fold_left update !protected ids)] f let pervasives_name namespace name = if not !enabled then Out_name.create name else @@ -281,7 +293,9 @@ let env_ident namespace name = (** Associate a name to the identifier [id] within [namespace] *) let ident_name_simple namespace id = - if not !enabled then Out_name.create (Ident.name id) else + if not !enabled || fuzzy_id namespace id then + Out_name.create (Ident.name id) + else let name = Ident.name id in match M.find name (get namespace) with | Uniquely_associated_to (id',r) when Ident.same id id' -> @@ -322,6 +336,11 @@ let ident_name namespace id = let reset () = Array.iteri ( fun i _ -> map.(i) <- M.empty ) map +let with_ctx f = + let old = Array.copy map in + try_finally f + ~always:(fun () -> Array.blit old 0 map 0 (Array.length map)) + end let ident_name = Naming_context.ident_name let reset_naming_context = Naming_context.reset @@ -361,6 +380,16 @@ let rec module_path_is_an_alias_of env path ~alias_of = | _ -> false | exception Not_found -> false +let expand_longident_head name = + match find_double_underscore name with + | None -> None + | Some i -> + Some + (Ldot + (Lident (String.sub name 0 i), + String.capitalize_ascii + (String.sub name (i + 2) (String.length name - i - 2)))) + (* Simple heuristic to print Foo__bar.* as Foo.Bar.* when Foo.Bar is an alias for Foo__bar. This pattern is used by the stdlib. *) let rec rewrite_double_underscore_paths env p = @@ -372,15 +401,9 @@ let rec rewrite_double_underscore_paths env p = rewrite_double_underscore_paths env b) | Pident id -> let name = Ident.name id in - match find_double_underscore name with + match expand_longident_head name with | None -> p - | Some i -> - let better_lid = - Ldot - (Lident (String.sub name 0 i), - String.capitalize_ascii - (String.sub name (i + 2) (String.length name - i - 2))) - in + | Some better_lid -> match Env.find_module_by_name better_lid env with | exception Not_found -> p | p', _ -> @@ -395,6 +418,25 @@ let rewrite_double_underscore_paths env p = else rewrite_double_underscore_paths env p +let rec rewrite_double_underscore_longidents env (l : Longident.t) = + match l with + | Ldot (l, s) -> + Ldot (rewrite_double_underscore_longidents env l, s) + | Lapply (a, b) -> + Lapply (rewrite_double_underscore_longidents env a, + rewrite_double_underscore_longidents env b) + | Lident name -> + match expand_longident_head name with + | None -> l + | Some l' -> + match Env.find_module_by_name l env, Env.find_module_by_name l' env with + | exception Not_found -> l + | (p, _), (p', _) -> + if module_path_is_an_alias_of env p' ~alias_of:p then + l' + else + l + let rec tree_of_path namespace = function | Pident id -> Oide_ident (ident_name namespace id) @@ -443,33 +485,17 @@ let raw_list pr ppf = function let kind_vars = ref [] let kind_count = ref 0 -let rec safe_kind_repr v = function - Fvar {contents=Some k} -> - if List.memq k v then "Fvar loop" else - safe_kind_repr (k::v) k - | Fvar r -> - let vid = - try List.assq r !kind_vars - with Not_found -> - let c = incr kind_count; !kind_count in - kind_vars := (r,c) :: !kind_vars; - c - in - Printf.sprintf "Fvar {None}@%d" vid - | Fpresent -> "Fpresent" +let string_of_field_kind v = + match field_kind_repr v with + | Fpublic -> "Fpublic" | Fabsent -> "Fabsent" + | Fprivate -> "Fprivate" -let rec safe_commu_repr v = function - Cok -> "Cok" - | Cunknown -> "Cunknown" - | Clink r -> - if List.memq r v then "Clink loop" else - safe_commu_repr (r::v) !r - -let rec safe_repr v = function +let rec safe_repr v t = + match Transient_expr.coerce t with {desc = Tlink t} when not (List.memq t v) -> safe_repr (t::v) t - | t -> t + | t' -> t' let rec list_of_memo = function Mnil -> [] @@ -500,7 +526,7 @@ and raw_type_desc ppf = function fprintf ppf "@[Tarrow((\"%s\",%a,%a),@,%a,@,%a,@,%s)@]" (string_of_label l) Alloc_mode.print arg Alloc_mode.print ret raw_type t1 raw_type t2 - (safe_commu_repr [] c) + (if is_commu_ok c then "Cok" else "Cunknown") | Ttuple tl -> fprintf ppf "@[<1>Ttuple@,%a@]" raw_type_list tl | Tconstr (p, tl, abbrev) -> @@ -515,34 +541,37 @@ and raw_type_desc ppf = function fprintf ppf "(Some(@,%a,@,%a))" path p raw_type_list tl) | Tfield (f, k, t1, t2) -> fprintf ppf "@[Tfield(@,%s,@,%s,@,%a,@;<0 -1>%a)@]" f - (safe_kind_repr [] k) + (string_of_field_kind k) raw_type t1 raw_type t2 | Tnil -> fprintf ppf "Tnil" | Tlink t -> fprintf ppf "@[<1>Tlink@,%a@]" raw_type t - | Tsubst t -> fprintf ppf "@[<1>Tsubst@,%a@]" raw_type t + | Tsubst (t, None) -> fprintf ppf "@[<1>Tsubst@,(%a,None)@]" raw_type t + | Tsubst (t, Some t') -> + fprintf ppf "@[<1>Tsubst@,(%a,@ Some%a)@]" raw_type t raw_type t' | Tunivar name -> fprintf ppf "Tunivar %a" print_name name | Tpoly (t, tl) -> fprintf ppf "@[Tpoly(@,%a,@,%a)@]" raw_type t raw_type_list tl | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in fprintf ppf "@[{@[%s@,%a;@]@ @[%s@,%a;@]@ %s%B;@ %s%a;@ @[<1>%s%t@]}@]" "row_fields=" (raw_list (fun ppf (l, f) -> fprintf ppf "@[%s,@ %a@]" l raw_field f)) - row.row_fields - "row_more=" raw_type row.row_more - "row_closed=" row.row_closed - "row_fixed=" raw_row_fixed row.row_fixed + fields + "row_more=" raw_type more + "row_closed=" closed + "row_fixed=" raw_row_fixed fixed "row_name=" (fun ppf -> - match row.row_name with None -> fprintf ppf "None" + match name with None -> fprintf ppf "None" | Some(p,tl) -> fprintf ppf "Some(@,%a,@,%a)" path p raw_type_list tl) - | Tpackage (p, _, tl) -> + | Tpackage (p, fl) -> fprintf ppf "@[Tpackage(@,%a@,%a)@]" path p - raw_type_list tl + raw_type_list (List.map snd fl) and raw_row_fixed ppf = function | None -> fprintf ppf "None" | Some Types.Fixed_private -> fprintf ppf "Some Fixed_private" @@ -550,16 +579,21 @@ and raw_row_fixed ppf = function | Some Types.Univar t -> fprintf ppf "Some(Univar(%a))" raw_type t | Some Types.Reified p -> fprintf ppf "Some(Reified(%a))" path p -and raw_field ppf = function - Rpresent None -> fprintf ppf "Rpresent None" - | Rpresent (Some t) -> fprintf ppf "@[<1>Rpresent(Some@,%a)@]" raw_type t - | Reither (c,tl,m,e) -> - fprintf ppf "@[Reither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c +and raw_field ppf rf = + match_row_field + ~absent:(fun _ -> fprintf ppf "RFabsent") + ~present:(function + | None -> + fprintf ppf "RFpresent None" + | Some t -> + fprintf ppf "@[<1>RFpresent(Some@,%a)@]" raw_type t) + ~either:(fun c tl m e -> + fprintf ppf "@[RFeither(%B,@,%a,@,%B,@,@[<1>ref%t@])@]" c raw_type_list tl m (fun ppf -> - match !e with None -> fprintf ppf " None" - | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f) - | Rabsent -> fprintf ppf "Rabsent" + match e with None -> fprintf ppf " RFnone" + | Some f -> fprintf ppf "@,@[<1>(%a)@]" raw_field f)) + rf let raw_type_expr ppf t = visited := []; kind_vars := []; kind_count := 0; @@ -596,7 +630,7 @@ type best_path = Paths of Path.t list | Best of Path.t cache for short-paths *) let printing_old = ref Env.empty -let printing_pers = ref Concr.empty +let printing_pers = ref Compilation_unit.Name.Set.empty (** {!printing_old} and {!printing_pers} are the keys of the one-slot cache *) let printing_depth = ref 0 @@ -612,34 +646,30 @@ let printing_map = ref Path.Map.empty the {!printing_map} one level further (see also {!Env.run_iter_cont}) *) -let same_type t t' = repr t == repr t' - let rec index l x = match l with [] -> raise Not_found - | a :: l -> if x == a then 0 else 1 + index l x + | a :: l -> if eq_type x a then 0 else 1 + index l x let rec uniq = function [] -> true - | a :: l -> not (List.memq a l) && uniq l + | a :: l -> not (List.memq (a : int) l) && uniq l let rec normalize_type_path ?(cache=false) env p = try let (params, ty, _) = Env.find_type_expansion p env in - let params = List.map repr params in - match repr ty with - {desc = Tconstr (p1, tyl, _)} -> - let tyl = List.map repr tyl in + match get_desc ty with + Tconstr (p1, tyl, _) -> if List.length params = List.length tyl - && List.for_all2 (==) params tyl + && List.for_all2 eq_type params tyl then normalize_type_path ~cache env p1 else if cache || List.length params <= List.length tyl - || not (uniq tyl) then (p, Id) + || not (uniq (List.map get_id tyl)) then (p, Id) else let l1 = List.map (index params) tyl in let (p2, s2) = normalize_type_path ~cache env p1 in (p2, compose l1 s2) - | ty -> + | _ -> (p, Nth (index params ty)) with Not_found -> @@ -664,7 +694,8 @@ let rec path_size = function let same_printing_env env = let used_pers = Env.used_persistent () in - Env.same_types !printing_old env && Concr.equal !printing_pers used_pers + Env.same_types !printing_old env + && Compilation_unit.Name.Set.equal !printing_pers used_pers let set_printing_env env = printing_env := env; @@ -763,224 +794,342 @@ let best_type_path p = (* Print a type expression *) -let names = ref ([] : (type_expr * string) list) -let name_counter = ref 0 -let named_vars = ref ([] : string list) +let proxy ty = Transient_expr.repr (proxy ty) -let weak_counter = ref 1 -let weak_var_map = ref TypeMap.empty -let named_weak_vars = ref String.Set.empty +(* When printing a type scheme, we print weak names. When printing a plain + type, we do not. This type controls that behavior *) +type type_or_scheme = Type | Type_scheme -let reset_names () = names := []; name_counter := 0; named_vars := [] -let add_named_var ty = - match ty.desc with - Tvar (Some name) | Tunivar (Some name) -> - if List.mem name !named_vars then () else - named_vars := name :: !named_vars - | _ -> () +let is_non_gen mode ty = + match mode with + | Type_scheme -> is_Tvar ty && get_level ty <> generic_level + | Type -> false -let name_is_already_used name = - List.mem name !named_vars - || List.exists (fun (_, name') -> name = name') !names - || String.Set.mem name !named_weak_vars - -let rec new_name () = - let name = - if !name_counter < 26 - then String.make 1 (Char.chr(97 + !name_counter)) - else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^ - Int.to_string(!name_counter / 26) in - incr name_counter; - if name_is_already_used name then new_name () else name - -let rec new_weak_name ty () = - let name = "weak" ^ Int.to_string !weak_counter in - incr weak_counter; - if name_is_already_used name then new_weak_name ty () - else begin - named_weak_vars := String.Set.add name !named_weak_vars; - weak_var_map := TypeMap.add ty name !weak_var_map; - name +let nameable_row row = + row_name row <> None && + List.for_all + (fun (_, f) -> + match row_field_repr f with + | Reither(c, l, _) -> + row_closed row && if c then l = [] else List.length l = 1 + | _ -> true) + (row_fields row) + +(* This specialized version of [Btype.iter_type_expr] normalizes and + short-circuits the traversal of the [type_expr], so that it covers only the + subterms that would be printed by the type printer. *) +let printer_iter_type_expr f ty = + match get_desc ty with + | Tconstr(p, tyl, _) -> + let (_p', s) = best_type_path p in + List.iter f (apply_subst s tyl) + | Tvariant row -> begin + match row_name row with + | Some(_p, tyl) when nameable_row row -> + List.iter f tyl + | _ -> + iter_row f row + end + | Tobject (fi, nm) -> begin + match !nm with + | None -> + let fields, _ = flatten_fields fi in + List.iter + (fun (_, kind, ty) -> + if field_kind_repr kind = Fpublic then + f ty) + fields + | Some (_, l) -> + List.iter f (List.tl l) end + | Tfield(_, kind, ty1, ty2) -> + if field_kind_repr kind = Fpublic then + f ty1; + f ty2 + | _ -> + Btype.iter_type_expr f ty -let name_of_type name_generator t = - (* We've already been through repr at this stage, so t is our representative - of the union-find class. *) - try List.assq t !names with Not_found -> - try TypeMap.find t !weak_var_map with Not_found -> - let name = - match t.desc with - Tvar (Some name) | Tunivar (Some name) -> - (* Some part of the type we've already printed has assigned another - * unification variable to that name. We want to keep the name, so try - * adding a number until we find a name that's not taken. *) - let current_name = ref name in - let i = ref 0 in - while List.exists (fun (_, name') -> !current_name = name') !names do - current_name := name ^ (Int.to_string !i); - i := !i + 1; - done; - !current_name +module Names : sig + val reset_names : unit -> unit + + val add_named_vars : type_expr -> unit + val add_subst : (type_expr * type_expr) list -> unit + + val new_name : unit -> string + val new_weak_name : type_expr -> unit -> string + + val name_of_type : (unit -> string) -> transient_expr -> string + val check_name_of_type : transient_expr -> unit + + val remove_names : transient_expr list -> unit + + val with_local_names : (unit -> 'a) -> 'a + + (* Refresh the weak variable map in the toplevel; for [print_items], which is + itself for the toplevel *) + val refresh_weak : unit -> unit +end = struct + (* We map from types to names, but not directly; we also store a substitution, + which maps from types to types. The lookup process is + "type -> apply substitution -> find name". The substitution is presumed to + be acyclic. *) + let names = ref ([] : (transient_expr * string) list) + let name_subst = ref ([] : (transient_expr * transient_expr) list) + let name_counter = ref 0 + let named_vars = ref ([] : string list) + let visited_for_named_vars = ref ([] : transient_expr list) + + let weak_counter = ref 1 + let weak_var_map = ref TypeMap.empty + let named_weak_vars = ref String.Set.empty + + let reset_names () = + names := []; + name_subst := []; + name_counter := 0; + named_vars := []; + visited_for_named_vars := [] + + let add_named_var tty = + match tty.desc with + Tvar (Some name) | Tunivar (Some name) -> + if List.mem name !named_vars then () else + named_vars := name :: !named_vars + | _ -> () + + let rec add_named_vars ty = + let tty = Transient_expr.repr ty in + let px = proxy ty in + if not (List.memq px !visited_for_named_vars) then begin + visited_for_named_vars := px :: !visited_for_named_vars; + match tty.desc with + | Tvar _ | Tunivar _ -> + add_named_var tty | _ -> - (* No name available, create a new one *) - name_generator () - in - (* Exception for type declarations *) - if name <> "_" then names := (t, name) :: !names; - name + printer_iter_type_expr add_named_vars ty + end + + let rec substitute ty = + match List.assq ty !name_subst with + | ty' -> substitute ty' + | exception Not_found -> ty -let check_name_of_type t = ignore(name_of_type new_name t) + let add_subst subst = + name_subst := + List.map (fun (t1,t2) -> Transient_expr.repr t1, Transient_expr.repr t2) + subst + @ !name_subst -let remove_names tyl = - let tyl = List.map repr tyl in - names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names + let name_is_already_used name = + List.mem name !named_vars + || List.exists (fun (_, name') -> name = name') !names + || String.Set.mem name !named_weak_vars -let visited_objects = ref ([] : type_expr list) -let aliased = ref ([] : type_expr list) -let delayed = ref ([] : type_expr list) + let rec new_name () = + let name = + if !name_counter < 26 + then String.make 1 (Char.chr(97 + !name_counter)) + else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^ + Int.to_string(!name_counter / 26) in + incr name_counter; + if name_is_already_used name then new_name () else name + + let rec new_weak_name ty () = + let name = "weak" ^ Int.to_string !weak_counter in + incr weak_counter; + if name_is_already_used name then new_weak_name ty () + else begin + named_weak_vars := String.Set.add name !named_weak_vars; + weak_var_map := TypeMap.add ty name !weak_var_map; + name + end + + let name_of_type name_generator t = + (* We've already been through repr at this stage, so t is our representative + of the union-find class. *) + let t = substitute t in + try List.assq t !names with Not_found -> + try TransientTypeMap.find t !weak_var_map with Not_found -> + let name = + match t.desc with + Tvar (Some name) | Tunivar (Some name) -> + (* Some part of the type we've already printed has assigned another + * unification variable to that name. We want to keep the name, so + * try adding a number until we find a name that's not taken. *) + let current_name = ref name in + let i = ref 0 in + while List.exists + (fun (_, name') -> !current_name = name') + !names + do + current_name := name ^ (Int.to_string !i); + i := !i + 1; + done; + !current_name + | _ -> + (* No name available, create a new one *) + name_generator () + in + (* Exception for type declarations *) + if name <> "_" then names := (t, name) :: !names; + name + + let check_name_of_type t = ignore(name_of_type new_name t) + + let remove_names tyl = + let tyl = List.map substitute tyl in + names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !names + + let with_local_names f = + let old_names = !names in + let old_subst = !name_subst in + names := []; + name_subst := []; + try_finally + ~always:(fun () -> + names := old_names; + name_subst := old_subst) + f + + let refresh_weak () = + let refresh t name (m,s) = + if is_non_gen Type_scheme t then + begin + TypeMap.add t name m, + String.Set.add name s + end + else m, s in + let m, s = + TypeMap.fold refresh !weak_var_map (TypeMap.empty ,String.Set.empty) in + named_weak_vars := s; + weak_var_map := m +end + +let reserve_names ty = + normalize_type ty; + Names.add_named_vars ty + +let visited_objects = ref ([] : transient_expr list) +let aliased = ref ([] : transient_expr list) +let delayed = ref ([] : transient_expr list) +let printed_aliases = ref ([] : transient_expr list) + +(* [printed_aliases] is a subset of [aliased] that records only those aliased + types that have actually been printed; this allows us to avoid naming loops + that the user will never see. *) let add_delayed t = if not (List.memq t !delayed) then delayed := t :: !delayed -let is_aliased ty = List.memq (proxy ty) !aliased -let add_alias ty = - let px = proxy ty in - if not (is_aliased px) then begin - aliased := px :: !aliased; - add_named_var px - end +let is_aliased_proxy px = List.memq px !aliased + +let add_alias_proxy px = + if not (is_aliased_proxy px) then + aliased := px :: !aliased + +let add_alias ty = add_alias_proxy (proxy ty) + +let add_printed_alias_proxy px = + Names.check_name_of_type px; + printed_aliases := px :: !printed_aliases + +let add_printed_alias ty = add_printed_alias_proxy (proxy ty) let aliasable ty = - match ty.desc with + match get_desc ty with Tvar _ | Tunivar _ | Tpoly _ -> false | Tconstr (p, _, _) -> not (is_nth (snd (best_type_path p))) | _ -> true -let namable_row row = - row.row_name <> None && - List.for_all - (fun (_, f) -> - match row_field_repr f with - | Reither(c, l, _, _) -> - row.row_closed && if c then l = [] else List.length l = 1 - | _ -> true) - row.row_fields +let should_visit_object ty = + match get_desc ty with + | Tvariant row -> not (static_row row) + | Tobject _ -> opened_object ty + | _ -> false let rec mark_loops_rec visited ty = - let ty = repr ty in let px = proxy ty in - if List.memq px visited && aliasable ty then add_alias px else + if List.memq px visited && aliasable ty then add_alias_proxy px else + let tty = Transient_expr.repr ty in let visited = px :: visited in - match ty.desc with - | Tvar _ -> add_named_var ty - | Tarrow(_, ty1, ty2, _) -> - mark_loops_rec visited ty1; mark_loops_rec visited ty2 - | Ttuple tyl -> List.iter (mark_loops_rec visited) tyl - | Tconstr(p, tyl, _) -> - let (_p', s) = best_type_path p in - List.iter (mark_loops_rec visited) (apply_subst s tyl) - | Tpackage (_, _, tyl) -> - List.iter (mark_loops_rec visited) tyl - | Tvariant row -> - if List.memq px !visited_objects then add_alias px else - begin - let row = row_repr row in - if not (static_row row) then - visited_objects := px :: !visited_objects; - match row.row_name with - | Some(_p, tyl) when namable_row row -> - List.iter (mark_loops_rec visited) tyl - | _ -> - iter_row (mark_loops_rec visited) row - end - | Tobject (fi, nm) -> - if List.memq px !visited_objects then add_alias px else - begin - if opened_object ty then + match tty.desc with + | Tvariant _ | Tobject _ -> + if List.memq px !visited_objects then add_alias_proxy px else begin + if should_visit_object ty then visited_objects := px :: !visited_objects; - begin match !nm with - | None -> - let fields, _ = flatten_fields fi in - List.iter - (fun (_, kind, ty) -> - if field_kind_repr kind = Fpresent then - mark_loops_rec visited ty) - fields - | Some (_, l) -> - List.iter (mark_loops_rec visited) (List.tl l) - end + printer_iter_type_expr (mark_loops_rec visited) ty end - | Tfield(_, kind, ty1, ty2) when field_kind_repr kind = Fpresent -> - mark_loops_rec visited ty1; mark_loops_rec visited ty2 - | Tfield(_, _, _, ty2) -> - mark_loops_rec visited ty2 - | Tnil -> () - | Tsubst ty -> mark_loops_rec visited ty - | Tlink _ -> fatal_error "Printtyp.mark_loops_rec (2)" - | Tpoly (ty, tyl) -> - List.iter (fun t -> add_alias t) tyl; + | Tpoly(ty, tyl) -> + List.iter add_alias tyl; mark_loops_rec visited ty - | Tunivar _ -> add_named_var ty + | _ -> + printer_iter_type_expr (mark_loops_rec visited) ty let mark_loops ty = - normalize_type ty; mark_loops_rec [] ty;; +let prepare_type ty = + reserve_names ty; + mark_loops ty;; + let reset_loop_marks () = - visited_objects := []; aliased := []; delayed := [] + visited_objects := []; aliased := []; delayed := []; printed_aliases := [] let reset_except_context () = - reset_names (); reset_loop_marks () + Names.reset_names (); reset_loop_marks () let reset () = reset_naming_context (); Conflicts.reset (); reset_except_context () -let reset_and_mark_loops ty = - reset_except_context (); mark_loops ty +let prepare_for_printing tyl = + reset_except_context (); + List.iter prepare_type tyl -let reset_and_mark_loops_list tyl = - reset_except_context (); List.iter mark_loops tyl +let add_type_to_preparation = prepare_type (* Disabled in classic mode when printing an unification error *) let print_labels = ref true -let rec tree_of_typexp sch ty = - let ty = repr ty in +let rec tree_of_typexp mode ty = let px = proxy ty in - if List.mem_assq px !names && not (List.memq px !delayed) then - let mark = is_non_gen sch ty in - let name = name_of_type (if mark then new_weak_name ty else new_name) px in + if List.memq px !printed_aliases && not (List.memq px !delayed) then + let mark = is_non_gen mode ty in + let name = Names.name_of_type + (if mark then Names.new_weak_name ty else Names.new_name) + px + in Otyp_var (mark, name) else let pr_typ () = - match ty.desc with + let tty = Transient_expr.repr ty in + match tty.desc with | Tvar _ -> - (*let lev = - if is_non_gen sch ty then "/" ^ Int.to_string ty.level else "" in*) - let non_gen = is_non_gen sch ty in - let name_gen = if non_gen then new_weak_name ty else new_name in - Otyp_var (non_gen, name_of_type name_gen ty) + let non_gen = is_non_gen mode ty in + let name_gen = if non_gen then Names.new_weak_name ty else Names.new_name in + Otyp_var (non_gen, Names.name_of_type name_gen tty) | Tarrow ((l, marg, mret), ty1, ty2, _) -> let lab = if !print_labels || is_optional l then string_of_label l else "" in let t1 = if is_optional l then - match (repr ty1).desc with + match get_desc (tpoly_get_mono ty1) with | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> - tree_of_typexp sch ty + tree_of_typexp mode ty | _ -> Otyp_stuff "" - else tree_of_typexp sch ty1 in + else + tree_of_typexp mode ty1 + in let am = match Alloc_mode.check_const marg with | Some Global -> Oam_global | Some Local -> Oam_local | None -> Oam_unknown in - let t2 = tree_of_typexp sch ty2 in + let t2 = tree_of_typexp mode ty2 in let rm = match Alloc_mode.check_const mret with | Some Global -> Oam_global @@ -989,19 +1138,20 @@ let rec tree_of_typexp sch ty = in Otyp_arrow (lab, am, t1, rm, t2) | Ttuple tyl -> - Otyp_tuple (tree_of_typlist sch tyl) + Otyp_tuple (tree_of_typlist mode tyl) | Tconstr(p, tyl, _abbrev) -> let p', s = best_type_path p in let tyl' = apply_subst s tyl in - if is_nth s && not (tyl'=[]) then tree_of_typexp sch (List.hd tyl') else - Otyp_constr (tree_of_path Type p', tree_of_typlist sch tyl') + if is_nth s && not (tyl'=[]) + then tree_of_typexp mode (List.hd tyl') + else Otyp_constr (tree_of_path Type p', tree_of_typlist mode tyl') | Tvariant row -> - let row = row_repr row in + let Row {fields; name; closed} = row_repr row in let fields = - if row.row_closed then + if closed then List.filter (fun (_, f) -> row_field_repr f <> Rabsent) - row.row_fields - else row.row_fields in + fields + else fields in let present = List.filter (fun (_, f) -> @@ -1010,81 +1160,96 @@ let rec tree_of_typexp sch ty = | _ -> false) fields in let all_present = List.length present = List.length fields in - begin match row.row_name with - | Some(p, tyl) when namable_row row -> + begin match name with + | Some(p, tyl) when nameable_row row -> let (p', s) = best_type_path p in let id = tree_of_path Type p' in - let args = tree_of_typlist sch (apply_subst s tyl) in + let args = tree_of_typlist mode (apply_subst s tyl) in let out_variant = if is_nth s then List.hd args else Otyp_constr (id, args) in - if row.row_closed && all_present then + if closed && all_present then out_variant else - let non_gen = is_non_gen sch px in + let non_gen = is_non_gen mode (Transient_expr.type_expr px) in let tags = if all_present then None else Some (List.map fst present) in - Otyp_variant (non_gen, Ovar_typ out_variant, row.row_closed, tags) + Otyp_variant (non_gen, Ovar_typ out_variant, closed, tags) | _ -> let non_gen = - not (row.row_closed && all_present) && is_non_gen sch px in - let fields = List.map (tree_of_row_field sch) fields in + not (closed && all_present) && + is_non_gen mode (Transient_expr.type_expr px) in + let fields = List.map (tree_of_row_field mode) fields in let tags = if all_present then None else Some (List.map fst present) in - Otyp_variant (non_gen, Ovar_fields fields, row.row_closed, tags) + Otyp_variant (non_gen, Ovar_fields fields, closed, tags) end | Tobject (fi, nm) -> - tree_of_typobject sch fi !nm + tree_of_typobject mode fi !nm | Tnil | Tfield _ -> - tree_of_typobject sch ty None - | Tsubst ty -> - tree_of_typexp sch ty + tree_of_typobject mode ty None + | Tsubst _ -> + (* This case should only happen when debugging the compiler *) + Otyp_stuff "" | Tlink _ -> fatal_error "Printtyp.tree_of_typexp" | Tpoly (ty, []) -> - tree_of_typexp sch ty + tree_of_typexp mode ty | Tpoly (ty, tyl) -> (*let print_names () = List.iter (fun (_, name) -> prerr_string (name ^ " ")) !names; prerr_string "; " in *) - let tyl = List.map repr tyl in - if tyl = [] then tree_of_typexp sch ty else begin + if tyl = [] then tree_of_typexp mode ty else begin + let tyl = List.map Transient_expr.repr tyl in let old_delayed = !delayed in (* Make the names delayed, so that the real type is printed once when used as proxy *) List.iter add_delayed tyl; - let tl = List.map (name_of_type new_name) tyl in - let tr = Otyp_poly (tl, tree_of_typexp sch ty) in + let tl = List.map (Names.name_of_type Names.new_name) tyl in + let tr = Otyp_poly (tl, tree_of_typexp mode ty) in (* Forget names when we leave scope *) - remove_names tyl; + Names.remove_names tyl; delayed := old_delayed; tr end | Tunivar _ -> - Otyp_var (false, name_of_type new_name ty) - | Tpackage (p, n, tyl) -> - let n = - List.map (fun li -> String.concat "." (Longident.flatten li)) n in - Otyp_module (tree_of_path Module_type p, n, tree_of_typlist sch tyl) + Otyp_var (false, Names.name_of_type Names.new_name tty) + | Tpackage (p, fl) -> + let fl = + List.map + (fun (li, ty) -> ( + String.concat "." (Longident.flatten li), + tree_of_typexp mode ty + )) fl in + Otyp_module (tree_of_path Module_type p, fl) in if List.memq px !delayed then delayed := List.filter ((!=) px) !delayed; - if is_aliased px && aliasable ty then begin - check_name_of_type px; - Otyp_alias (pr_typ (), name_of_type new_name px) end + if is_aliased_proxy px && aliasable ty then begin + add_printed_alias_proxy px; + Otyp_alias (pr_typ (), Names.name_of_type Names.new_name px) end else pr_typ () -and tree_of_row_field sch (l, f) = +and tree_of_row_field mode (l, f) = match row_field_repr f with - | Rpresent None | Reither(true, [], _, _) -> (l, false, []) - | Rpresent(Some ty) -> (l, false, [tree_of_typexp sch ty]) - | Reither(c, tyl, _, _) -> + | Rpresent None | Reither(true, [], _) -> (l, false, []) + | Rpresent(Some ty) -> (l, false, [tree_of_typexp mode ty]) + | Reither(c, tyl, _) -> if c (* contradiction: constant constructor with an argument *) - then (l, true, tree_of_typlist sch tyl) - else (l, false, tree_of_typlist sch tyl) + then (l, true, tree_of_typlist mode tyl) + else (l, false, tree_of_typlist mode tyl) | Rabsent -> (l, false, [] (* actually, an error *)) -and tree_of_typlist sch tyl = - List.map (tree_of_typexp sch) tyl +and tree_of_typlist mode tyl = + List.map (tree_of_typexp mode) tyl -and tree_of_typobject sch fi nm = +and tree_of_typ_gf (ty, gf) = + let gf = + match gf with + | Global -> Ogf_global + | Nonlocal -> Ogf_nonlocal + | Unrestricted -> Ogf_unrestricted + in + (tree_of_typexp Type ty, gf) + +and tree_of_typobject mode fi nm = begin match nm with | None -> let pr_fields fi = @@ -1093,18 +1258,18 @@ and tree_of_typobject sch fi nm = List.fold_right (fun (n, k, t) l -> match field_kind_repr k with - | Fpresent -> (n, t) :: l + | Fpublic -> (n, t) :: l | _ -> l) fields [] in let sorted_fields = List.sort (fun (n, _) (n', _) -> String.compare n n') present_fields in - tree_of_typfields sch rest sorted_fields in + tree_of_typfields mode rest sorted_fields in let (fields, rest) = pr_fields fi in Otyp_object (fields, rest) | Some (p, ty :: tyl) -> - let non_gen = is_non_gen sch (repr ty) in - let args = tree_of_typlist sch tyl in + let non_gen = is_non_gen mode ty in + let args = tree_of_typlist mode tyl in let (p', s) = best_type_path p in assert (s = Id); Otyp_class (non_gen, tree_of_path Type p', args) @@ -1112,38 +1277,46 @@ and tree_of_typobject sch fi nm = fatal_error "Printtyp.tree_of_typobject" end -and is_non_gen sch ty = - sch && is_Tvar ty && ty.level <> generic_level - -and tree_of_typfields sch rest = function +and tree_of_typfields mode rest = function | [] -> let rest = - match rest.desc with - | Tvar _ | Tunivar _ -> Some (is_non_gen sch rest) + match get_desc rest with + | Tvar _ | Tunivar _ -> Some (is_non_gen mode rest) | Tconstr _ -> Some false | Tnil -> None | _ -> fatal_error "typfields (1)" in ([], rest) | (s, t) :: l -> - let field = (s, tree_of_typexp sch t) in - let (fields, rest) = tree_of_typfields sch rest l in + let field = (s, tree_of_typexp mode t) in + let (fields, rest) = tree_of_typfields mode rest l in (field :: fields, rest) -let typexp sch ppf ty = - !Oprint.out_type ppf (tree_of_typexp sch ty) +let typexp mode ppf ty = + !Oprint.out_type ppf (tree_of_typexp mode ty) -let marked_type_expr ppf ty = typexp false ppf ty +let prepared_type_expr ppf ty = typexp Type ppf ty let type_expr ppf ty = (* [type_expr] is used directly by error message printers, we mark eventual loops ourself to avoid any misuse and stack overflow *) - reset_and_mark_loops ty; - marked_type_expr ppf ty + prepare_for_printing [ty]; + prepared_type_expr ppf ty + +(* "Half-prepared" type expression: [ty] should have had its names reserved, but + should not have had its loops marked. *) +let type_expr_with_reserved_names ppf ty = + reset_loop_marks (); + mark_loops ty; + prepared_type_expr ppf ty -and type_sch ppf ty = typexp true ppf ty +let shared_type_scheme ppf ty = + prepare_type ty; + typexp Type_scheme ppf ty -and type_scheme ppf ty = reset_and_mark_loops ty; typexp true ppf ty +let type_scheme ppf ty = + prepare_for_printing [ty]; + typexp Type_scheme ppf ty let type_path ppf p = let (p', s) = best_type_path p in @@ -1151,13 +1324,9 @@ let type_path ppf p = let t = tree_of_path Type p in !Oprint.out_ident ppf t -(* Maxence *) -let type_scheme_max ?(b_reset_names=true) ppf ty = - if b_reset_names then reset_names () ; - typexp true ppf ty -(* End Maxence *) - -let tree_of_type_scheme ty = reset_and_mark_loops ty; tree_of_typexp true ty +let tree_of_type_scheme ty = + prepare_for_printing [ty]; + tree_of_typexp Type_scheme ty (* Print one type declaration *) @@ -1166,8 +1335,8 @@ let tree_of_constraints params = (fun ty list -> let ty' = unalias ty in if proxy ty != proxy ty' then - let tr = tree_of_typexp true ty in - (tr, tree_of_typexp true ty') :: list + let tr = tree_of_typexp Type_scheme ty in + (tr, tree_of_typexp Type_scheme ty') :: list else list) params [] @@ -1175,15 +1344,19 @@ let filter_params tyl = let params = List.fold_left (fun tyl ty -> - let ty = repr ty in - if List.memq ty tyl then Btype.newgenty (Tsubst ty) :: tyl + if List.exists (eq_type ty) tyl + then newty2 ~level:generic_level (Ttuple [ty]) :: tyl else ty :: tyl) + (* Two parameters might be identical due to a constraint but we need to + print them differently in order to make the output syntactically valid. + We use [Ttuple [ty]] because it is printed as [ty]. *) + (* Replacing fold_left by fold_right does not work! *) [] tyl in List.rev params -let mark_loops_constructor_arguments = function - | Cstr_tuple l -> List.iter mark_loops l - | Cstr_record l -> List.iter (fun l -> mark_loops l.ld_type) l +let prepare_type_constructor_arguments = function + | Cstr_tuple l -> List.iter (fun (ty, _) -> prepare_type ty) l + | Cstr_record l -> List.iter (fun l -> prepare_type l.ld_type) l let rec tree_of_type_decl id decl = @@ -1195,44 +1368,44 @@ let rec tree_of_type_decl id decl = | Some ty -> let vars = free_variables ty in List.iter - (function {desc = Tvar (Some "_")} as ty -> - if List.memq ty vars then ty.desc <- Tvar None - | _ -> ()) + (fun ty -> + if get_desc ty = Tvar (Some "_") && List.exists (eq_type ty) vars + then set_type_desc ty (Tvar None)) params | None -> () end; List.iter add_alias params; - List.iter mark_loops params; - List.iter check_name_of_type (List.map proxy params); + List.iter prepare_type params; + List.iter add_printed_alias params; let ty_manifest = match decl.type_manifest with | None -> None | Some ty -> let ty = (* Special hack to hide variant name *) - match repr ty with {desc=Tvariant row} -> - let row = row_repr row in - begin match row.row_name with - Some (Pident id', _) when Ident.same id id' -> - newgenty (Tvariant {row with row_name = None}) - | _ -> ty - end + match get_desc ty with + Tvariant row -> + begin match row_name row with + Some (Pident id', _) when Ident.same id id' -> + newgenty (Tvariant (set_row_name row None)) + | _ -> ty + end | _ -> ty in - mark_loops ty; + prepare_type ty; Some ty in begin match decl.type_kind with | Type_abstract -> () - | Type_variant cstrs -> + | Type_variant (cstrs, _rep) -> List.iter (fun c -> - mark_loops_constructor_arguments c.cd_args; - Option.iter mark_loops c.cd_res) + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res) cstrs | Type_record(l, _rep) -> - List.iter (fun l -> mark_loops l.ld_type) l + List.iter (fun l -> prepare_type l.ld_type) l | Type_open -> () end; @@ -1248,7 +1421,7 @@ let rec tree_of_type_decl id decl = decl.type_manifest = None || decl.type_private = Private | Type_record _ -> decl.type_private = Private - | Type_variant tll -> + | Type_variant (tll, _rep) -> decl.type_private = Private || List.exists (fun cd -> cd.cd_res <> None) tll | Type_open -> @@ -1257,7 +1430,7 @@ let rec tree_of_type_decl id decl = let vari = List.map2 (fun ty v -> - let is_var = is_Tvar (repr ty) in + let is_var = is_Tvar ty in if abstr || not is_var then let inj = decl.type_kind = Type_abstract && Variance.mem Inj v && @@ -1274,58 +1447,67 @@ let rec tree_of_type_decl id decl = decl.type_params decl.type_variance in (Ident.name id, - List.map2 (fun ty cocn -> type_param (tree_of_typexp false ty), cocn) + List.map2 (fun ty cocn -> type_param (tree_of_typexp Type ty), cocn) params vari) in let tree_of_manifest ty1 = match ty_manifest with | None -> ty1 - | Some ty -> Otyp_manifest (tree_of_typexp false ty, ty1) + | Some ty -> Otyp_manifest (tree_of_typexp Type ty, ty1) in let (name, args) = type_defined decl in let constraints = tree_of_constraints params in - let ty, priv = + let ty, priv, unboxed = match decl.type_kind with | Type_abstract -> begin match ty_manifest with - | None -> (Otyp_abstract, Public) + | None -> (Otyp_abstract, Public, false) | Some ty -> - tree_of_typexp false ty, decl.type_private + tree_of_typexp Type ty, decl.type_private, false end - | Type_variant cstrs -> + | Type_variant (cstrs, rep) -> tree_of_manifest (Otyp_sum (List.map tree_of_constructor cstrs)), - decl.type_private - | Type_record(lbls, _rep) -> + decl.type_private, + (rep = Variant_unboxed) + | Type_record(lbls, rep) -> tree_of_manifest (Otyp_record (List.map tree_of_label lbls)), - decl.type_private + decl.type_private, + (match rep with Record_unboxed _ -> true | _ -> false) | Type_open -> tree_of_manifest Otyp_open, - decl.type_private + decl.type_private, + false in { otype_name = name; otype_params = args; otype_type = ty; otype_private = priv; otype_immediate = Type_immediacy.of_attributes decl.type_attributes; - otype_unboxed = decl.type_unboxed.unboxed; + otype_unboxed = unboxed; otype_cstrs = constraints } and tree_of_constructor_arguments = function - | Cstr_tuple l -> tree_of_typlist false l - | Cstr_record l -> [ Otyp_record (List.map tree_of_label l) ] + | Cstr_tuple l -> List.map tree_of_typ_gf l + | Cstr_record l -> [ Otyp_record (List.map tree_of_label l), Ogf_unrestricted ] and tree_of_constructor cd = let name = Ident.name cd.cd_id in let arg () = tree_of_constructor_arguments cd.cd_args in match cd.cd_res with - | None -> (name, arg (), None) + | None -> { + ocstr_name = name; + ocstr_args = arg (); + ocstr_return_type = None; + } | Some res -> - let nm = !names in - names := []; - let ret = tree_of_typexp false res in - let args = arg () in - names := nm; - (name, args, Some ret) + Names.with_local_names (fun () -> + let ret = tree_of_typexp Type res in + let args = arg () in + { + ocstr_name = name; + ocstr_args = args; + ocstr_return_type = Some ret; + }) and tree_of_label l = let gom = @@ -1335,14 +1517,17 @@ and tree_of_label l = | Immutable, Nonlocal -> Ogom_nonlocal | Immutable, Unrestricted -> Ogom_immutable in - (Ident.name l.ld_id, gom, tree_of_typexp false l.ld_type) + (Ident.name l.ld_id, gom, tree_of_typexp Type l.ld_type) let constructor ppf c = reset_except_context (); + prepare_type_constructor_arguments c.cd_args; + Option.iter prepare_type c.cd_res; !Oprint.out_constr ppf (tree_of_constructor c) let label ppf l = reset_except_context (); + prepare_type l.ld_type; !Oprint.out_label ppf (tree_of_label l) let tree_of_type_declaration id decl rs = @@ -1353,7 +1538,7 @@ let type_declaration id ppf decl = let constructor_arguments ppf a = let tys = tree_of_constructor_arguments a in - !Oprint.out_type ppf (Otyp_tuple tys) + !Oprint.out_constr_args ppf tys (* Print an extension declaration *) @@ -1361,29 +1546,27 @@ let extension_constructor_args_and_ret_type_subtree ext_args ext_ret_type = match ext_ret_type with | None -> (tree_of_constructor_arguments ext_args, None) | Some res -> - let nm = !names in - names := []; - let ret = tree_of_typexp false res in - let args = tree_of_constructor_arguments ext_args in - names := nm; - (args, Some ret) + Names.with_local_names (fun () -> + let ret = tree_of_typexp Type res in + let args = tree_of_constructor_arguments ext_args in + (args, Some ret)) let tree_of_extension_constructor id ext es = reset_except_context (); let ty_name = Path.name ext.ext_type_path in let ty_params = filter_params ext.ext_type_params in List.iter add_alias ty_params; - List.iter mark_loops ty_params; - List.iter check_name_of_type (List.map proxy ty_params); - mark_loops_constructor_arguments ext.ext_args; - Option.iter mark_loops ext.ext_ret_type; + List.iter prepare_type ty_params; + List.iter add_printed_alias ty_params; + prepare_type_constructor_arguments ext.ext_args; + Option.iter prepare_type ext.ext_ret_type; let type_param = function | Otyp_var (_, id) -> id | _ -> "?" in let ty_params = - List.map (fun ty -> type_param (tree_of_typexp false ty)) ty_params + List.map (fun ty -> type_param (tree_of_typexp Type ty)) ty_params in let name = Ident.name id in let args, ret = @@ -1412,6 +1595,8 @@ let extension_constructor id ppf ext = let extension_only_constructor id ppf ext = reset_except_context (); + prepare_type_constructor_arguments ext.ext_args; + Option.iter prepare_type ext.ext_ret_type; let name = Ident.name id in let args, ret = extension_constructor_args_and_ret_type_subtree @@ -1419,7 +1604,11 @@ let extension_only_constructor id ppf ext = ext.ext_ret_type in Format.fprintf ppf "@[%a@]" - !Oprint.out_constr (name, args, ret) + !Oprint.out_constr { + ocstr_name = name; + ocstr_args = args; + ocstr_return_type = ret; + } (* Print a value declaration *) @@ -1445,67 +1634,61 @@ let value_description id ppf decl = (* Print a class type *) -let method_type (_, kind, ty) = - match field_kind_repr kind, repr ty with - Fpresent, {desc=Tpoly(ty, tyl)} -> (ty, tyl) - | _ , ty -> (ty, []) - -let tree_of_metho sch concrete csil (lab, kind, ty) = - if lab <> dummy_method then begin - let kind = field_kind_repr kind in - let priv = kind <> Fpresent in - let virt = not (Concr.mem lab concrete) in - let (ty, tyl) = method_type (lab, kind, ty) in - let tty = tree_of_typexp sch ty in - remove_names tyl; - Ocsg_method (lab, priv, virt, tty) :: csil - end - else csil +let method_type priv ty = + match priv, get_desc ty with + | Mpublic, Tpoly(ty, tyl) -> (ty, tyl) + | _ , _ -> (ty, []) + +let prepare_method _lab (priv, _virt, ty) = + let ty, _ = method_type priv ty in + prepare_type ty + +let tree_of_method mode (lab, priv, virt, ty) = + let (ty, tyl) = method_type priv ty in + let tty = tree_of_typexp mode ty in + Names.remove_names (List.map Transient_expr.repr tyl); + let priv = priv <> Mpublic in + let virt = virt = Virtual in + Ocsg_method (lab, priv, virt, tty) let rec prepare_class_type params = function | Cty_constr (_p, tyl, cty) -> - let sty = Ctype.self_type cty in - if List.memq (proxy sty) !visited_objects + let row = Btype.self_type_row cty in + if List.memq (proxy row) !visited_objects || not (List.for_all is_Tvar params) - || List.exists (deep_occur sty) tyl + || List.exists (deep_occur row) tyl then prepare_class_type params cty - else List.iter mark_loops tyl + else List.iter prepare_type tyl | Cty_signature sign -> - let sty = repr sign.csig_self in (* Self may have a name *) - let px = proxy sty in - if List.memq px !visited_objects then add_alias sty + let px = proxy sign.csig_self_row in + if List.memq px !visited_objects then add_alias_proxy px else visited_objects := px :: !visited_objects; - let (fields, _) = - Ctype.flatten_fields (Ctype.object_fields sign.csig_self) - in - List.iter (fun met -> mark_loops (fst (method_type met))) fields; - Vars.iter (fun _ (_, _, ty) -> mark_loops ty) sign.csig_vars + Vars.iter (fun _ (_, _, ty) -> prepare_type ty) sign.csig_vars; + Meths.iter prepare_method sign.csig_meths | Cty_arrow (_, ty, cty) -> - mark_loops ty; + prepare_type ty; prepare_class_type params cty -let rec tree_of_class_type sch params = +let rec tree_of_class_type mode params = function | Cty_constr (p', tyl, cty) -> - let sty = Ctype.self_type cty in - if List.memq (proxy sty) !visited_objects + let row = Btype.self_type_row cty in + if List.memq (proxy row) !visited_objects || not (List.for_all is_Tvar params) then - tree_of_class_type sch params cty + tree_of_class_type mode params cty else let namespace = Namespace.best_class_namespace p' in - Octy_constr (tree_of_path namespace p', tree_of_typlist true tyl) + Octy_constr (tree_of_path namespace p', tree_of_typlist Type_scheme tyl) | Cty_signature sign -> - let sty = repr sign.csig_self in + let px = proxy sign.csig_self_row in let self_ty = - if is_aliased sty then - Some (Otyp_var (false, name_of_type new_name (proxy sty))) + if is_aliased_proxy px then + Some + (Otyp_var (false, Names.name_of_type Names.new_name px)) else None in - let (fields, _) = - Ctype.flatten_fields (Ctype.object_fields sign.csig_self) - in let csil = [] in let csil = List.fold_left @@ -1520,12 +1703,20 @@ let rec tree_of_class_type sch params = let csil = List.fold_left (fun csil (l, m, v, t) -> - Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp sch t) + Ocsg_value (l, m = Mutable, v = Virtual, tree_of_typexp mode t) :: csil) csil all_vars in + let all_meths = + Meths.fold + (fun l (p, v, t) all -> (l, p, v, t) :: all) + sign.csig_meths [] + in + let all_meths = List.rev all_meths in let csil = - List.fold_left (tree_of_metho sch sign.csig_concr) csil fields + List.fold_left + (fun csil meth -> tree_of_method mode meth :: csil) + csil all_meths in Octy_signature (self_ty, List.rev csil) | Cty_arrow (l, ty, cty) -> @@ -1534,24 +1725,24 @@ let rec tree_of_class_type sch params = in let tr = if is_optional l then - match (repr ty).desc with + match get_desc ty with | Tconstr(path, [ty], _) when Path.same path Predef.path_option -> - tree_of_typexp sch ty + tree_of_typexp mode ty | _ -> Otyp_stuff "" - else tree_of_typexp sch ty in - Octy_arrow (lab, tr, tree_of_class_type sch params cty) + else tree_of_typexp mode ty in + Octy_arrow (lab, tr, tree_of_class_type mode params cty) let class_type ppf cty = reset (); prepare_class_type [] cty; - !Oprint.out_class_type ppf (tree_of_class_type false [] cty) + !Oprint.out_class_type ppf (tree_of_class_type Type [] cty) let tree_of_class_param param variance = - (match tree_of_typexp true param with + (match tree_of_typexp Type_scheme param with Otyp_var (_, s) -> s | _ -> "?"), - if is_Tvar (repr param) then Asttypes.(NoVariance, NoInjectivity) - else variance + if is_Tvar param then Asttypes.(NoVariance, NoInjectivity) + else variance let class_variance = let open Variance in let open Asttypes in @@ -1566,50 +1757,47 @@ let tree_of_class_declaration id cl rs = reset_except_context (); List.iter add_alias params; prepare_class_type params cl.cty_type; - let sty = Ctype.self_type cl.cty_type in - List.iter mark_loops params; + let px = proxy (Btype.self_type_row cl.cty_type) in + List.iter prepare_type params; - List.iter check_name_of_type (List.map proxy params); - if is_aliased sty then check_name_of_type (proxy sty); + List.iter add_printed_alias params; + if is_aliased_proxy px then add_printed_alias_proxy px; let vir_flag = cl.cty_new = None in Osig_class (vir_flag, Ident.name id, List.map2 tree_of_class_param params (class_variance cl.cty_variance), - tree_of_class_type true params cl.cty_type, + tree_of_class_type Type_scheme params cl.cty_type, tree_of_rec rs) let class_declaration id ppf cl = !Oprint.out_sig_item ppf (tree_of_class_declaration id cl Trec_first) let tree_of_cltype_declaration id cl rs = - let params = List.map repr cl.clty_params in + let params = cl.clty_params in reset_except_context (); List.iter add_alias params; prepare_class_type params cl.clty_type; - let sty = Ctype.self_type cl.clty_type in - List.iter mark_loops params; - - List.iter check_name_of_type (List.map proxy params); - if is_aliased sty then check_name_of_type (proxy sty); - - let sign = Ctype.signature_of_class_type cl.clty_type in - - let virt = - let (fields, _) = - Ctype.flatten_fields (Ctype.object_fields sign.csig_self) in - List.exists - (fun (lab, _, _) -> - not (lab = dummy_method || Concr.mem lab sign.csig_concr)) - fields - || Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) sign.csig_vars false - in + let px = proxy (Btype.self_type_row cl.clty_type) in + List.iter prepare_type params; + List.iter add_printed_alias params; + if is_aliased_proxy px then add_printed_alias_proxy px; + + let sign = Btype.signature_of_class_type cl.clty_type in + let has_virtual_vars = + Vars.fold (fun _ (_,vr,_) b -> vr = Virtual || b) + sign.csig_vars false + in + let has_virtual_meths = + Meths.fold (fun _ (_,vr,_) b -> vr = Virtual || b) + sign.csig_meths false + in Osig_class_type - (virt, Ident.name id, + (has_virtual_vars || has_virtual_meths, Ident.name id, List.map2 tree_of_class_param params (class_variance cl.clty_variance), - tree_of_class_type true params cl.clty_type, + tree_of_class_type Type_scheme params cl.clty_type, tree_of_rec rs) let cltype_declaration id ppf cl = @@ -1643,15 +1831,6 @@ let wrap_env fenv ftree arg = set_printing_env env; tree -let filter_rem_sig item rem = - match item, rem with - | Sig_class _, ctydecl :: tydecl1 :: tydecl2 :: rem -> - ([ctydecl; tydecl1; tydecl2], rem) - | Sig_class_type _, tydecl1 :: tydecl2 :: rem -> - ([tydecl1; tydecl2], rem) - | _ -> - ([], rem) - let dummy = { type_params = []; @@ -1666,54 +1845,44 @@ let dummy = type_loc = Location.none; type_attributes = []; type_immediate = Unknown; - type_unboxed = unboxed_false_default_false; + type_unboxed_default = false; type_uid = Uid.internal_not_actually_unique; } -let hide ids env = List.fold_right - (fun id -> Env.add_type ~check:false (Ident.rename id) dummy) - ids env - -let hide_rec_items = function - | Sig_type(id, _decl, rs, _) ::rem - when rs = Trec_first && not !Clflags.real_paths -> - let rec get_ids = function - Sig_type (id, _, Trec_next, _) :: rem -> - id :: get_ids rem - | _ -> [] - in - let ids = id :: get_ids rem in - set_printing_env - (hide ids !printing_env) - | _ -> () +(** we hide items being defined from short-path to avoid shortening + [type t = Path.To.t] into [type t = t]. +*) -let recursive_sigitem = function - | Sig_class(id,_,rs,_) -> Some(id,rs,3) - | Sig_class_type (id,_,rs,_) -> Some(id,rs,2) - | Sig_type(id, _, rs, _) - | Sig_module(id, _, _, rs, _) -> Some (id,rs,0) - | _ -> None +let ident_sigitem = function + | Types.Sig_type(ident,_,_,_) -> {hide=true;ident} + | Types.Sig_class(ident,_,_,_) + | Types.Sig_class_type (ident,_,_,_) + | Types.Sig_module(ident,_, _,_,_) + | Types.Sig_value (ident,_,_) + | Types.Sig_modtype (ident,_,_) + | Types.Sig_typext (ident,_,_,_) -> {hide=false; ident } + +let hide ids env = + let hide_id id env = + (* Global idents cannot be renamed *) + if id.hide && not (Ident.is_global_or_predef id.ident) then + Env.add_type ~check:false (Ident.rename id.ident) dummy env + else env + in + List.fold_right hide_id ids env + +let with_hidden_items ids f = + let with_hidden_in_printing_env ids f = + wrap_env (hide ids) (Naming_context.with_hidden ids) f + in + if not !Clflags.real_paths then + with_hidden_in_printing_env ids f + else + Naming_context.with_hidden ids f -let skip k l = snd (Misc.Stdlib.List.split_at k l) -let protect_rec_items items = - let rec get_ids recs = function - | [] -> [] - | item :: rem -> match recursive_sigitem item with - | Some (id, r, k ) when r = recs -> id :: get_ids Trec_next (skip k rem) - | _ -> [] in - List.iter Naming_context.add_protected (get_ids Trec_first items) - -let stop_type_group env = - Naming_context.reset_protected (); - set_printing_env env - -let still_in_type_group env' in_type_group item = - match in_type_group, recursive_sigitem item with - | true, Some (_,Trec_next,_) -> true - | _, Some (_, (Trec_not | Trec_first),_) -> - stop_type_group env' ; true - | _ -> stop_type_group env'; false +let add_sigitem env x = + Env.add_signature (Signature_group.flatten x) env let rec tree_of_modtype ?(ellipsis=false) = function | Mty_ident p -> @@ -1722,61 +1891,77 @@ let rec tree_of_modtype ?(ellipsis=false) = function Omty_signature (if ellipsis then [Osig_ellipsis] else tree_of_signature sg) | Mty_functor(param, ty_res) -> - let param, res = - match param with - | Unit -> None, tree_of_modtype ~ellipsis ty_res - | Named (param, ty_arg) -> - let name, env = - match param with - | None -> None, fun env -> env - | Some id -> - Some (Ident.name id), - Env.add_module ~arg:true id Mp_present ty_arg - in - Some (name, tree_of_modtype ~ellipsis:false ty_arg), - wrap_env env (tree_of_modtype ~ellipsis) ty_res + let param, env = + tree_of_functor_parameter param in + let res = wrap_env env (tree_of_modtype ~ellipsis) ty_res in Omty_functor (param, res) | Mty_alias p -> Omty_alias (tree_of_path Module p) +and tree_of_functor_parameter = function + | Unit -> + None, fun k -> k + | Named (param, ty_arg) -> + let name, env = + match param with + | None -> None, fun env -> env + | Some id -> + Some (Ident.name id), + Env.add_module ~arg:true id Mp_present ty_arg + in + Some (name, tree_of_modtype ~ellipsis:false ty_arg), env + and tree_of_signature sg = - wrap_env (fun env -> env) (tree_of_signature_rec !printing_env false) sg - -and tree_of_signature_rec env' in_type_group = function - [] -> stop_type_group env'; [] - | item :: rem as items -> - let in_type_group = still_in_type_group env' in_type_group item in - let (sg, rem) = filter_rem_sig item rem in - hide_rec_items items; - protect_rec_items items; - reset_naming_context (); - let trees = trees_of_sigitem item in - let env' = Env.add_signature (item :: sg) env' in - trees @ tree_of_signature_rec env' in_type_group rem - -and trees_of_sigitem = function + wrap_env (fun env -> env)(fun sg -> + let tree_groups = tree_of_signature_rec !printing_env sg in + List.concat_map (fun (_env,l) -> List.map snd l) tree_groups + ) sg + +and tree_of_signature_rec env' sg = + let structured = List.of_seq (Signature_group.seq sg) in + let collect_trees_of_rec_group group = + let env = !printing_env in + let env', group_trees = + Naming_context.with_ctx + (fun () -> trees_of_recursive_sigitem_group env group) + in + set_printing_env env'; + (env, group_trees) in + set_printing_env env'; + List.map collect_trees_of_rec_group structured + +and trees_of_recursive_sigitem_group env + (syntactic_group: Signature_group.rec_group) = + let display (x:Signature_group.sig_item) = x.src, tree_of_sigitem x.src in + let env = Env.add_signature syntactic_group.pre_ghosts env in + match syntactic_group.group with + | Not_rec x -> add_sigitem env x, [display x] + | Rec_group items -> + let ids = List.map (fun x -> ident_sigitem x.Signature_group.src) items in + List.fold_left add_sigitem env items, + with_hidden_items ids (fun () -> List.map display items) + +and tree_of_sigitem = function | Sig_value(id, decl, _) -> - [tree_of_value_description id decl] - | Sig_type(id, _, _, _) when is_row_name (Ident.name id) -> - [] + tree_of_value_description id decl | Sig_type(id, decl, rs, _) -> - [tree_of_type_declaration id decl rs] + tree_of_type_declaration id decl rs | Sig_typext(id, ext, es, _) -> - [tree_of_extension_constructor id ext es] + tree_of_extension_constructor id ext es | Sig_module(id, _, md, rs, _) -> let ellipsis = List.exists (function | Parsetree.{attr_name = {txt="..."}; attr_payload = PStr []} -> true | _ -> false) md.md_attributes in - [tree_of_module id md.md_type rs ~ellipsis] + tree_of_module id md.md_type rs ~ellipsis | Sig_modtype(id, decl, _) -> - [tree_of_modtype_declaration id decl] + tree_of_modtype_declaration id decl | Sig_class(id, decl, rs, _) -> - [tree_of_class_declaration id decl rs] + tree_of_class_declaration id decl rs | Sig_class_type(id, decl, rs, _) -> - [tree_of_cltype_declaration id decl rs] + tree_of_cltype_declaration id decl rs and tree_of_modtype_declaration id decl = let mty = @@ -1789,42 +1974,39 @@ and tree_of_modtype_declaration id decl = and tree_of_module id ?ellipsis mty rs = Osig_module (Ident.name id, tree_of_modtype ?ellipsis mty, tree_of_rec rs) +let rec functor_parameters ~sep custom_printer = function + | [] -> ignore + | [id,param] -> + Format.dprintf "%t%t" + (custom_printer param) + (functor_param ~sep ~custom_printer id []) + | (id,param) :: q -> + Format.dprintf "%t%a%t" + (custom_printer param) + sep () + (functor_param ~sep ~custom_printer id q) +and functor_param ~sep ~custom_printer id q = + match id with + | None -> functor_parameters ~sep custom_printer q + | Some id -> + Naming_context.with_arg id + (fun () -> functor_parameters ~sep custom_printer q) + + + let modtype ppf mty = !Oprint.out_module_type ppf (tree_of_modtype mty) let modtype_declaration id ppf decl = !Oprint.out_sig_item ppf (tree_of_modtype_declaration id decl) (* For the toplevel: merge with tree_of_signature? *) -(* Refresh weak variable map in the toplevel *) -let refresh_weak () = - let refresh t name (m,s) = - if is_non_gen true (repr t) then - begin - TypeMap.add t name m, - String.Set.add name s - end - else m, s in - let m, s = - TypeMap.fold refresh !weak_var_map (TypeMap.empty ,String.Set.empty) in - named_weak_vars := s; - weak_var_map := m - let print_items showval env x = - refresh_weak(); + Names.refresh_weak(); reset_naming_context (); Conflicts.reset (); - let rec print showval in_type_group env = function - | [] -> stop_type_group env; [] - | item :: rem as items -> - let in_type_group = still_in_type_group env in_type_group item in - let (sg, rem) = filter_rem_sig item rem in - hide_rec_items items; - protect_rec_items items; - reset_naming_context (); - let trees = trees_of_sigitem item in - List.map (fun d -> (d, showval env item)) trees @ - print showval in_type_group (Env.add_signature (item :: sg) env) rem in - print showval false env x + let extend_val env (sigitem,outcome) = outcome, showval env sigitem in + let post_process (env,l) = List.map (extend_val env) l in + List.concat_map post_process @@ tree_of_signature_rec env x (* Print a signature body (used by -i when compiling a .ml) *) @@ -1850,12 +2032,29 @@ let printed_signature sourcefile ppf sg = end; fprintf ppf "%a" print_signature t -(* Print an unification error *) +(* Trace-specific printing *) + +(* A configuration type that controls which trace we print. This could be + exposed, but we instead expose three separate + [report_{unification,equality,moregen}_error] functions. This also lets us + give the unification case an extra optional argument without adding it to the + equality and moregen cases. *) +type 'variety trace_format = + | Unification : Errortrace.unification trace_format + | Equality : Errortrace.comparison trace_format + | Moregen : Errortrace.comparison trace_format + +let incompatibility_phrase (type variety) : variety trace_format -> string = + function + | Unification -> "is not compatible with type" + | Equality -> "is not equal to type" + | Moregen -> "is not compatible with type" + +(* Print a unification error *) let same_path t t' = - let t = repr t and t' = repr t' in - t == t' || - match t.desc, t'.desc with + eq_type t t' || + match get_desc t, get_desc t' with Tconstr(p,tl,_), Tconstr(p',tl',_) -> let (p1, s1) = best_type_path p and (p2, s2) = best_type_path p' in begin match s1, s2 with @@ -1863,7 +2062,7 @@ let same_path t t' = | (Id | Map _), (Id | Map _) when Path.same p1 p2 -> let tl = apply_subst s1 tl and tl' = apply_subst s2 tl' in List.length tl = List.length tl' && - List.for_all2 same_type tl tl' + List.for_all2 eq_type tl tl' | _ -> false end | _ -> @@ -1871,26 +2070,29 @@ let same_path t t' = type 'a diff = Same of 'a | Diff of 'a * 'a -let trees_of_type_expansion (t,t') = +let trees_of_type_expansion mode Errortrace.{ty = t; expanded = t'} = + reset_loop_marks (); + mark_loops t; if same_path t t' - then begin add_delayed (proxy t); Same (tree_of_typexp false t) end - else + then begin add_delayed (proxy t); Same (tree_of_typexp mode t) end + else begin + mark_loops t'; let t' = if proxy t == proxy t' then unalias t' else t' in (* beware order matter due to side effect, e.g. when printing object types *) - let first = tree_of_typexp false t in - let second = tree_of_typexp false t' in + let first = tree_of_typexp mode t in + let second = tree_of_typexp mode t' in if first = second then Same first else Diff(first,second) + end let type_expansion ppf = function | Same t -> !Oprint.out_type ppf t | Diff(t,t') -> fprintf ppf "@[<2>%a@ =@ %a@]" !Oprint.out_type t !Oprint.out_type t' -module Trace = Ctype.Unification_trace - -let trees_of_trace = List.map (Trace.map_diff trees_of_type_expansion) +let trees_of_trace mode = + List.map (Errortrace.map_diff (trees_of_type_expansion mode)) let trees_of_type_path_expansion (tp,tp') = if Path.same tp tp' then Same(tree_of_path Type tp) else @@ -1904,14 +2106,13 @@ let type_path_expansion ppf = function !Oprint.out_ident p' let rec trace fst txt ppf = function - | {Trace.got; expected} :: rem -> + | {Errortrace.got; expected} :: rem -> if not fst then fprintf ppf "@,"; fprintf ppf "@[Type@;<1 2>%a@ %s@;<1 2>%a@] %a" type_expansion got txt type_expansion expected (trace false txt) rem | _ -> () - type printing_status = | Discard | Keep @@ -1924,36 +2125,48 @@ type printing_status = type error. *) -let printing_status = function - | Trace.(Diff { got=t1, t1'; expected=t2, t2'}) -> - if is_constr_row ~allow_ident:true t1' - || is_constr_row ~allow_ident:true t2' - then Discard - else if same_path t1 t1' && same_path t2 t2' then Optional_refinement - else Keep +let diff_printing_status Errortrace.{ got = {ty = t1; expanded = t1'}; + expected = {ty = t2; expanded = t2'} } = + if is_constr_row ~allow_ident:true t1' + || is_constr_row ~allow_ident:true t2' + then Discard + else if same_path t1 t1' && same_path t2 t2' then Optional_refinement + else Keep + +let printing_status = function + | Errortrace.Diff d -> diff_printing_status d + | Errortrace.Escape {kind = Constraint} -> Keep | _ -> Keep (** Flatten the trace and remove elements that are always discarded during printing *) -let prepare_trace f tr = + +(* Takes [printing_status] to change behavior for [Subtype] *) +let prepare_any_trace printing_status tr = let clean_trace x l = match printing_status x with | Keep -> x :: l | Optional_refinement when l = [] -> [x] | Optional_refinement | Discard -> l in - match Trace.flatten f tr with + match tr with | [] -> [] - | elt :: rem -> (* the first element is always kept *) - elt :: List.fold_right clean_trace rem [] + | elt :: rem -> elt :: List.fold_right clean_trace rem [] + +let prepare_trace f tr = + prepare_any_trace printing_status (Errortrace.map f tr) (** Keep elements that are not [Diff _ ] and take the decision for the last element, require a prepared trace *) -let rec filter_trace keep_last = function +let rec filter_trace + (trace_format : 'variety trace_format) + keep_last + : ('a, 'variety) Errortrace.t -> _ = function | [] -> [] - | [Trace.Diff d as elt] when printing_status elt = Optional_refinement -> - if keep_last then [d] else [] - | Trace.Diff d :: rem -> d :: filter_trace keep_last rem - | _ :: rem -> filter_trace keep_last rem + | [Errortrace.Diff d as elt] + when printing_status elt = Optional_refinement -> + if keep_last then [d] else [] + | Errortrace.Diff d :: rem -> d :: filter_trace trace_format keep_last rem + | _ :: rem -> filter_trace trace_format keep_last rem let type_path_list = Format.pp_print_list ~pp_sep:(fun ppf () -> Format.pp_print_break ppf 2 0) @@ -1961,24 +2174,29 @@ let type_path_list = (* Hide variant name and var, to force printing the expanded type *) let hide_variant_name t = - match repr t with - | {desc = Tvariant row} as t when (row_repr row).row_name <> None -> - newty2 t.level - (Tvariant {(row_repr row) with row_name = None; - row_more = newvar2 (row_more row).level}) + match get_desc t with + | Tvariant row -> + let Row {fields; more; name; fixed; closed} = row_repr row in + if name = None then t else + newty2 ~level:(get_level t) + (Tvariant + (create_row ~fields ~fixed ~closed ~name:None + ~more:(newvar2 (get_level more)))) | _ -> t -let prepare_expansion (t, t') = - let t' = hide_variant_name t' in - mark_loops t; - if not (same_path t t') then mark_loops t'; - (t, t') +let prepare_expansion Errortrace.{ty; expanded} = + let expanded = hide_variant_name expanded in + reserve_names ty; + if not (same_path ty expanded) then reserve_names expanded; + Errortrace.{ty; expanded} -let may_prepare_expansion compact (t, t') = - match (repr t').desc with +let may_prepare_expansion compact (Errortrace.{ty; expanded} as ty_exp) = + match get_desc expanded with Tvariant _ | Tobject _ when compact -> - mark_loops t; (t, t) - | _ -> prepare_expansion (t, t') + reserve_names ty; Errortrace.{ty; expanded = ty} + | _ -> prepare_expansion ty_exp + +let print_path p = Format.dprintf "%a" !Oprint.out_ident (tree_of_path Type p) let print_tag ppf = fprintf ppf "`%s" @@ -1986,10 +2204,14 @@ let print_tags = let comma ppf () = Format.fprintf ppf ",@ " in Format.pp_print_list ~pp_sep:comma print_tag -let is_unit env ty = - match (Ctype.expand_head env ty).desc with - | Tconstr (p, _, _) -> Path.same p Predef.path_unit - | _ -> false +let is_unit_arg env ty = + let ty, vars = tpoly_get_poly ty in + if vars <> [] then false + else begin + match get_desc (Ctype.expand_head env ty) with + | Tconstr (p, _, _) -> Path.same p Predef.path_unit + | _ -> false + end let unifiable env ty1 ty2 = let snap = Btype.snapshot () in @@ -2001,14 +2223,14 @@ let unifiable env ty1 ty2 = res let explanation_diff env t3 t4 : (Format.formatter -> unit) option = - match t3.desc, t4.desc with + match get_desc t3, get_desc t4 with | Tarrow (_, ty1, ty2, _), _ - when is_unit env ty1 && unifiable env ty2 t4 -> + when is_unit_arg env ty1 && unifiable env ty2 t4 -> Some (fun ppf -> fprintf ppf "@,@[Hint: Did you forget to provide `()' as argument?@]") | _, Tarrow (_, ty1, ty2, _) - when is_unit env ty1 && unifiable env t3 ty2 -> + when is_unit_arg env ty1 && unifiable env t3 ty2 -> Some (fun ppf -> fprintf ppf "@,@[Hint: Did you forget to wrap the expression using \ @@ -2016,118 +2238,153 @@ let explanation_diff env t3 t4 : (Format.formatter -> unit) option = | _ -> None -let print_pos ppf = function - | Trace.First -> fprintf ppf "first" - | Trace.Second -> fprintf ppf "second" - let explain_fixed_row_case ppf = function - | Trace.Cannot_be_closed -> Format.fprintf ppf "it cannot be closed" - | Trace.Cannot_add_tags tags -> - Format.fprintf ppf "it may not allow the tag(s) %a" - print_tags tags + | Errortrace.Cannot_be_closed -> + fprintf ppf "it cannot be closed" + | Errortrace.Cannot_add_tags tags -> + fprintf ppf "it may not allow the tag(s) %a" print_tags tags let explain_fixed_row pos expl = match expl with - | Types.Fixed_private -> - dprintf "The %a variant type is private" print_pos pos - | Types.Univar x -> - dprintf "The %a variant type is bound to the universal type variable %a" - print_pos pos type_expr x - | Types.Reified p -> - let p = tree_of_path Type p in - dprintf "The %a variant type is bound to %a" print_pos pos - !Oprint.out_ident p - | Types.Rigid -> ignore - -let explain_variant = function - | Trace.No_intersection -> + | Fixed_private -> + dprintf "The %a variant type is private" Errortrace.print_pos pos + | Univar x -> + reserve_names x; + dprintf "The %a variant type is bound to the universal type variable %a" + Errortrace.print_pos pos type_expr_with_reserved_names x + | Reified p -> + dprintf "The %a variant type is bound to %t" + Errortrace.print_pos pos (print_path p) + | Rigid -> ignore + +let explain_variant (type variety) : variety Errortrace.variant -> _ = function + (* Common *) + | Errortrace.Incompatible_types_for s -> + Some(dprintf "@,Types for tag `%s are incompatible" s) + (* Unification *) + | Errortrace.No_intersection -> Some(dprintf "@,These two variant types have no intersection") - | Trace.No_tags(pos,fields) -> Some( + | Errortrace.No_tags(pos,fields) -> Some( dprintf "@,@[The %a variant type does not allow tag(s)@ @[%a@]@]" - print_pos pos + Errortrace.print_pos pos print_tags (List.map fst fields) ) - | Trace.Incompatible_types_for s -> - Some(dprintf "@,Types for tag `%s are incompatible" s) - | Trace.Fixed_row (pos, k, (Univar _ | Reified _ | Fixed_private as e)) -> + | Errortrace.Fixed_row (pos, + k, + (Univar _ | Reified _ | Fixed_private as e)) -> Some ( dprintf "@,@[%t,@ %a@]" (explain_fixed_row pos e) explain_fixed_row_case k ) - | Trace.Fixed_row (_,_, Rigid) -> + | Errortrace.Fixed_row (_,_, Rigid) -> (* this case never happens *) None - - -let explain_escape intro prev ctx e = - let pre = match ctx with - | Some ctx -> dprintf "@[%t@;<1 2>%a@]" intro type_expr ctx - | None -> match e, prev with - | Trace.Univ _, Some(Trace.Incompatible_fields {name; diff}) -> - dprintf "@,@[The method %s has type@ %a,@ \ - but the expected method type was@ %a@]" name - type_expr diff.Trace.got type_expr diff.Trace.expected - | _ -> ignore in - match e with - | Trace.Univ u -> Some( - dprintf "%t@,The universal variable %a would escape its scope" - pre type_expr u) - | Trace.Constructor p -> Some( + (* Equality & Moregen *) + | Errortrace.Presence_not_guaranteed_for (pos, s) -> Some( + dprintf + "@,@[The tag `%s is guaranteed to be present in the %a variant type,\ + @ but not in the %a@]" + s + Errortrace.print_pos (Errortrace.swap_position pos) + Errortrace.print_pos pos + ) + | Errortrace.Openness pos -> + Some(dprintf "@,The %a variant type is open and the %a is not" + Errortrace.print_pos pos + Errortrace.print_pos (Errortrace.swap_position pos)) + +let explain_escape pre = function + | Errortrace.Univ u -> + reserve_names u; + Some( + dprintf "%t@,The universal variable %a would escape its scope" + pre type_expr_with_reserved_names u) + | Errortrace.Constructor p -> Some( dprintf "%t@,@[The type constructor@;<1 2>%a@ would escape its scope@]" pre path p ) - | Trace.Module_type p -> Some( + | Errortrace.Module_type p -> Some( dprintf "%t@,@[The module type@;<1 2>%a@ would escape its scope@]" pre path p ) - | Trace.Equation (_,t) -> Some( - dprintf "%t @,@[This instance of %a is ambiguous:@ %s@]" - pre type_expr t - "it would escape the scope of its equation" - ) - | Trace.Self -> + | Errortrace.Equation Errortrace.{ty = _; expanded = t} -> + reserve_names t; + Some( + dprintf "%t @,@[This instance of %a is ambiguous:@ %s@]" + pre type_expr_with_reserved_names t + "it would escape the scope of its equation" + ) + | Errortrace.Self -> Some (dprintf "%t@,Self type cannot escape its class" pre) + | Errortrace.Constraint -> + None - -let explain_object = function - | Trace.Self_cannot_be_closed -> - Some (dprintf "@,Self type cannot be unified with a closed object type") - | Trace.Missing_field (pos,f) -> - Some(dprintf "@,@[The %a object type has no method %s@]" print_pos pos f) - | Trace.Abstract_row pos -> Some( +let explain_object (type variety) : variety Errortrace.obj -> _ = function + | Errortrace.Missing_field (pos,f) -> Some( + dprintf "@,@[The %a object type has no method %s@]" + Errortrace.print_pos pos f + ) + | Errortrace.Abstract_row pos -> Some( dprintf "@,@[The %a object type has an abstract row, it cannot be closed@]" - print_pos pos + Errortrace.print_pos pos ) + | Errortrace.Self_cannot_be_closed -> + Some (dprintf "@,Self type cannot be unified with a closed object type") - -let explanation intro prev env = function - | Trace.Diff { Trace.got = _, s; expected = _,t } -> explanation_diff env s t - | Trace.Escape {kind;context} -> explain_escape intro prev context kind - | Trace.Incompatible_fields { name; _ } -> - Some(dprintf "@,Types for method %s are incompatible" name) - | Trace.Variant v -> explain_variant v - | Trace.Obj o -> explain_object o - | Trace.Rec_occur(x,y) -> - reset_and_mark_loops y; - begin match x.desc with - | Tvar _ | Tunivar _ -> - Some(dprintf "@,@[The type variable %a occurs inside@ %a@]" - marked_type_expr x marked_type_expr y) - | _ -> - (* We had a delayed unification of the type variable with - a non-variable after the occur check. *) - Some ignore - (* There is no need to search further for an explanation, but - we don't want to print a message of the form: - {[ The type int occurs inside int list -> 'a |} - *) - end +let explanation (type variety) intro prev env + : (Errortrace.expanded_type, variety) Errortrace.elt -> _ = function + | Errortrace.Diff {got; expected} -> + explanation_diff env got.expanded expected.expanded + | Errortrace.Escape {kind; context} -> + let pre = + match context, kind, prev with + | Some ctx, _, _ -> + reserve_names ctx; + dprintf "@[%t@;<1 2>%a@]" intro type_expr_with_reserved_names ctx + | None, Univ _, Some(Errortrace.Incompatible_fields {name; diff}) -> + reserve_names diff.got; + reserve_names diff.expected; + dprintf "@,@[The method %s has type@ %a,@ \ + but the expected method type was@ %a@]" + name + type_expr_with_reserved_names diff.got + type_expr_with_reserved_names diff.expected + | _ -> ignore + in + explain_escape pre kind + | Errortrace.Incompatible_fields { name; _ } -> + Some(dprintf "@,Types for method %s are incompatible" name) + | Errortrace.Variant v -> + explain_variant v + | Errortrace.Obj o -> + explain_object o + | Errortrace.Rec_occur(x,y) -> + reserve_names x; + reserve_names y; + begin match get_desc x with + | Tvar _ | Tunivar _ -> + Some(fun ppf -> + reset_loop_marks (); + mark_loops x; + mark_loops y; + dprintf "@,@[The type variable %a occurs inside@ %a@]" + prepared_type_expr x prepared_type_expr y + ppf) + | _ -> + (* We had a delayed unification of the type variable with + a non-variable after the occur check. *) + Some ignore + (* There is no need to search further for an explanation, but + we don't want to print a message of the form: + {[ The type int occurs inside int list -> 'a |} + *) + end let mismatch intro env trace = - Trace.explain trace (fun ~prev h -> explanation intro prev env h) + Errortrace.explain trace (fun ~prev h -> explanation intro prev env h) let explain mis ppf = match mis with @@ -2135,7 +2392,7 @@ let explain mis ppf = | Some explain -> explain ppf let warn_on_missing_def env ppf t = - match t.desc with + match get_desc t with | Tconstr (p,_,_) -> begin try @@ -2147,47 +2404,55 @@ let warn_on_missing_def env ppf t = end | _ -> () - let prepare_expansion_head empty_tr = function - | Trace.Diff d -> - Some(Trace.map_diff (may_prepare_expansion empty_tr) d) + | Errortrace.Diff d -> + Some (Errortrace.map_diff (may_prepare_expansion empty_tr) d) | _ -> None -let head_error_printer txt_got txt_but = function +let head_error_printer mode txt_got txt_but = function | None -> ignore | Some d -> - let d = Trace.map_diff trees_of_type_expansion d in + let d = Errortrace.map_diff (trees_of_type_expansion mode) d in dprintf "%t@;<1 2>%a@ %t@;<1 2>%a" - txt_got type_expansion d.Trace.got - txt_but type_expansion d.Trace.expected + txt_got type_expansion d.Errortrace.got + txt_but type_expansion d.Errortrace.expected let warn_on_missing_defs env ppf = function | None -> () - | Some {Trace.got=te1,_; expected=te2,_ } -> + | Some Errortrace.{got = {ty=te1; expanded=_}; + expected = {ty=te2; expanded=_} } -> warn_on_missing_def env ppf te1; warn_on_missing_def env ppf te2 -let unification_error env tr txt1 ppf txt2 ty_expect_explanation = +(* [subst] comes out of equality, and is [[]] otherwise *) +let error trace_format mode subst env tr txt1 ppf txt2 ty_expect_explanation = reset (); - let tr = prepare_trace (fun t t' -> t, hide_variant_name t') tr in + (* We want to substitute in the opposite order from [Eqtype] *) + Names.add_subst (List.map (fun (ty1,ty2) -> ty2,ty1) subst); + let tr = + prepare_trace + (fun ty_exp -> + Errortrace.{ty_exp with expanded = hide_variant_name ty_exp.expanded}) + tr + in let mis = mismatch txt1 env tr in match tr with | [] -> assert false | elt :: tr -> try print_labels := not !Clflags.classic; - let tr = filter_trace (mis = None) tr in + let tr = filter_trace trace_format (mis = None) tr in let head = prepare_expansion_head (tr=[]) elt in - let tr = List.map (Trace.map_diff prepare_expansion) tr in - let head_error = head_error_printer txt1 txt2 head in - let tr = trees_of_trace tr in + let tr = List.map (Errortrace.map_diff prepare_expansion) tr in + let head_error = head_error_printer mode txt1 txt2 head in + let tr = trees_of_trace mode tr in fprintf ppf "@[\ @[%t%t@]%a%t\ @]" head_error ty_expect_explanation - (trace false "is not compatible with type") tr + (trace false (incompatibility_phrase trace_format)) tr (explain mis); if env <> Env.empty then warn_on_missing_defs env ppf head; @@ -2197,51 +2462,112 @@ let unification_error env tr txt1 ppf txt2 ty_expect_explanation = print_labels := true; raise exn -let report_unification_error ppf env tr - ?(type_expected_explanation = fun _ -> ()) - txt1 txt2 = - wrap_printing_env env (fun () -> unification_error env tr txt1 ppf txt2 - type_expected_explanation) - ~error:true -;; - -(** [trace] requires the trace to be prepared *) -let trace fst keep_last txt ppf tr = - print_labels := not !Clflags.classic; - try match tr with - | elt :: tr' -> - let elt = match elt with - | Trace.Diff diff -> [Trace.map_diff trees_of_type_expansion diff] - | _ -> [] in +let report_error trace_format ppf mode env tr + ?(subst = []) + ?(type_expected_explanation = fun _ -> ()) + txt1 txt2 = + wrap_printing_env ~error:true env (fun () -> + error trace_format mode subst env tr txt1 ppf txt2 + type_expected_explanation) + +let report_unification_error + ppf env ({trace} : Errortrace.unification_error) = + report_error Unification ppf Type env + ?subst:None trace + +let report_equality_error + ppf mode env ({subst; trace} : Errortrace.equality_error) = + report_error Equality ppf mode env + ~subst ?type_expected_explanation:None trace + +let report_moregen_error + ppf mode env ({trace} : Errortrace.moregen_error) = + report_error Moregen ppf mode env + ?subst:None ?type_expected_explanation:None trace + +let report_comparison_error ppf mode env = function + | Errortrace.Equality_error error -> report_equality_error ppf mode env error + | Errortrace.Moregen_error error -> report_moregen_error ppf mode env error + +module Subtype = struct + (* There's a frustrating amount of code duplication between this module and + the outside code, particularly in [prepare_trace] and [filter_trace]. + Unfortunately, [Subtype] is *just* similar enough to have code duplication, + while being *just* different enough (it's only [Diff]) for the abstraction + to be nonobvious. Someday, perhaps... *) + + let printing_status = function + | Errortrace.Subtype.Diff d -> diff_printing_status d + + let prepare_unification_trace = prepare_trace + + let prepare_trace f tr = + prepare_any_trace printing_status (Errortrace.Subtype.map f tr) + + let trace filter_trace get_diff fst keep_last txt ppf tr = + print_labels := not !Clflags.classic; + try match tr with + | elt :: tr' -> + let diffed_elt = get_diff elt in let tr = - trees_of_trace - @@ List.map (Trace.map_diff prepare_expansion) + trees_of_trace Type + @@ List.map (Errortrace.map_diff prepare_expansion) @@ filter_trace keep_last tr' in - if fst then trace fst txt ppf (elt @ tr) - else trace fst txt ppf tr; - print_labels := true - | _ -> () - with exn -> - print_labels := true; - raise exn + let tr = + match fst, diffed_elt with + | true, Some elt -> elt :: tr + | _, _ -> tr + in + trace fst txt ppf tr; + print_labels := true + | _ -> () + with exn -> + print_labels := true; + raise exn -let report_subtyping_error ppf env tr1 txt1 tr2 = - wrap_printing_env ~error:true env (fun () -> - reset (); - let tr1 = prepare_trace (fun t t' -> prepare_expansion (t, t')) tr1 in - let tr2 = prepare_trace (fun t t' -> prepare_expansion (t, t')) tr2 in - let keep_first = match tr2 with - | Trace.[Obj _ | Variant _ | Escape _ ] | [] -> true - | _ -> false in - fprintf ppf "@[%a" (trace true keep_first txt1) tr1; - if tr2 = [] then fprintf ppf "@]" else - let mis = mismatch (dprintf "Within this type") env tr2 in - fprintf ppf "%a%t%t@]" - (trace false (mis = None) "is not compatible with type") tr2 - (explain mis) - Conflicts.print_explanations - ) + let filter_unification_trace = filter_trace Unification + let rec filter_subtype_trace keep_last = function + | [] -> [] + | [Errortrace.Subtype.Diff d as elt] + when printing_status elt = Optional_refinement -> + if keep_last then [d] else [] + | Errortrace.Subtype.Diff d :: rem -> + d :: filter_subtype_trace keep_last rem + + let unification_get_diff = function + | Errortrace.Diff diff -> + Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) + | _ -> None + + let subtype_get_diff = function + | Errortrace.Subtype.Diff diff -> + Some (Errortrace.map_diff (trees_of_type_expansion Type) diff) + + let report_error + ppf + env + (Errortrace.Subtype.{trace = tr_sub; unification_trace = tr_unif}) + txt1 = + wrap_printing_env ~error:true env (fun () -> + reset (); + let tr_sub = prepare_trace prepare_expansion tr_sub in + let tr_unif = prepare_unification_trace prepare_expansion tr_unif in + let keep_first = match tr_unif with + | [Obj _ | Variant _ | Escape _ ] | [] -> true + | _ -> false in + fprintf ppf "@[%a" + (trace filter_subtype_trace subtype_get_diff true keep_first txt1) + tr_sub; + if tr_unif = [] then fprintf ppf "@]" else + let mis = mismatch (dprintf "Within this type") env tr_unif in + fprintf ppf "%a%t%t@]" + (trace filter_unification_trace unification_get_diff false + (mis = None) "is not compatible with type") tr_unif + (explain mis) + Conflicts.print_explanations + ) +end let report_ambiguous_type_error ppf env tp0 tpl txt1 txt2 txt3 = wrap_printing_env ~error:true env (fun () -> @@ -2267,10 +2593,8 @@ let report_ambiguous_type_error ppf env tp0 tpl txt1 txt2 txt3 = (* Adapt functions to exposed interface *) let tree_of_path = tree_of_path Other let tree_of_modtype = tree_of_modtype ~ellipsis:false -let type_expansion ty ppf ty' = - type_expansion ppf (trees_of_type_expansion (ty,ty')) -let tree_of_type_declaration id td rs = - Naming_context.with_hidden id ( (* for disambiguation *) - wrap_env (hide [id]) (* for short-path *) - (fun () -> tree_of_type_declaration id td rs) - ) +let type_expansion mode ppf ty_exp = + type_expansion ppf (trees_of_type_expansion mode ty_exp) +let tree_of_type_declaration ident td rs = + with_hidden_items [{hide=true; ident}] + (fun () -> tree_of_type_declaration ident td rs) diff --git a/ocaml/typing/printtyp.mli b/ocaml/typing/printtyp.mli index fba02c6fb56..ac59f837e6f 100644 --- a/ocaml/typing/printtyp.mli +++ b/ocaml/typing/printtyp.mli @@ -47,6 +47,7 @@ val strings_of_paths: namespace -> Path.t list -> string list avoid name collisions *) val raw_type_expr: formatter -> type_expr -> unit +val raw_field : formatter -> row_field -> unit val string_of_label: Asttypes.arg_label -> string val wrap_printing_env: error:bool -> Env.t -> (unit -> 'a) -> 'a @@ -93,30 +94,47 @@ module Conflicts: sig end val reset: unit -> unit -val mark_loops: type_expr -> unit -val reset_and_mark_loops: type_expr -> unit -val reset_and_mark_loops_list: type_expr list -> unit +(** Print out a type. This will pick names for type variables, and will not + reuse names for common type variables shared across multiple type + expressions. (It will also reset the printing state, which matters for + other type formatters such as [prepared_type_expr].) If you want multiple + types to use common names for type variables, see [prepare_for_printing] and + [prepared_type_expr]. *) val type_expr: formatter -> type_expr -> unit -val marked_type_expr: formatter -> type_expr -> unit -(** The function [type_expr] is the safe version of the pair - [(typed_expr, marked_type_expr)]: - it takes care of marking loops in the type expression and resetting - type variable names before printing. - Contrarily, the function [marked_type_expr] should only be called on - type expressions whose loops have been marked or it may stackoverflow - (see #8860 for examples). - *) + +(** [prepare_for_printing] resets the global printing environment, a la [reset], + and prepares the types for printing by reserving names and marking loops. + Any type variables that are shared between multiple types in the input list + will be given the same name when printed with [prepared_type_expr]. *) +val prepare_for_printing: type_expr list -> unit + +(** [add_type_to_preparation ty] extend a previous type expression preparation + to the type expression [ty] +*) +val add_type_to_preparation: type_expr -> unit + +val prepared_type_expr: formatter -> type_expr -> unit +(** The function [prepared_type_expr] is a less-safe but more-flexible version + of [type_expr] that should only be called on [type_expr]s that have been + passed to [prepare_for_printing]. Unlike [type_expr], this function does no + extra work before printing a type; in particular, this means that any loops + in the type expression may cause a stack overflow (see #8860) since this + function does not mark any loops. The benefit of this is that if multiple + type expressions are prepared simultaneously and then printed with + [prepared_type_expr], they will use the same names for the same type + variables. *) val constructor_arguments: formatter -> constructor_arguments -> unit val tree_of_type_scheme: type_expr -> out_type -val type_sch : formatter -> type_expr -> unit val type_scheme: formatter -> type_expr -> unit -(* Maxence *) -val reset_names: unit -> unit -val type_scheme_max: ?b_reset_names: bool -> - formatter -> type_expr -> unit -(* End Maxence *) +val shared_type_scheme: formatter -> type_expr -> unit +(** [shared_type_scheme] is very similar to [type_scheme], but does not reset + the printing context first. This is intended to be used in cases where the + printing should have a particularly wide context, such as documentation + generators; most use cases, such as error messages, have narrower contexts + for which [type_scheme] is better suited. *) + val tree_of_value_description: Ident.t -> value_description -> out_sig_item val value_description: Ident.t -> formatter -> value_description -> unit val label : formatter -> label_declaration -> unit @@ -145,8 +163,26 @@ val signature: formatter -> signature -> unit val tree_of_modtype: module_type -> out_module_type val tree_of_modtype_declaration: Ident.t -> modtype_declaration -> out_sig_item + +(** Print a list of functor parameters while adjusting the printing environment + for each functor argument. + + Currently, we are disabling disambiguation for functor argument name to + avoid the need to track the moving association between identifiers and + syntactic names in situation like: + + got: (X: sig module type T end) (Y:X.T) (X:sig module type T end) (Z:X.T) + expect: (_: sig end) (Y:X.T) (_:sig end) (Z:X.T) +*) +val functor_parameters: + sep:(Format.formatter -> unit -> unit) -> + ('b -> Format.formatter -> unit) -> + (Ident.t option * 'b) list -> Format.formatter -> unit + +type type_or_scheme = Type | Type_scheme + val tree_of_signature: Types.signature -> out_sig_item list -val tree_of_typexp: bool -> type_expr -> out_type +val tree_of_typexp: type_or_scheme -> type_expr -> out_type val modtype_declaration: Ident.t -> formatter -> modtype_declaration -> unit val class_type: formatter -> class_type -> unit val tree_of_class_declaration: @@ -155,24 +191,50 @@ val class_declaration: Ident.t -> formatter -> class_declaration -> unit val tree_of_cltype_declaration: Ident.t -> class_type_declaration -> rec_status -> out_sig_item val cltype_declaration: Ident.t -> formatter -> class_type_declaration -> unit -val type_expansion: type_expr -> Format.formatter -> type_expr -> unit -val prepare_expansion: type_expr * type_expr -> type_expr * type_expr -val trace: - bool -> bool-> string -> formatter - -> (type_expr * type_expr) Ctype.Unification_trace.elt list -> unit -val report_unification_error: - formatter -> Env.t -> - Ctype.Unification_trace.t -> - ?type_expected_explanation:(formatter -> unit) -> - (formatter -> unit) -> (formatter -> unit) -> - unit -val report_subtyping_error: - formatter -> Env.t -> Ctype.Unification_trace.t -> string - -> Ctype.Unification_trace.t -> unit +val type_expansion : + type_or_scheme -> Format.formatter -> Errortrace.expanded_type -> unit +val prepare_expansion: Errortrace.expanded_type -> Errortrace.expanded_type val report_ambiguous_type_error: formatter -> Env.t -> (Path.t * Path.t) -> (Path.t * Path.t) list -> (formatter -> unit) -> (formatter -> unit) -> (formatter -> unit) -> unit +val report_unification_error : + formatter -> + Env.t -> Errortrace.unification_error -> + ?type_expected_explanation:(formatter -> unit) -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +val report_equality_error : + formatter -> + type_or_scheme -> + Env.t -> Errortrace.equality_error -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +val report_moregen_error : + formatter -> + type_or_scheme -> + Env.t -> Errortrace.moregen_error -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +val report_comparison_error : + formatter -> + type_or_scheme -> + Env.t -> Errortrace.comparison_error -> + (formatter -> unit) -> (formatter -> unit) -> + unit + +module Subtype : sig + val report_error : + formatter -> + Env.t -> + Errortrace.Subtype.error -> + string -> + unit +end + (* for toploop *) val print_items: (Env.t -> signature_item -> 'a option) -> Env.t -> signature_item list -> (out_sig_item * 'a option) list @@ -181,6 +243,8 @@ val print_items: (Env.t -> signature_item -> 'a option) -> for Foo__bar. This pattern is used by the stdlib. *) val rewrite_double_underscore_paths: Env.t -> Path.t -> Path.t +val rewrite_double_underscore_longidents: Env.t -> Longident.t -> Longident.t + (** [printed_signature sourcefile ppf sg] print the signature [sg] of [sourcefile] with potential warnings for name collisions *) val printed_signature: string -> formatter -> signature -> unit diff --git a/ocaml/typing/printtyped.ml b/ocaml/typing/printtyped.ml index 71a934af970..efa566247b3 100644 --- a/ocaml/typing/printtyped.ml +++ b/ocaml/typing/printtyped.ml @@ -155,6 +155,10 @@ let arg_label i ppf = function | Labelled s -> line i ppf "Labelled \"%s\"\n" s ;; +let typevars ppf vs = + List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt) vs +;; + let record_representation i ppf = let open Types in function | Record_regular -> line i ppf "Record_regular\n" | Record_float -> line i ppf "Record_float\n" @@ -230,11 +234,12 @@ and pattern : type k . _ -> _ -> k general_pattern -> unit = fun i ppf x -> line i ppf "pattern %a\n" fmt_location x.pat_loc; attributes i ppf x.pat_attributes; let i = i+1 in - match x.pat_extra with - | extra :: rem -> - pattern_extra i ppf extra; - pattern i ppf { x with pat_extra = rem } - | [] -> + begin match x.pat_extra with + | [] -> () + | extra -> + line i ppf "extra\n"; + List.iter (pattern_extra (i+1) ppf) extra; + end; match x.pat_desc with | Tpat_any -> line i ppf "Tpat_any\n"; | Tpat_var (s,_) -> line i ppf "Tpat_var \"%a\"\n" fmt_ident s; @@ -245,9 +250,15 @@ and pattern : type k . _ -> _ -> k general_pattern -> unit = fun i ppf x -> | Tpat_tuple (l) -> line i ppf "Tpat_tuple\n"; list i pattern ppf l; - | Tpat_construct (li, _, po) -> + | Tpat_construct (li, _, po, vto) -> line i ppf "Tpat_construct %a\n" fmt_longident li; list i pattern ppf po; + option i + (fun i ppf (vl,ct) -> + let names = List.map (fun {txt} -> "\""^Ident.name txt^"\"") vl in + line i ppf "[%s]\n" (String.concat "; " names); + core_type i ppf ct) + ppf vto | Tpat_variant (l, po, _) -> line i ppf "Tpat_variant \"%s\"\n" l; option i pattern ppf po; @@ -284,10 +295,10 @@ and pattern_extra i ppf (extra_pat, _, attrs) = line i ppf "Tpat_extra_type %a\n" fmt_path id; attributes i ppf attrs; | Tpat_open (id,_,_) -> - line i ppf "Tpat_extra_open \"%a\"\n" fmt_path id; + line i ppf "Tpat_extra_open %a\n" fmt_path id; attributes i ppf attrs; -and expression_extra i ppf x attrs = +and expression_extra i ppf (x,_,attrs) = match x with | Texp_constraint ct -> line i ppf "Texp_constraint\n"; @@ -325,12 +336,14 @@ and comprehension i ppf comp_types= and expression i ppf x = line i ppf "expression %a\n" fmt_location x.exp_loc; attributes i ppf x.exp_attributes; - let i = - List.fold_left (fun i (extra,_,attrs) -> - expression_extra i ppf extra attrs; i+1) - (i+1) x.exp_extra - in - (match Btype.Value_mode.check_const x.exp_mode with + let i = i+1 in + begin match x.exp_extra with + | [] -> () + | extra -> + line i ppf "extra\n"; + List.iter (expression_extra (i+1) ppf) extra; + end; + (match Types.Value_mode.check_const x.exp_mode with | Some Global -> line i ppf "value_mode global\n" | Some Regional -> line i ppf "value_mode regional\n" | Some Local -> line i ppf "value_mode local\n" @@ -425,17 +438,18 @@ and expression i ppf x = expression i ppf for_to; line i ppf "region %b\n" for_region; expression i ppf for_body - | Texp_send (e, Tmeth_name s, eo, _) -> + | Texp_send (e, Tmeth_name s, _) -> line i ppf "Texp_send \"%s\"\n" s; - expression i ppf e; - option i expression ppf eo - | Texp_send (e, Tmeth_val s, eo, _) -> + expression i ppf e + | Texp_send (e, Tmeth_val s, _) -> line i ppf "Texp_send \"%a\"\n" fmt_ident s; - expression i ppf e; - option i expression ppf eo + expression i ppf e + | Texp_send (e, Tmeth_ancestor(s, _), _) -> + line i ppf "Texp_send \"%a\"\n" fmt_ident s; + expression i ppf e | Texp_new (li, _, _, _) -> line i ppf "Texp_new %a\n" fmt_path li; | Texp_setinstvar (_, s, _, e) -> - line i ppf "Texp_setinstvar \"%a\"\n" fmt_path s; + line i ppf "Texp_setinstvar %a\n" fmt_path s; expression i ppf e; | Texp_override (_, l) -> line i ppf "Texp_override\n"; @@ -552,8 +566,9 @@ and extension_constructor i ppf x = and extension_constructor_kind i ppf x = match x with - Text_decl(a, r) -> + Text_decl(v, a, r) -> line i ppf "Text_decl\n"; + if v <> [] then line (i+1) ppf "vars%a\n" typevars v; constructor_arguments (i+1) ppf a; option (i+1) core_type ppf r; | Text_rebind(p, _) -> @@ -776,6 +791,10 @@ and signature_item i ppf x = line i ppf "Tsig_modtype \"%a\"\n" fmt_ident x.mtd_id; attributes i ppf x.mtd_attributes; modtype_declaration i ppf x.mtd_type + | Tsig_modtypesubst x -> + line i ppf "Tsig_modtypesubst \"%a\"\n" fmt_ident x.mtd_id; + attributes i ppf x.mtd_attributes; + modtype_declaration i ppf x.mtd_type | Tsig_open od -> line i ppf "Tsig_open %a %a\n" fmt_override_flag od.open_override @@ -818,6 +837,12 @@ and with_constraint i ppf x = type_declaration (i+1) ppf td; | Twith_module (li,_) -> line i ppf "Twith_module %a\n" fmt_path li; | Twith_modsubst (li,_) -> line i ppf "Twith_modsubst %a\n" fmt_path li; + | Twith_modtype mty -> + line i ppf "Twith_modtype\n"; + module_type (i+1) ppf mty + | Twith_modtypesubst mty -> + line i ppf "Twith_modtype\n"; + module_type (i+1) ppf mty and module_expr i ppf x = line i ppf "module_expr %a\n" fmt_location x.mod_loc; @@ -910,16 +935,17 @@ and core_type_x_core_type_x_location i ppf (ct1, ct2, l) = core_type (i+1) ppf ct1; core_type (i+1) ppf ct2; -and constructor_decl i ppf {cd_id; cd_name = _; cd_args; cd_res; cd_loc; - cd_attributes} = +and constructor_decl i ppf {cd_id; cd_name = _; cd_vars; + cd_args; cd_res; cd_loc; cd_attributes} = line i ppf "%a\n" fmt_location cd_loc; line (i+1) ppf "%a\n" fmt_ident cd_id; + if cd_vars <> [] then line (i+1) ppf "cd_vars =%a\n" typevars cd_vars; attributes i ppf cd_attributes; constructor_arguments (i+1) ppf cd_args; option (i+1) core_type ppf cd_res and constructor_arguments i ppf = function - | Cstr_tuple l -> list i core_type ppf l + | Cstr_tuple l -> list i field_decl ppf l | Cstr_record l -> list i label_decl ppf l and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc; @@ -930,6 +956,9 @@ and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc; line (i+1) ppf "%a" fmt_ident ld_id; core_type (i+1) ppf ld_type +and field_decl i ppf (ty, _) = + core_type (i+1) ppf ty + and longident_x_pattern i ppf (li, _, p) = line i ppf "%a\n" fmt_longident li; pattern (i+1) ppf p; @@ -952,7 +981,7 @@ and value_binding i ppf x = expression (i+1) ppf x.vb_expr and string_x_expression i ppf (s, _, e) = - line i ppf " \"%a\"\n" fmt_path s; + line i ppf " \"%a\"\n" fmt_ident s; expression (i+1) ppf e; and record_field i ppf = function @@ -986,4 +1015,5 @@ let interface ppf x = list 0 signature_item ppf x.sig_items;; let implementation ppf x = list 0 structure_item ppf x.str_items;; -let implementation_with_coercion ppf (x, _) = implementation ppf x +let implementation_with_coercion ppf Typedtree.{structure; _} = + implementation ppf structure diff --git a/ocaml/typing/printtyped.mli b/ocaml/typing/printtyped.mli index ded42bb325c..538a3faae2e 100644 --- a/ocaml/typing/printtyped.mli +++ b/ocaml/typing/printtyped.mli @@ -20,4 +20,4 @@ val interface : formatter -> signature -> unit;; val implementation : formatter -> structure -> unit;; val implementation_with_coercion : - formatter -> (structure * module_coercion) -> unit;; + formatter -> Typedtree.implementation -> unit;; diff --git a/ocaml/typing/rec_check.ml b/ocaml/typing/rec_check.ml index 892c0e9b5a5..7601d6761ca 100644 --- a/ocaml/typing/rec_check.ml +++ b/ocaml/typing/rec_check.ml @@ -720,15 +720,14 @@ let rec expression : Typedtree.expression -> term_judg = expression wh_cond << Dereference; expression wh_body << Guard; ] - | Texp_send (e1, _, eo, _) -> + | Texp_send (e1, _, _) -> (* G |- e: m[Dereference] ---------------------- (plus weird 'eo' option) G |- e#x: m *) join [ - expression e1 << Dereference; - option expression eo << Dereference; + expression e1 << Dereference ] | Texp_field (e, _, _) -> (* @@ -1247,7 +1246,7 @@ and is_destructuring_pattern : type k . k general_pattern -> bool = | Tpat_alias (pat, _, _) -> is_destructuring_pattern pat | Tpat_constant _ -> true | Tpat_tuple _ -> true - | Tpat_construct (_, _, _) -> true + | Tpat_construct _ -> true | Tpat_variant _ -> true | Tpat_record (_, _) -> true | Tpat_array _ -> true @@ -1258,17 +1257,20 @@ and is_destructuring_pattern : type k . k general_pattern -> bool = is_destructuring_pattern l || is_destructuring_pattern r let is_valid_recursive_expression idlist expr = - let ty = expression expr Return in - match Env.unguarded ty idlist, Env.dependent ty idlist, - classify_expression expr with - | _ :: _, _, _ (* The expression inspects rec-bound variables *) - | [], _ :: _, Dynamic -> (* The expression depends on rec-bound variables - and its size is unknown *) - false - | [], _, Static (* The expression has known size *) - | [], [], Dynamic -> (* The expression has unknown size, - but does not depend on rec-bound variables *) - true + match expr.exp_desc with + | Texp_function _ -> + (* Fast path: functions can never have invalid recursive references *) + true + | _ -> + match classify_expression expr with + | Static -> + (* The expression has known size *) + let ty = expression expr Return in + Env.unguarded ty idlist = [] + | Dynamic -> + (* The expression has unknown size *) + let ty = expression expr Return in + Env.unguarded ty idlist = [] && Env.dependent ty idlist = [] (* A class declaration may contain let-bindings. If they are recursive, their validity will already be checked by [is_valid_recursive_expression] diff --git a/ocaml/typing/shape.ml b/ocaml/typing/shape.ml new file mode 100644 index 00000000000..73a39e203f6 --- /dev/null +++ b/ocaml/typing/shape.ml @@ -0,0 +1,524 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Uid = struct + type t = + | Compilation_unit of string + | Item of { comp_unit: string; id: int } + | Internal + | Predef of string + + include Identifiable.Make(struct + type nonrec t = t + + let equal (x : t) y = x = y + let compare (x : t) y = compare x y + let hash (x : t) = Hashtbl.hash x + + let print fmt = function + | Internal -> Format.pp_print_string fmt "" + | Predef name -> Format.fprintf fmt "" name + | Compilation_unit s -> Format.pp_print_string fmt s + | Item { comp_unit; id } -> Format.fprintf fmt "%s.%d" comp_unit id + + let output oc t = + let fmt = Format.formatter_of_out_channel oc in + print fmt t + end) + + let id = ref (-1) + + let reinit () = id := (-1) + + let mk ~current_unit = + incr id; + let comp_unit = + match current_unit with + | Some cu -> cu |> Compilation_unit.full_path_as_string + | None -> "" + in + Item { comp_unit; id = !id } + + let of_compilation_unit_id id = + Compilation_unit (id |> Compilation_unit.full_path_as_string) + + let of_predef_id id = + if not (Ident.is_predef id) then + Misc.fatal_errorf "Types.Uid.of_predef_id %S" (Ident.name id); + Predef (Ident.name id) + + let internal_not_actually_unique = Internal + + let for_actual_declaration = function + | Item _ -> true + | _ -> false +end + +module Sig_component_kind = struct + type t = + | Value + | Type + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + + let to_string = function + | Value -> "value" + | Type -> "type" + | Module -> "module" + | Module_type -> "module type" + | Extension_constructor -> "extension constructor" + | Class -> "class" + | Class_type -> "class type" + + let can_appear_in_types = function + | Value + | Extension_constructor -> + false + | Type + | Module + | Module_type + | Class + | Class_type -> + true +end + +module Item = struct + module T = struct + type t = string * Sig_component_kind.t + let compare = compare + + let make str ns = str, ns + + let value id = Ident.name id, Sig_component_kind.Value + let type_ id = Ident.name id, Sig_component_kind.Type + let module_ id = Ident.name id, Sig_component_kind.Module + let module_type id = Ident.name id, Sig_component_kind.Module_type + let extension_constructor id = + Ident.name id, Sig_component_kind.Extension_constructor + let class_ id = + Ident.name id, Sig_component_kind.Class + let class_type id = + Ident.name id, Sig_component_kind.Class_type + + let print fmt (name, ns) = + Format.fprintf fmt "%S[%s]" + name + (Sig_component_kind.to_string ns) + end + + include T + + module Map = Map.Make(T) +end + +type var = Ident.t +type t = { uid: Uid.t option; desc: desc } +and desc = + | Var of var + | Abs of var * t + | App of t * t + | Struct of t Item.Map.t + | Leaf + | Proj of t * Item.t + | Comp_unit of string + +let print fmt = + let print_uid_opt = + Format.pp_print_option (fun fmt -> Format.fprintf fmt "<%a>" Uid.print) + in + let rec aux fmt { uid; desc } = + match desc with + | Var id -> + Format.fprintf fmt "%a%a" Ident.print id print_uid_opt uid + | Abs (id, t) -> + Format.fprintf fmt "Abs@[%a@,(@[%a,@ @[%a@]@])@]" + print_uid_opt uid Ident.print id aux t + | App (t1, t2) -> + Format.fprintf fmt "@[%a(@,%a)%a@]" aux t1 aux t2 + print_uid_opt uid + | Leaf -> + Format.fprintf fmt "<%a>" (Format.pp_print_option Uid.print) uid + | Proj (t, item) -> + begin match uid with + | None -> + Format.fprintf fmt "@[%a@ .@ %a@]" + aux t + Item.print item + | Some uid -> + Format.fprintf fmt "@[(%a@ .@ %a)<%a>@]" + aux t + Item.print item + Uid.print uid + end + | Comp_unit name -> Format.fprintf fmt "CU %s" name + | Struct map -> + let print_map fmt = + Item.Map.iter (fun item t -> + Format.fprintf fmt "@[%a ->@ %a;@]@," + Item.print item + aux t + ) + in + Format.fprintf fmt "{@[%a@,%a@]}" print_uid_opt uid print_map map + in + Format.fprintf fmt"@[%a@]@;" aux + +let fresh_var ?(name="shape-var") uid = + let var = Ident.create_local name in + var, { uid = Some uid; desc = Var var } + +let for_unnamed_functor_param = Ident.create_local "()" + +let var uid id = + { uid = Some uid; desc = Var id } + +let abs ?uid var body = + { uid; desc = Abs (var, body) } + +let str ?uid map = + { uid; desc = Struct map } + +let leaf uid = + { uid = Some uid; desc = Leaf } + +let proj ?uid t item = + match t.desc with + | Leaf -> + (* When stuck projecting in a leaf we propagate the leaf + as a best effort *) + t + | Struct map -> + begin try Item.Map.find item map + with Not_found -> t (* ill-typed program *) + end + | _ -> + { uid; desc = Proj (t, item) } + +let app ?uid f ~arg = + { uid; desc = App (f, arg) } + +let decompose_abs t = + match t.desc with + | Abs (x, t) -> Some (x, t) + | _ -> None + +module Make_reduce(Params : sig + type env + val fuel : int + val read_unit_shape : unit_name:string -> t option + val find_shape : env -> Ident.t -> t +end) = struct + (* We implement a strong call-by-need reduction, following an + evaluator from Nathanaelle Courant. *) + + type nf = { uid: Uid.t option; desc: nf_desc } + and nf_desc = + | NVar of var + | NApp of nf * nf + | NAbs of local_env * var * t * delayed_nf + | NStruct of delayed_nf Item.Map.t + | NProj of nf * Item.t + | NLeaf + | NComp_unit of string + | NoFuelLeft of desc + (* A type of normal forms for strong call-by-need evaluation. + The normal form of an abstraction + Abs(x, t) + is a closure + NAbs(env, x, t, dnf) + when [env] is the local environment, and [dnf] is a delayed + normal form of [t]. + + A "delayed normal form" is morally equivalent to (nf Lazy.t), but + we use a different representation that is compatible with + memoization (lazy values are not hashable/comparable by default + comparison functions): we represent a delayed normal form as + just a not-yet-computed pair [local_env * t] of a term in a + local environment -- we could also see this as a term under + an explicit substitution. This delayed thunked is "forced" + by calling the normalization function as usual, but duplicate + computations are precisely avoided by memoization. + *) + and delayed_nf = Thunk of local_env * t + + and local_env = delayed_nf option Ident.Map.t + (* When reducing in the body of an abstraction [Abs(x, body)], we + bind [x] to [None] in the environment. [Some v] is used for + actual substitutions, for example in [App(Abs(x, body), t)], when + [v] is a thunk that will evaluate to the normal form of [t]. *) + + let improve_uid uid (nf : nf) = + match nf.uid with + | Some _ -> nf + | None -> { nf with uid } + + let in_memo_table memo_table memo_key f arg = + match Hashtbl.find memo_table memo_key with + | res -> res + | exception Not_found -> + let res = f arg in + Hashtbl.replace memo_table memo_key res; + res + + type env = { + fuel: int ref; + global_env: Params.env; + local_env: local_env; + reduce_memo_table: (local_env * t, nf) Hashtbl.t; + read_back_memo_table: (nf, t) Hashtbl.t; + } + + let bind env var shape = + { env with local_env = Ident.Map.add var shape env.local_env } + + let rec reduce_ env t = + let memo_key = (env.local_env, t) in + in_memo_table env.reduce_memo_table memo_key (reduce__ env) t + (* Memoization is absolutely essential for performance on this + problem, because the normal forms we build can in some real-world + cases contain an exponential amount of redundancy. Memoization + can avoid the repeated evaluation of identical subterms, + providing a large speedup, but even more importantly it + implicitly shares the memory of the repeated results, providing + much smaller normal forms (that blow up again if printed back + as trees). A functor-heavy file from Irmin has its shape normal + form decrease from 100Mio to 2.5Mio when memoization is enabled. + + Note: the local environment is part of the memoization key, while + it is defined using a type Ident.Map.t of non-canonical balanced + trees: two maps could have exactly the same items, but be + balanced differently and therefore hash differently, reducing + the effectivenss of memoization. + This could in theory happen, say, with the two programs + (fun x -> fun y -> ...) + and + (fun y -> fun x -> ...) + having "the same" local environments, with additions done in + a different order, giving non-structurally-equal trees. Should we + define our own hash functions to provide robust hashing on + environments? + + We believe that the answer is "no": this problem does not occur + in practice. We can assume that identifiers are unique on valid + typedtree fragments (identifier "stamps" distinguish + binding positions); in particular the two program fragments above + in fact bind *distinct* identifiers x (with different stamps) and + different identifiers y, so the environments are distinct. If two + environments are structurally the same, they must correspond to + the evaluation evnrionments of two sub-terms that are under + exactly the same scope of binders. So the two environments were + obtained by the same term traversal, adding binders in the same + order, giving the same balanced trees: the environments have the + same hash. +*) + + and reduce__ ({fuel; global_env; local_env; _} as env) (t : t) = + let reduce env t = reduce_ env t in + let delay_reduce env t = Thunk (env.local_env, t) in + let force (Thunk (local_env, t)) = + reduce { env with local_env } t in + let return desc : nf = { uid = t.uid; desc } in + if !fuel < 0 then return (NoFuelLeft t.desc) + else + match t.desc with + | Comp_unit unit_name -> + begin match Params.read_unit_shape ~unit_name with + | Some t -> reduce env t + | None -> return (NComp_unit unit_name) + end + | App(f, arg) -> + let f = reduce env f in + begin match f.desc with + | NAbs(clos_env, var, body, _body_nf) -> + let arg = delay_reduce env arg in + let env = bind { env with local_env = clos_env } var (Some arg) in + reduce env body + |> improve_uid t.uid + | _ -> + let arg = reduce env arg in + return (NApp(f, arg)) + end + | Proj(str, item) -> + let str = reduce env str in + let nored () = return (NProj(str, item)) in + begin match str.desc with + | NStruct (items) -> + begin match Item.Map.find item items with + | exception Not_found -> nored () + | nf -> + force nf + |> improve_uid t.uid + end + | _ -> + nored () + end + | Abs(var, body) -> + let body_nf = delay_reduce (bind env var None) body in + return (NAbs(local_env, var, body, body_nf)) + | Var id -> + begin match Ident.Map.find id local_env with + (* Note: instead of binding abstraction-bound variables to + [None], we could unify it with the [Some v] case by + binding the bound variable [x] to [NVar x]. + + One reason to distinguish the situations is that we can + provide a different [Uid.t] location; for bound + variables, we use the [Uid.t] of the bound occurrence + (not the binding site), whereas for bound values we use + their binding-time [Uid.t]. *) + | None -> return (NVar id) + | Some def -> force def + | exception Not_found -> + match Params.find_shape global_env id with + | exception Not_found -> return (NVar id) + | res when res = t -> return (NVar id) + | res -> + decr fuel; + reduce env res + end + | Leaf -> return NLeaf + | Struct m -> + let mnf = Item.Map.map (delay_reduce env) m in + return (NStruct mnf) + + let rec read_back env (nf : nf) : t = + in_memo_table env.read_back_memo_table nf (read_back_ env) nf + (* The [nf] normal form we receive may contain a lot of internal + sharing due to the use of memoization in the evaluator. We have + to memoize here again, otherwise the sharing is lost by mapping + over the term as a tree. *) + + and read_back_ env (nf : nf) : t = + { uid = nf.uid; desc = read_back_desc env nf.desc } + + and read_back_desc env desc = + let read_back nf = read_back env nf in + let read_back_force (Thunk (local_env, t)) = + read_back (reduce_ { env with local_env } t) in + match desc with + | NVar v -> + Var v + | NApp (nft, nfu) -> + App(read_back nft, read_back nfu) + | NAbs (_env, x, _t, nf) -> + Abs(x, read_back_force nf) + | NStruct nstr -> + Struct (Item.Map.map read_back_force nstr) + | NProj (nf, item) -> + Proj (read_back nf, item) + | NLeaf -> Leaf + | NComp_unit s -> Comp_unit s + | NoFuelLeft t -> t + + let reduce global_env t = + let fuel = ref Params.fuel in + let reduce_memo_table = Hashtbl.create 42 in + let read_back_memo_table = Hashtbl.create 42 in + let local_env = Ident.Map.empty in + let env = { + fuel; + global_env; + reduce_memo_table; + read_back_memo_table; + local_env; + } in + reduce_ env t |> read_back env +end + +module Local_reduce = + (* Note: this definition with [type env = unit] is only suitable for + reduction of toplevel shapes -- shapes of compilation units, + where free variables are only Comp_unit names. If we wanted to + reduce shapes inside module signatures, we would need to take + a typing environment as parameter. *) + Make_reduce(struct + type env = unit + let fuel = 10 + let read_unit_shape ~unit_name:_ = None + let find_shape _env _id = raise Not_found + end) + +let local_reduce shape = + Local_reduce.reduce () shape + +let dummy_mod = { uid = None; desc = Struct Item.Map.empty } + +let of_path ~find_shape ~namespace = + let rec aux : Sig_component_kind.t -> Path.t -> t = fun ns -> function + | Pident id -> find_shape ns id + | Pdot (path, name) -> proj (aux Module path) (name, ns) + | Papply (p1, p2) -> app (aux Module p1) ~arg:(aux Module p2) + in + aux namespace + +let for_persistent_unit s = + { uid = Some (Compilation_unit s); + desc = Comp_unit s } + +let leaf_for_unpack = { uid = None; desc = Leaf } + +let set_uid_if_none t uid = + match t.uid with + | None -> { t with uid = Some uid } + | _ -> t + +module Map = struct + type shape = t + type nonrec t = t Item.Map.t + + let empty = Item.Map.empty + + let add t item shape = Item.Map.add item shape t + + let add_value t id uid = Item.Map.add (Item.value id) (leaf uid) t + let add_value_proj t id shape = + let item = Item.value id in + Item.Map.add item (proj shape item) t + + let add_type t id uid = Item.Map.add (Item.type_ id) (leaf uid) t + let add_type_proj t id shape = + let item = Item.type_ id in + Item.Map.add item (proj shape item) t + + let add_module t id shape = Item.Map.add (Item.module_ id) shape t + let add_module_proj t id shape = + let item = Item.module_ id in + Item.Map.add item (proj shape item) t + + let add_module_type t id uid = + Item.Map.add (Item.module_type id) (leaf uid) t + let add_module_type_proj t id shape = + let item = Item.module_type id in + Item.Map.add item (proj shape item) t + + let add_extcons t id uid = + Item.Map.add (Item.extension_constructor id) (leaf uid) t + let add_extcons_proj t id shape = + let item = Item.extension_constructor id in + Item.Map.add item (proj shape item) t + + let add_class t id uid = Item.Map.add (Item.class_ id) (leaf uid) t + let add_class_proj t id shape = + let item = Item.class_ id in + Item.Map.add item (proj shape item) t + + let add_class_type t id uid = Item.Map.add (Item.class_type id) (leaf uid) t + let add_class_type_proj t id shape = + let item = Item.class_type id in + Item.Map.add item (proj shape item) t +end diff --git a/ocaml/typing/shape.mli b/ocaml/typing/shape.mli new file mode 100644 index 00000000000..e1dc6bed331 --- /dev/null +++ b/ocaml/typing/shape.mli @@ -0,0 +1,158 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Ulysse Gérard, Thomas Refis, Tarides *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module Uid : sig + type t = private + | Compilation_unit of string + | Item of { comp_unit: string; id: int } + | Internal + | Predef of string + + val reinit : unit -> unit + + val mk : current_unit:Compilation_unit.t option -> t + val of_compilation_unit_id : Compilation_unit.t -> t + val of_predef_id : Ident.t -> t + val internal_not_actually_unique : t + + val for_actual_declaration : t -> bool + + include Identifiable.S with type t := t +end + +module Sig_component_kind : sig + type t = + | Value + | Type + | Module + | Module_type + | Extension_constructor + | Class + | Class_type + + val to_string : t -> string + + (** Whether the name of a component of that kind can appear in a type. *) + val can_appear_in_types : t -> bool +end + +module Item : sig + type t + + val make : string -> Sig_component_kind.t -> t + + val value : Ident.t -> t + val type_ : Ident.t -> t + val module_ : Ident.t -> t + val module_type : Ident.t -> t + val extension_constructor : Ident.t -> t + val class_ : Ident.t -> t + val class_type : Ident.t -> t + + module Map : Map.S with type key = t +end + +type var = Ident.t +type t = { uid: Uid.t option; desc: desc } +and desc = + | Var of var + | Abs of var * t + | App of t * t + | Struct of t Item.Map.t + | Leaf + | Proj of t * Item.t + | Comp_unit of string + +val print : Format.formatter -> t -> unit + +(* Smart constructors *) + +val for_unnamed_functor_param : var +val fresh_var : ?name:string -> Uid.t -> var * t + +val var : Uid.t -> Ident.t -> t +val abs : ?uid:Uid.t -> var -> t -> t +val app : ?uid:Uid.t -> t -> arg:t -> t +val str : ?uid:Uid.t -> t Item.Map.t -> t +val proj : ?uid:Uid.t -> t -> Item.t -> t +val leaf : Uid.t -> t + +val decompose_abs : t -> (var * t) option + +(* CR lmaurer: Should really take a [Compilation_unit.t] *) +val for_persistent_unit : string -> t +val leaf_for_unpack : t + +module Map : sig + type shape = t + type nonrec t = t Item.Map.t + + val empty : t + + val add : t -> Item.t -> shape -> t + + val add_value : t -> Ident.t -> Uid.t -> t + val add_value_proj : t -> Ident.t -> shape -> t + + val add_type : t -> Ident.t -> Uid.t -> t + val add_type_proj : t -> Ident.t -> shape -> t + + val add_module : t -> Ident.t -> shape -> t + val add_module_proj : t -> Ident.t -> shape -> t + + val add_module_type : t -> Ident.t -> Uid.t -> t + val add_module_type_proj : t -> Ident.t -> shape -> t + + val add_extcons : t -> Ident.t -> Uid.t -> t + val add_extcons_proj : t -> Ident.t -> shape -> t + + val add_class : t -> Ident.t -> Uid.t -> t + val add_class_proj : t -> Ident.t -> shape -> t + + val add_class_type : t -> Ident.t -> Uid.t -> t + val add_class_type_proj : t -> Ident.t -> shape -> t +end + +val dummy_mod : t + +val of_path : + find_shape:(Sig_component_kind.t -> Ident.t -> t) -> + namespace:Sig_component_kind.t -> Path.t -> t + +val set_uid_if_none : t -> Uid.t -> t + +(** The [Make_reduce] functor is used to generate a reduction function for + shapes. + + It is parametrized by: + - an environment and a function to find shapes by path in that environment + - a function to load the shape of an external compilation unit + - some fuel, which is used to bound recursion when dealing with recursive + shapes introduced by recursive modules. (FTR: merlin currently uses a + fuel of 10, which seems to be enough for most practical examples) +*) +module Make_reduce(Context : sig + type env + + val fuel : int + + val read_unit_shape : unit_name:string -> t option + + val find_shape : env -> Ident.t -> t + end) : sig + val reduce : Context.env -> t -> t +end + +val local_reduce : t -> t diff --git a/ocaml/typing/signature_group.ml b/ocaml/typing/signature_group.ml new file mode 100644 index 00000000000..b2cc7d49106 --- /dev/null +++ b/ocaml/typing/signature_group.ml @@ -0,0 +1,155 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Fold on a signature by syntactic group of items *) + +(** Classes and class types generate ghosts signature items, we group them + together before printing *) +type sig_item = + { + src: Types.signature_item; + post_ghosts: Types.signature_item list + (** ghost classes types are post-declared *); + } +let flatten x = x.src :: x.post_ghosts + +type core_rec_group = + | Not_rec of sig_item + | Rec_group of sig_item list + +let rec_items = function + | Not_rec x -> [x] + | Rec_group x -> x + +(** Private row types are manifested as a sequence of definitions + preceding a recursive group, we collect them and separate them from the + syntactic recursive group. *) +type rec_group = + { pre_ghosts: Types.signature_item list; group:core_rec_group } + +let next_group = function + | [] -> None + | src :: q -> + let ghosts, q = + match src with + | Types.Sig_class _ -> + (* a class declaration for [c] is followed by the ghost + declarations of class type [c], and types [c] and [#c] *) + begin match q with + | ct::t::ht::q -> [ct;t;ht], q + | _ -> assert false + end + | Types.Sig_class_type _ -> + (* a class type declaration for [ct] is followed by the ghost + declarations of types [ct] and [#ct] *) + begin match q with + | t::ht::q -> [t;ht], q + | _ -> assert false + end + | Types.(Sig_module _ | Sig_value _ | Sig_type _ | Sig_typext _ + | Sig_modtype _) -> + [],q + in + Some({src; post_ghosts=ghosts}, q) + +let recursive_sigitem = function + | Types.Sig_type(ident, _, rs, _) + | Types.Sig_class(ident,_,rs,_) + | Types.Sig_class_type (ident,_,rs,_) + | Types.Sig_module(ident, _, _, rs, _) -> Some (ident,rs) + | Types.(Sig_value _ | Sig_modtype _ | Sig_typext _ ) -> None + +let next x = + let cons_group pre group q = + let group = Rec_group (List.rev group) in + Some({ pre_ghosts=List.rev pre; group },q) + in + let rec not_in_group pre l = match next_group l with + | None -> + assert (pre=[]); + None + | Some(elt, q) -> + match recursive_sigitem elt.src with + | Some (id, _) when Btype.is_row_name (Ident.name id) -> + not_in_group (elt.src::pre) q + | None | Some (_, Types.Trec_not) -> + let sgroup = { pre_ghosts=List.rev pre; group=Not_rec elt } in + Some (sgroup,q) + | Some (id, Types.(Trec_first | Trec_next) ) -> + in_group ~pre ~ids:[id] ~group:[elt] q + and in_group ~pre ~ids ~group rem = match next_group rem with + | None -> cons_group pre group [] + | Some (elt,next) -> + match recursive_sigitem elt.src with + | Some (id, Types.Trec_next) -> + in_group ~pre ~ids:(id::ids) ~group:(elt::group) next + | None | Some (_, Types.(Trec_not|Trec_first)) -> + cons_group pre group rem + in + not_in_group [] x + +let seq l = Seq.unfold next l +let iter f l = Seq.iter f (seq l) +let fold f acc l = Seq.fold_left f acc (seq l) + +let update_rec_next rs rem = + match rs with + | Types.Trec_next -> rem + | Types.(Trec_first | Trec_not) -> + match rem with + | Types.Sig_type (id, decl, Trec_next, priv) :: rem -> + Types.Sig_type (id, decl, rs, priv) :: rem + | Types.Sig_module (id, pres, mty, Trec_next, priv) :: rem -> + Types.Sig_module (id, pres, mty, rs, priv) :: rem + | _ -> rem + +type in_place_patch = { + ghosts: Types.signature; + replace_by: Types.signature_item option; +} + + +let replace_in_place f sg = + let rec next_group f before signature = + match next signature with + | None -> None + | Some(item,sg) -> + core_group f ~before ~ghosts:item.pre_ghosts ~before_group:[] + (rec_items item.group) ~sg + and core_group f ~before ~ghosts ~before_group current ~sg = + let commit ghosts = before_group @ List.rev_append ghosts before in + match current with + | [] -> next_group f (commit ghosts) sg + | a :: q -> + match f ~ghosts a.src with + | Some (info, {ghosts; replace_by}) -> + let after = List.concat_map flatten q @ sg in + let after = match recursive_sigitem a.src, replace_by with + | None, _ | _, Some _ -> after + | Some (_,rs), None -> update_rec_next rs after + in + let before = match replace_by with + | None -> commit ghosts + | Some x -> x :: commit ghosts + in + let sg = List.rev_append before after in + Some(info, sg) + | None -> + let before_group = + List.rev_append a.post_ghosts (a.src :: before_group) + in + core_group f ~before ~ghosts ~before_group q ~sg + in + next_group f [] sg diff --git a/ocaml/typing/signature_group.mli b/ocaml/typing/signature_group.mli new file mode 100644 index 00000000000..0b736a5b455 --- /dev/null +++ b/ocaml/typing/signature_group.mli @@ -0,0 +1,85 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Iterate on signature by syntactic group of items + + Classes, class types and private row types adds ghost components to + the signature where they are defined. + + When editing or printing a signature it is therefore important to + identify those ghost components. + + This module provides type grouping together ghost components + with the corresponding core item (or recursive group) and + the corresponding iterators. +*) + +(** Classes and class types generate ghosts signature items, we group them + together before printing *) +type sig_item = + { + src: Types.signature_item (** the syntactic item *) +; + post_ghosts: Types.signature_item list + (** ghost classes types are post-declared *); + } + +(** [flatten sig_item] is [x.src :: x.post_ghosts] *) +val flatten: sig_item -> Types.signature + +(** A group of mutually recursive definition *) +type core_rec_group = + | Not_rec of sig_item + | Rec_group of sig_item list + +(** [rec_items group] is the list of sig_items in the group *) +val rec_items: core_rec_group -> sig_item list + +(** Private #row types are manifested as a sequence of definitions + preceding a recursive group, we collect them and separate them from the + syntactic recursive group. *) +type rec_group = + { pre_ghosts: Types.signature_item list; group:core_rec_group } + +(** The sequence [seq signature] iterates over [signature] {!rec_group} by + {!rec_group}. + The second element of the tuple in the {!full_seq} case is the not-yet + traversed part of the signature. +*) +val next: Types.signature -> (rec_group * Types.signature) option +val seq: Types.signature -> rec_group Seq.t + +val iter: (rec_group -> unit) -> Types.signature -> unit +val fold: ('acc -> rec_group -> 'acc) -> 'acc -> Types.signature -> 'acc + +(** Describe how to amend one element of a signature *) +type in_place_patch = { + ghosts: Types.signature; (** updated list of ghost items *) + replace_by: Types.signature_item option; + (** replacement for the selected item *) +} + +(** + [!replace_in_place patch sg] replaces the first element of the signature + for which [patch ~rec_group ~ghosts component] returns [Some (value,patch)]. + The [rec_group] argument is the remaining part of the mutually + recursive group of [component]. + The [ghosts] list is the current prefix of ghost components associated to + [component] +*) +val replace_in_place: + ( ghosts:Types.signature -> Types.signature_item + -> ('a * in_place_patch) option ) + -> Types.signature -> ('a * Types.signature) option diff --git a/ocaml/typing/stypes.ml b/ocaml/typing/stypes.ml index d467c0b6af8..d35cc889431 100644 --- a/ocaml/typing/stypes.ml +++ b/ocaml/typing/stypes.ml @@ -157,10 +157,9 @@ let print_info pp prev_loc ti = end; output_string pp "type(\n"; printtyp_reset_maybe loc; - Printtyp.mark_loops typ; Format.pp_print_string Format.str_formatter " "; Printtyp.wrap_printing_env ~error:false env - (fun () -> Printtyp.type_sch Format.str_formatter typ); + (fun () -> Printtyp.shared_type_scheme Format.str_formatter typ); Format.pp_print_newline Format.str_formatter (); let s = Format.flush_str_formatter () in output_string pp s; diff --git a/ocaml/typing/subst.ml b/ocaml/typing/subst.ml index 5c759151529..05060666a3a 100644 --- a/ocaml/typing/subst.ml +++ b/ocaml/typing/subst.ml @@ -29,15 +29,17 @@ type type_replacement = type t = { types: type_replacement Path.Map.t; modules: Path.t Path.Map.t; - modtypes: module_type Ident.Map.t; + modtypes: module_type Path.Map.t; for_saving: bool; + loc: Location.t option; } let identity = { types = Path.Map.empty; modules = Path.Map.empty; - modtypes = Ident.Map.empty; + modtypes = Path.Map.empty; for_saving = false; + loc = None; } let add_type_path id p s = { s with types = Path.Map.add id (Path p) s.types } @@ -49,12 +51,18 @@ let add_type_function id ~params ~body s = let add_module_path id p s = { s with modules = Path.Map.add id p s.modules } let add_module id p s = add_module_path (Pident id) p s -let add_modtype id ty s = { s with modtypes = Ident.Map.add id ty s.modtypes } +let add_modtype_path p ty s = { s with modtypes = Path.Map.add p ty s.modtypes } +let add_modtype id ty s = add_modtype_path (Pident id) ty s let for_saving s = { s with for_saving = true } +let change_locs s loc = { s with loc = Some loc } + let loc s x = - if s.for_saving && not !Clflags.keep_locs then Location.none else x + match s.loc with + | Some l -> l + | None -> + if s.for_saving && not !Clflags.keep_locs then Location.none else x let remove_loc = let open Ast_mapper in @@ -87,17 +95,18 @@ let rec module_path s path = | Papply(p1, p2) -> Papply(module_path s p1, module_path s p2) -let modtype_path s = function - Pident id as p -> - begin try - match Ident.Map.find id s.modtypes with - | Mty_ident p -> p - | _ -> fatal_error "Subst.modtype_path" - with Not_found -> p end - | Pdot(p, n) -> - Pdot(module_path s p, n) - | Papply _ -> - fatal_error "Subst.modtype_path" +let modtype_path s path = + match Path.Map.find path s.modtypes with + | Mty_ident p -> p + | Mty_alias _ | Mty_signature _ | Mty_functor _ -> + fatal_error "Subst.modtype_path" + | exception Not_found -> + match path with + | Pdot(p, n) -> + Pdot(module_path s p, n) + | Papply _ -> + fatal_error "Subst.modtype_path" + | Pident _ -> path let type_path s path = match Path.Map.find path s.types with @@ -131,7 +140,8 @@ let reset_for_saving () = new_id := -1 let newpersty desc = decr new_id; - { desc; level = generic_level; scope = Btype.lowest_level; id = !new_id } + create_expr + desc ~level:generic_level ~scope:Btype.lowest_level ~id:!new_id (* ensure that all occurrences of 'Tvar None' are physically shared *) let tvar_none = Tvar None @@ -145,22 +155,21 @@ let ctype_apply_env_empty = ref (fun _ -> assert false) (* Similar to [Ctype.nondep_type_rec]. *) let rec typexp copy_scope s ty = - let ty = repr ty in - match ty.desc with - Tvar _ | Tunivar _ as desc -> - if s.for_saving || ty.id < 0 then + let desc = get_desc ty in + match desc with + Tvar _ | Tunivar _ -> + if s.for_saving || get_id ty < 0 then let ty' = if s.for_saving then newpersty (norm desc) - else newty2 ty.level desc + else newty2 ~level:(get_level ty) desc in - For_copy.save_desc copy_scope ty desc; - ty.desc <- Tsubst ty'; + For_copy.redirect_desc copy_scope ty (Tsubst (ty', None)); ty' else ty - | Tsubst ty -> + | Tsubst (ty, _) -> ty | Tfield (m, k, _t1, _t2) when not s.for_saving && m = dummy_method - && field_kind_repr k <> Fabsent && (repr ty).level < generic_level -> + && field_kind_repr k <> Fabsent && get_level ty < generic_level -> (* do not copy the type of self when it is not generalized *) ty (* cannot do it, since it would omit substitution @@ -168,18 +177,18 @@ let rec typexp copy_scope s ty = ty *) | _ -> - let desc = ty.desc in - For_copy.save_desc copy_scope ty desc; let tm = row_of_type ty in let has_fixed_row = not (is_Tconstr ty) && is_constr_row ~allow_ident:false tm in (* Make a stub *) - let ty' = if s.for_saving then newpersty (Tvar None) else newgenvar () in - ty'.scope <- ty.scope; - ty.desc <- Tsubst ty'; - ty'.desc <- - begin if has_fixed_row then - match tm.desc with (* PR#7348 *) + let ty' = + if s.for_saving then newpersty (Tvar None) + else newgenstub ~scope:(get_scope ty) + in + For_copy.redirect_desc copy_scope ty (Tsubst (ty', None)); + let desc = + if has_fixed_row then + match get_desc tm with (* PR#7348 *) Tconstr (Pdot(m,i), tl, _abbrev) -> let i' = String.sub i 0 (String.length i - 4) in Tconstr(type_path s (Pdot(m,i')), tl, ref Mnil) @@ -193,8 +202,9 @@ let rec typexp copy_scope s ty = | Type_function { params; body } -> Tlink (!ctype_apply_env_empty params body args) end - | Tpackage(p, n, tl) -> - Tpackage(modtype_path s p, n, List.map (typexp copy_scope s) tl) + | Tpackage(p, fl) -> + Tpackage(modtype_path s p, + List.map (fun (n, ty) -> (n, typexp copy_scope s ty)) fl) | Tobject (t1, name) -> let t1' = typexp copy_scope s t1 in let name' = @@ -207,48 +217,53 @@ let rec typexp copy_scope s ty = in Tobject (t1', ref name') | Tvariant row -> - let row = row_repr row in - let more = repr row.row_more in + let more = row_more row in + let mored = get_desc more in (* We must substitute in a subtle way *) (* Tsubst takes a tuple containing the row var and the variant *) - begin match more.desc with - Tsubst {desc = Ttuple [_;ty2]} -> + begin match mored with + Tsubst (_, Some ty2) -> (* This variant type has been already copied *) - ty.desc <- Tsubst ty2; (* avoid Tlink in the new type *) + (* Change the stub to avoid Tlink in the new type *) + For_copy.redirect_desc copy_scope ty (Tsubst (ty2, None)); Tlink ty2 | _ -> let dup = - s.for_saving || more.level = generic_level || static_row row || - match more.desc with Tconstr _ -> true | _ -> false in + s.for_saving || get_level more = generic_level || + static_row row || is_Tconstr more in (* Various cases for the row variable *) let more' = - match more.desc with - Tsubst ty -> ty + match mored with + Tsubst (ty, None) -> ty | Tconstr _ | Tnil -> typexp copy_scope s more | Tunivar _ | Tvar _ -> - For_copy.save_desc copy_scope more more.desc; - if s.for_saving then newpersty (norm more.desc) else - if dup && is_Tvar more then newgenty more.desc else more + if s.for_saving then newpersty (norm mored) + else if dup && is_Tvar more then newgenty mored + else more | _ -> assert false in (* Register new type first for recursion *) - more.desc <- Tsubst(newgenty(Ttuple[more';ty'])); + For_copy.redirect_desc copy_scope more + (Tsubst (more', Some ty')); + (* TODO: check if more' can be eliminated *) (* Return a new copy *) let row = copy_row (typexp copy_scope s) true row (not dup) more' in - match row.row_name with + match row_name row with | Some (p, tl) -> - Tvariant {row with row_name = - if to_subst_by_type_function s p - then None - else Some (type_path s p, tl)} + let name = + if to_subst_by_type_function s p then None + else Some (type_path s p, tl) + in + Tvariant (set_row_name row name) | None -> Tvariant row end | Tfield(_label, kind, _t1, t2) when field_kind_repr kind = Fabsent -> Tlink (typexp copy_scope s t2) | _ -> copy_type_desc (typexp copy_scope s) desc - end; + in + Transient_expr.set_stub_desc ty' desc; ty' (* @@ -271,7 +286,7 @@ let label_declaration copy_scope s l = let constructor_arguments copy_scope s = function | Cstr_tuple l -> - Cstr_tuple (List.map (typexp copy_scope s) l) + Cstr_tuple (List.map (fun (ty, gf) -> (typexp copy_scope s ty, gf)) l) | Cstr_record l -> Cstr_record (List.map (label_declaration copy_scope s) l) @@ -291,8 +306,9 @@ let type_declaration' copy_scope s decl = type_kind = begin match decl.type_kind with Type_abstract -> Type_abstract - | Type_variant cstrs -> - Type_variant (List.map (constructor_declaration copy_scope s) cstrs) + | Type_variant (cstrs, rep) -> + Type_variant (List.map (constructor_declaration copy_scope s) cstrs, + rep) | Type_record(lbls, rep) -> Type_record (List.map (label_declaration copy_scope s) lbls, rep) | Type_open -> Type_open @@ -311,7 +327,7 @@ let type_declaration' copy_scope s decl = type_loc = loc s decl.type_loc; type_attributes = attrs s decl.type_attributes; type_immediate = decl.type_immediate; - type_unboxed = decl.type_unboxed; + type_unboxed_default = decl.type_unboxed_default; type_uid = decl.type_uid; } @@ -320,14 +336,15 @@ let type_declaration s decl = let class_signature copy_scope s sign = { csig_self = typexp copy_scope s sign.csig_self; + csig_self_row = typexp copy_scope s sign.csig_self_row; csig_vars = Vars.map - (function (m, v, t) -> (m, v, typexp copy_scope s t)) sign.csig_vars; - csig_concr = sign.csig_concr; - csig_inher = - List.map - (fun (p, tl) -> (type_path s p, List.map (typexp copy_scope s) tl)) - sign.csig_inher; + (function (m, v, t) -> (m, v, typexp copy_scope s t)) + sign.csig_vars; + csig_meths = + Meths.map + (function (p, v, t) -> (p, v, typexp copy_scope s t)) + sign.csig_meths; } let rec class_type copy_scope s = function @@ -404,13 +421,14 @@ let extension_constructor s ext = (* For every binding k |-> d of m1, add k |-> f d to m2 and return resulting merged map. *) - -let merge_tbls f m1 m2 = - Ident.Map.fold (fun k d accu -> Ident.Map.add k (f d) accu) m1 m2 - let merge_path_maps f m1 m2 = Path.Map.fold (fun k d accu -> Path.Map.add k (f d) accu) m1 m2 +let keep_latest_loc l1 l2 = + match l2 with + | None -> l1 + | Some _ -> l2 + let type_replacement s = function | Path p -> Path (type_path s p) | Type_function { params; body } -> @@ -453,7 +471,7 @@ module Lazy_types = struct | S_lazy of signature_item list and signature = - (scoping * t * signature', signature') EnvLazy.t + (scoping * t * signature', signature') Lazy_backtrack.t and signature_item = SigL_value of Ident.t * value_description * visibility @@ -548,7 +566,7 @@ and force_module_decl md = and lazy_modtype = function | Mty_ident p -> MtyL_ident p | Mty_signature sg -> - MtyL_signature (EnvLazy.create_forced (S_eager sg)) + MtyL_signature (Lazy_backtrack.create_forced (S_eager sg)) | Mty_functor (Unit, mty) -> MtyL_functor (Unit, lazy_modtype mty) | Mty_functor (Named (id, arg), res) -> MtyL_functor (Named (id, lazy_modtype arg), lazy_modtype res) @@ -556,15 +574,16 @@ and lazy_modtype = function and subst_lazy_modtype scoping s = function | MtyL_ident p -> - begin match p with - Pident id -> - begin match Ident.Map.find id s.modtypes with - | mty -> lazy_modtype mty - | exception Not_found -> MtyL_ident p end - | Pdot(p, n) -> - MtyL_ident(Pdot(module_path s p, n)) - | Papply _ -> - fatal_error "Subst.modtype" + begin match Path.Map.find p s.modtypes with + | mty -> lazy_modtype mty + | exception Not_found -> + begin match p with + | Pident _ -> MtyL_ident p + | Pdot(p, n) -> + MtyL_ident(Pdot(module_path s p, n)) + | Papply _ -> + fatal_error "Subst.modtype" + end end | MtyL_signature sg -> MtyL_signature(subst_lazy_signature scoping s sg) @@ -612,7 +631,7 @@ and force_modtype_decl mtd = mtd_uid = mtd.mtdl_uid } and subst_lazy_signature scoping s sg = - match EnvLazy.get_contents sg with + match Lazy_backtrack.get_contents sg with | Left (scoping', s', sg) -> let scoping = match scoping', scoping with @@ -620,15 +639,15 @@ and subst_lazy_signature scoping s sg = | _, (Make_local|Rescope _) -> scoping in let s = compose s' s in - EnvLazy.create (scoping, s, sg) + Lazy_backtrack.create (scoping, s, sg) | Right sg -> - EnvLazy.create (scoping, s, sg) + Lazy_backtrack.create (scoping, s, sg) and force_signature sg = List.map force_signature_item (force_signature_once sg) and force_signature_once sg = - lazy_signature' (EnvLazy.force force_signature_once' sg) + lazy_signature' (Lazy_backtrack.force force_signature_once' sg) and lazy_signature' = function | S_lazy sg -> sg @@ -700,8 +719,9 @@ and compose s1 s2 = if s2 == identity then s1 else { types = merge_path_maps (type_replacement s2) s1.types s2.types; modules = merge_path_maps (module_path s2) s1.modules s2.modules; - modtypes = merge_tbls (modtype Keep s2) s1.modtypes s2.modtypes; + modtypes = merge_path_maps (modtype Keep s2) s1.modtypes s2.modtypes; for_saving = s1.for_saving || s2.for_saving; + loc = keep_latest_loc s1.loc s2.loc; } @@ -715,8 +735,8 @@ module Lazy = struct let of_module_decl = lazy_module_decl let of_modtype = lazy_modtype let of_modtype_decl = lazy_modtype_decl - let of_signature sg = EnvLazy.create_forced (S_eager sg) - let of_signature_items sg = EnvLazy.create_forced (S_lazy sg) + let of_signature sg = Lazy_backtrack.create_forced (S_eager sg) + let of_signature_items sg = Lazy_backtrack.create_forced (S_lazy sg) let of_signature_item = lazy_signature_item let module_decl = subst_lazy_module_decl diff --git a/ocaml/typing/subst.mli b/ocaml/typing/subst.mli index b5188eb2ce3..b55d2cc6f24 100644 --- a/ocaml/typing/subst.mli +++ b/ocaml/typing/subst.mli @@ -40,8 +40,11 @@ val add_type_function: val add_module: Ident.t -> Path.t -> t -> t val add_module_path: Path.t -> Path.t -> t -> t val add_modtype: Ident.t -> module_type -> t -> t +val add_modtype_path: Path.t -> module_type -> t -> t + val for_saving: t -> t val reset_for_saving: unit -> unit +val change_locs: t -> Location.t -> t val module_path: t -> Path.t -> Path.t val type_path: t -> Path.t -> Path.t diff --git a/ocaml/typing/tast_iterator.ml b/ocaml/typing/tast_iterator.ml index 546963f9b6f..42cd8c240d2 100644 --- a/ocaml/typing/tast_iterator.ml +++ b/ocaml/typing/tast_iterator.ml @@ -117,8 +117,10 @@ let value_description sub x = sub.typ sub x.val_desc let label_decl sub {ld_type; _} = sub.typ sub ld_type +let field_decl sub (ty, _) = sub.typ sub ty + let constructor_args sub = function - | Cstr_tuple l -> List.iter (sub.typ sub) l + | Cstr_tuple l -> List.iter (field_decl sub) l | Cstr_record l -> List.iter (label_decl sub) l let constructor_decl sub {cd_args; cd_res; _} = @@ -152,7 +154,7 @@ let type_exception sub {tyexn_constructor; _} = let extension_constructor sub {ext_kind; _} = match ext_kind with - | Text_decl (ctl, cto) -> + | Text_decl (_, ctl, cto) -> constructor_args sub ctl; Option.iter (sub.typ sub) cto | Text_rebind _ -> () @@ -173,7 +175,9 @@ let pat | Tpat_var _ -> () | Tpat_constant _ -> () | Tpat_tuple l -> List.iter (sub.pat sub) l - | Tpat_construct (_, _, l) -> List.iter (sub.pat sub) l + | Tpat_construct (_, _, l, vto) -> + List.iter (sub.pat sub) l; + Option.iter (fun (_ids, ct) -> sub.typ sub ct) vto | Tpat_variant (_, po, _) -> Option.iter (sub.pat sub) po | Tpat_record (l, _) -> List.iter (fun (_, _, i) -> sub.pat sub i) l | Tpat_array l -> List.iter (sub.pat sub) l @@ -255,9 +259,8 @@ let expr sub {exp_extra; exp_desc; exp_env; _} = sub.expr sub for_from; sub.expr sub for_to; sub.expr sub for_body - | Texp_send (exp, _, expo, _) -> - sub.expr sub exp; - Option.iter (sub.expr sub) expo + | Texp_send (exp, _, _) -> + sub.expr sub exp | Texp_new _ -> () | Texp_instvar _ -> () | Texp_setinstvar (_, _, _, exp) ->sub.expr sub exp @@ -311,6 +314,7 @@ let signature_item sub {sig_desc; sig_env; _} = | Tsig_modsubst x -> sub.module_substitution sub x | Tsig_recmodule list -> List.iter (sub.module_declaration sub) list | Tsig_modtype x -> sub.module_type_declaration sub x + | Tsig_modtypesubst x -> sub.module_type_declaration sub x | Tsig_include incl -> sig_include_infos sub incl | Tsig_class list -> List.iter (sub.class_description sub) list | Tsig_class_type list -> List.iter (sub.class_type_declaration sub) list @@ -343,6 +347,9 @@ let with_constraint sub = function | Twith_typesubst decl -> sub.type_declaration sub decl | Twith_module _ -> () | Twith_modsubst _ -> () + | Twith_modtype _ -> () + | Twith_modtypesubst _ -> () + let open_description sub {open_env; _} = sub.env sub open_env diff --git a/ocaml/typing/tast_mapper.ml b/ocaml/typing/tast_mapper.ml index 243607cc05a..e49991f7555 100644 --- a/ocaml/typing/tast_mapper.ml +++ b/ocaml/typing/tast_mapper.ml @@ -154,8 +154,12 @@ let label_decl sub x = let ld_type = sub.typ sub x.ld_type in {x with ld_type} +let field_decl sub (ty, gf) = + let ty = sub.typ sub ty in + (ty, gf) + let constructor_args sub = function - | Cstr_tuple l -> Cstr_tuple (List.map (sub.typ sub) l) + | Cstr_tuple l -> Cstr_tuple (List.map (field_decl sub) l) | Cstr_record l -> Cstr_record (List.map (label_decl sub) l) let constructor_decl sub cd = @@ -199,8 +203,8 @@ let type_exception sub x = let extension_constructor sub x = let ext_kind = match x.ext_kind with - Text_decl(ctl, cto) -> - Text_decl(constructor_args sub ctl, Option.map (sub.typ sub) cto) + Text_decl(v, ctl, cto) -> + Text_decl(v, constructor_args sub ctl, Option.map (sub.typ sub) cto) | Text_rebind _ as d -> d in {x with ext_kind} @@ -222,8 +226,9 @@ let pat | Tpat_var _ | Tpat_constant _ -> x.pat_desc | Tpat_tuple l -> Tpat_tuple (List.map (sub.pat sub) l) - | Tpat_construct (loc, cd, l) -> - Tpat_construct (loc, cd, List.map (sub.pat sub) l) + | Tpat_construct (loc, cd, l, vto) -> + let vto = Option.map (fun (vl,cty) -> vl, sub.typ sub cty) vto in + Tpat_construct (loc, cd, List.map (sub.pat sub) l, vto) | Tpat_variant (l, po, rd) -> Tpat_variant (l, Option.map (sub.pat sub) po, rd) | Tpat_record (l, closed) -> @@ -353,13 +358,12 @@ let expr sub x = Texp_for {tf with for_from = sub.expr sub tf.for_from; for_to = sub.expr sub tf.for_to; for_body = sub.expr sub tf.for_body} - | Texp_send (exp, meth, expo, pos) -> + | Texp_send (exp, meth, ap) -> Texp_send ( sub.expr sub exp, meth, - Option.map (sub.expr sub) expo, - pos + ap ) | Texp_new _ | Texp_instvar _ as d -> d @@ -458,6 +462,8 @@ let signature_item sub x = Tsig_recmodule (List.map (sub.module_declaration sub) list) | Tsig_modtype x -> Tsig_modtype (sub.module_type_declaration sub x) + | Tsig_modtypesubst x -> + Tsig_modtypesubst (sub.module_type_declaration sub x) | Tsig_include incl -> Tsig_include (sig_include_infos sub incl) | Tsig_class list -> @@ -499,6 +505,8 @@ let module_type sub x = let with_constraint sub = function | Twith_type decl -> Twith_type (sub.type_declaration sub decl) | Twith_typesubst decl -> Twith_typesubst (sub.type_declaration sub decl) + | Twith_modtype mty -> Twith_modtype (sub.module_type sub mty) + | Twith_modtypesubst mty -> Twith_modtypesubst (sub.module_type sub mty) | Twith_module _ | Twith_modsubst _ as d -> d diff --git a/ocaml/typing/typeclass.ml b/ocaml/typing/typeclass.ml index 83002dd7f01..864df442311 100644 --- a/ocaml/typing/typeclass.ml +++ b/ocaml/typing/typeclass.ml @@ -20,8 +20,6 @@ open Types open Typecore open Typetexp open Format -module Value_mode = Btype.Value_mode -module Alloc_mode = Btype.Alloc_mode type 'a class_info = { cls_id : Ident.t; @@ -62,15 +60,26 @@ type 'a full_class = { arity: int; pub_meths: string list; coe: Warnings.loc list; - expr: 'a; req: 'a Typedtree.class_infos; } -type class_env = { val_env : Env.t; met_env : Env.t; par_env : Env.t } +type kind = + | Object + | Class + | Class_type + +type final = + | Final + | Not_final + +let kind_of_final = function + | Final -> Object + | Not_final -> Class type error = - Unconsistent_constraint of Ctype.Unification_trace.t - | Field_type_mismatch of string * string * Ctype.Unification_trace.t + | Unconsistent_constraint of Errortrace.unification_error + | Field_type_mismatch of string * string * Errortrace.unification_error + | Unexpected_field of type_expr * string | Structure_expected of class_type | Cannot_apply of class_type | Apply_wrong_label of arg_label @@ -79,23 +88,26 @@ type error = | Unbound_class_2 of Longident.t | Unbound_class_type_2 of Longident.t | Abbrev_type_clash of type_expr * type_expr * type_expr - | Constructor_type_mismatch of string * Ctype.Unification_trace.t - | Virtual_class of bool * bool * string list * string list + | Constructor_type_mismatch of string * Errortrace.unification_error + | Virtual_class of kind * string list * string list + | Undeclared_methods of kind * string list | Parameter_arity_mismatch of Longident.t * int * int - | Parameter_mismatch of Ctype.Unification_trace.t + | Parameter_mismatch of Errortrace.unification_error | Bad_parameters of Ident.t * type_expr * type_expr | Class_match_failure of Ctype.class_match_failure list | Unbound_val of string - | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure + | Unbound_type_var of + (formatter -> unit) * (type_expr * bool * string * type_expr) | Non_generalizable_class of Ident.t * Types.class_declaration | Cannot_coerce_self of type_expr | Non_collapsable_conjunction of - Ident.t * Types.class_declaration * Ctype.Unification_trace.t - | Final_self_clash of Ctype.Unification_trace.t + Ident.t * Types.class_declaration * Errortrace.unification_error + | Self_clash of Errortrace.unification_error | Mutability_mismatch of string * mutable_flag | No_overriding of string * string | Duplicate of string * string - | Closing_self_type of type_expr + | Closing_self_type of class_signature + | Polymorphic_class_parameter exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -111,17 +123,6 @@ let ctyp desc typ env loc = { ctyp_desc = desc; ctyp_type = typ; ctyp_loc = loc; ctyp_env = env; ctyp_attributes = [] } - (**********************) - (* Useful constants *) - (**********************) - - -(* - Self type have a dummy private method, thus preventing it to become - closed. -*) -let dummy_method = Btype.dummy_method - (* Path associated to the temporary class type of a class being typed (its constructor is not available). @@ -134,42 +135,55 @@ let unbound_class = (* Some operations on class types *) (************************************) +let extract_constraints cty = + let sign = Btype.signature_of_class_type cty in + (Btype.instance_vars sign, + Btype.methods sign, + Btype.concrete_methods sign) + +(* Record a class type *) +let rc node = + Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node); + node -(* Fully expand the head of a class type *) -let rec scrape_class_type = - function - Cty_constr (_, _, cty) -> scrape_class_type cty - | cty -> cty - -(* Generalize a class type *) -let rec generalize_class_type gen = - function - Cty_constr (_, params, cty) -> - List.iter gen params; - generalize_class_type gen cty - | Cty_signature {csig_self = sty; csig_vars = vars; csig_inher = inher} -> - gen sty; - Vars.iter (fun _ (_, _, ty) -> gen ty) vars; - List.iter (fun (_,tl) -> List.iter gen tl) inher - | Cty_arrow (_, ty, cty) -> - gen ty; - generalize_class_type gen cty - -let generalize_class_type vars = - let gen = if vars then Ctype.generalize else Ctype.generalize_structure in - generalize_class_type gen - -(* Return the virtual methods of a class type *) -let virtual_methods sign = - let (fields, _) = - Ctype.flatten_fields (Ctype.object_fields sign.Types.csig_self) +let update_class_signature loc env ~warn_implicit_public virt kind sign = + let implicit_public, implicit_declared = + Ctype.update_class_signature env sign in - List.fold_left - (fun virt (lab, _, _) -> - if lab = dummy_method then virt else - if Concr.mem lab sign.csig_concr then virt else - lab::virt) - [] fields + if implicit_declared <> [] then begin + match virt with + | Virtual -> () (* Should perhaps emit warning 17 here *) + | Concrete -> + raise (Error(loc, env, Undeclared_methods(kind, implicit_declared))) + end; + if warn_implicit_public && implicit_public <> [] then begin + Location.prerr_warning + loc (Warnings.Implicit_public_methods implicit_public) + end + +let complete_class_signature loc env virt kind sign = + update_class_signature loc env ~warn_implicit_public:false virt kind sign; + Ctype.hide_private_methods env sign + +let complete_class_type loc env virt kind typ = + let sign = Btype.signature_of_class_type typ in + complete_class_signature loc env virt kind sign + +let check_virtual loc env virt kind sign = + match virt with + | Virtual -> () + | Concrete -> + match Btype.virtual_methods sign, Btype.virtual_instance_vars sign with + | [], [] -> () + | meths, vars -> + raise(Error(loc, env, Virtual_class(kind, meths, vars))) + +let rec check_virtual_clty loc env virt kind clty = + match clty with + | Cty_constr(_, _, clty) | Cty_arrow(_, _, clty) -> + check_virtual_clty loc env virt kind clty + | Cty_signature sign -> + check_virtual loc env virt kind sign (* Return the constructor type associated to a class type *) let rec constructor_type constr cty = @@ -179,226 +193,70 @@ let rec constructor_type constr cty = | Cty_signature _ -> constr | Cty_arrow (l, ty, cty) -> - Ctype.newty (Tarrow ((l, Alloc_mode.global, Alloc_mode.global), - ty, constructor_type constr cty, Cok)) - -let rec class_body cty = - match cty with - Cty_constr _ -> - cty (* Only class bodies can be abbreviated *) - | Cty_signature _ -> - cty - | Cty_arrow (_, _, cty) -> - class_body cty - -let extract_constraints cty = - let sign = Ctype.signature_of_class_type cty in - (Vars.fold (fun lab _ vars -> lab :: vars) sign.csig_vars [], - begin let (fields, _) = - Ctype.flatten_fields (Ctype.object_fields sign.csig_self) - in - List.fold_left - (fun meths (lab, _, _) -> - if lab = dummy_method then meths else lab::meths) - [] fields - end, - sign.csig_concr) - -let rec abbreviate_class_type path params cty = - match cty with - Cty_constr (_, _, _) | Cty_signature _ -> - Cty_constr (path, params, cty) - | Cty_arrow (l, ty, cty) -> - Cty_arrow (l, ty, abbreviate_class_type path params cty) - -(* Check that all type variables are generalizable *) -(* Use Env.empty to prevent expansion of recursively defined object types; - cf. typing-poly/poly.ml *) -let closed_type ty = - Ctype.remove_mode_variables ty; Ctype.closed_schema Env.empty ty - -let rec closed_class_type = - function - Cty_constr (_, params, _) -> - List.for_all closed_type params - | Cty_signature sign -> - closed_type sign.csig_self - && - Vars.fold (fun _ (_, _, ty) cc -> closed_type ty && cc) - sign.csig_vars - true - | Cty_arrow (_, ty, cty) -> - closed_type ty - && - closed_class_type cty - -let closed_class cty = - List.for_all closed_type cty.cty_params - && - closed_class_type cty.cty_type - -let rec limited_generalize rv = - function - Cty_constr (_path, params, cty) -> - List.iter (Ctype.limited_generalize rv) params; - limited_generalize rv cty - | Cty_signature sign -> - Ctype.limited_generalize rv sign.csig_self; - Vars.iter (fun _ (_, _, ty) -> Ctype.limited_generalize rv ty) - sign.csig_vars; - List.iter (fun (_, tl) -> List.iter (Ctype.limited_generalize rv) tl) - sign.csig_inher - | Cty_arrow (_, ty, cty) -> - Ctype.limited_generalize rv ty; - limited_generalize rv cty - -(* Record a class type *) -let rc node = - Cmt_format.add_saved_type (Cmt_format.Partial_class_expr node); - node - + let arrow_desc = l, Alloc_mode.global, Alloc_mode.global in + let ty = Ctype.newmono ty in + Ctype.newty + (Tarrow (arrow_desc, ty, constructor_type constr cty, commu_ok)) (***********************************) (* Primitives for typing classes *) (***********************************) - -(* Enter a value in the method environment only *) -let enter_met_env ?check loc lab kind unbound_kind ty class_env = - let {val_env; met_env; par_env} = class_env in - let val_env = Env.enter_unbound_value lab unbound_kind val_env in - let par_env = Env.enter_unbound_value lab unbound_kind par_env in - let (id, met_env) = - Env.enter_value ?check lab - {val_type = ty; val_kind = kind; - val_attributes = []; Types.val_loc = loc; - val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } met_env +let raise_add_method_failure loc env label sign failure = + match (failure : Ctype.add_method_failure) with + | Ctype.Unexpected_method -> + raise(Error(loc, env, Unexpected_field (sign.Types.csig_self, label))) + | Ctype.Type_mismatch trace -> + raise(Error(loc, env, Field_type_mismatch ("method", label, trace))) + +let raise_add_instance_variable_failure loc env label failure = + match (failure : Ctype.add_instance_variable_failure) with + | Ctype.Mutability_mismatch mut -> + raise (Error(loc, env, Mutability_mismatch(label, mut))) + | Ctype.Type_mismatch trace -> + raise (Error(loc, env, + Field_type_mismatch("instance variable", label, trace))) + +let raise_inherit_class_signature_failure loc env sign = function + | Ctype.Self_type_mismatch trace -> + raise(Error(loc, env, Self_clash trace)) + | Ctype.Method(label, failure) -> + raise_add_method_failure loc env label sign failure + | Ctype.Instance_variable(label, failure) -> + raise_add_instance_variable_failure loc env label failure + +let add_method loc env label priv virt ty sign = + match Ctype.add_method env label priv virt ty sign with + | () -> () + | exception Ctype.Add_method_failed failure -> + raise_add_method_failure loc env label sign failure + +let add_instance_variable ~strict loc env label mut virt ty sign = + match Ctype.add_instance_variable ~strict env label mut virt ty sign with + | () -> () + | exception Ctype.Add_instance_variable_failed failure -> + raise_add_instance_variable_failure loc env label failure + +let inherit_class_signature ~strict loc env sign1 sign2 = + match Ctype.inherit_class_signature ~strict env sign1 sign2 with + | () -> () + | exception Ctype.Inherit_class_signature_failed failure -> + raise_inherit_class_signature_failure loc env sign1 failure + +let inherit_class_type ~strict loc env sign1 cty2 = + let sign2 = + match Btype.scrape_class_type cty2 with + | Cty_signature sign2 -> sign2 + | _ -> + raise(Error(loc, env, Structure_expected cty2)) in - let class_env = {val_env; met_env; par_env} in - (id,class_env ) + inherit_class_signature ~strict loc env sign1 sign2 -(* Enter an instance variable in the environment *) -let enter_val cl_num vars inh lab mut virt ty class_env loc = - let val_env = class_env.val_env in - let (id, virt) = - try - let (id, mut', virt', ty') = Vars.find lab !vars in - if mut' <> mut then - raise (Error(loc, val_env, Mutability_mismatch(lab, mut))); - Ctype.unify val_env (Ctype.instance ty) (Ctype.instance ty'); - (if not inh then Some id else None), - (if virt' = Concrete then virt' else virt) - with - Ctype.Unify tr -> - raise (Error(loc, val_env, - Field_type_mismatch("instance variable", lab, tr))) - | Not_found -> None, virt - in - let (id, _) as result = - match id with Some id -> (id, class_env) - | None -> - enter_met_env Location.none lab (Val_ivar (mut, cl_num)) - Val_unbound_instance_variable ty class_env - in - vars := Vars.add lab (id, mut, virt, ty) !vars; - result - -let concr_vals vars = - Vars.fold - (fun id (_, vf, _) s -> if vf = Virtual then s else Concr.add id s) - vars Concr.empty - -let inheritance self_type env ovf concr_meths warn_vals loc parent = - match scrape_class_type parent with - Cty_signature cl_sig -> - - (* Methods *) - begin try - Ctype.unify env self_type cl_sig.csig_self - with Ctype.Unify trace -> - let open Ctype.Unification_trace in - match trace with - | Diff _ :: Incompatible_fields {name = n; _ } :: rem -> - raise(Error(loc, env, Field_type_mismatch ("method", n, rem))) - | _ -> assert false - end; - - (* Overriding *) - let over_meths = Concr.inter cl_sig.csig_concr concr_meths in - let concr_vals = concr_vals cl_sig.csig_vars in - let over_vals = Concr.inter concr_vals warn_vals in - begin match ovf with - Some Fresh -> - let cname = - match parent with - Cty_constr (p, _, _) -> Path.name p - | _ -> "inherited" - in - if not (Concr.is_empty over_meths) then - Location.prerr_warning loc - (Warnings.Method_override (cname :: Concr.elements over_meths)); - if not (Concr.is_empty over_vals) then - Location.prerr_warning loc - (Warnings.Instance_variable_override - (cname :: Concr.elements over_vals)); - | Some Override - when Concr.is_empty over_meths && Concr.is_empty over_vals -> - raise (Error(loc, env, No_overriding ("",""))) - | _ -> () - end; - - let concr_meths = Concr.union cl_sig.csig_concr concr_meths - and warn_vals = Concr.union concr_vals warn_vals in - - (cl_sig, concr_meths, warn_vals) - - | _ -> - raise(Error(loc, env, Structure_expected parent)) - -let virtual_method val_env meths self_type lab priv sty loc = - let (_, ty') = - Ctype.filter_self_method val_env lab priv meths self_type - in - let sty = Ast_helper.Typ.force_poly sty in - let cty = transl_simple_type val_env false Global sty in - let ty = cty.ctyp_type in - begin - try Ctype.unify val_env ty ty' with Ctype.Unify trace -> - raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace))); - end; - cty - -let delayed_meth_specs = ref [] - -let declare_method val_env meths self_type lab priv sty loc = - let (_, ty') = - Ctype.filter_self_method val_env lab priv meths self_type - in - let unif ty = - try Ctype.unify val_env ty ty' with Ctype.Unify trace -> - raise(Error(loc, val_env, Field_type_mismatch ("method", lab, trace))) - in - let sty = Ast_helper.Typ.force_poly sty in - match sty.ptyp_desc, priv with - Ptyp_poly ([],sty'), Public -> -(* TODO: we moved the [transl_simple_type_univars] outside of the lazy, -so that we can get an immediate value. Is that correct ? Ask Jacques. *) - let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) val_env loc in - delayed_meth_specs := - Warnings.mk_lazy (fun () -> - let cty = transl_simple_type_univars val_env sty' in - let ty = cty.ctyp_type in - unif ty; - returned_cty.ctyp_desc <- Ttyp_poly ([], cty); - returned_cty.ctyp_type <- ty; - ) :: - !delayed_meth_specs; - returned_cty - | _ -> - let cty = transl_simple_type val_env false Global sty in - let ty = cty.ctyp_type in - unif ty; - cty +let unify_delayed_method_type loc env label ty expected_ty= + match Ctype.unify env ty expected_ty with + | () -> () + | exception Ctype.Unify trace -> + raise(Error(loc, env, Field_type_mismatch ("method", label, trace))) let type_constraint val_env sty sty' loc = let cty = transl_simple_type val_env false Global sty in @@ -406,8 +264,8 @@ let type_constraint val_env sty sty' loc = let cty' = transl_simple_type val_env false Global sty' in let ty' = cty'.ctyp_type in begin - try Ctype.unify val_env ty ty' with Ctype.Unify trace -> - raise(Error(loc, val_env, Unconsistent_constraint trace)); + try Ctype.unify val_env ty ty' with Ctype.Unify err -> + raise(Error(loc, val_env, Unconsistent_constraint err)); end; (cty, cty') @@ -420,115 +278,100 @@ let make_method loc cl_num expr = (*******************************) -let add_val lab (mut, virt, ty) val_sig = - let virt = - try - let (_mut', virt', _ty') = Vars.find lab val_sig in - if virt' = Concrete then virt' else virt - with Not_found -> virt - in - Vars.add lab (mut, virt, ty) val_sig - -let rec class_type_field env self_type meths arg ctf = - Builtin_attributes.warning_scope ctf.pctf_attributes - (fun () -> class_type_field_aux env self_type meths arg ctf) - -and class_type_field_aux env self_type meths - (fields, val_sig, concr_meths, inher) ctf = +let delayed_meth_specs = ref [] +let rec class_type_field env sign self_scope ctf = let loc = ctf.pctf_loc in let mkctf desc = { ctf_desc = desc; ctf_loc = loc; ctf_attributes = ctf.pctf_attributes } in + let mkctf_with_attrs f = + Builtin_attributes.warning_scope ctf.pctf_attributes + (fun () -> mkctf (f ())) + in match ctf.pctf_desc with - Pctf_inherit sparent -> - let parent = class_type env sparent in - let inher = - match parent.cltyp_type with - Cty_constr (p, tl, _) -> (p, tl) :: inher - | _ -> inher - in - let (cl_sig, concr_meths, _) = - inheritance self_type env None concr_meths Concr.empty sparent.pcty_loc - parent.cltyp_type - in - let val_sig = - Vars.fold add_val cl_sig.csig_vars val_sig in - (mkctf (Tctf_inherit parent) :: fields, - val_sig, concr_meths, inher) - + | Pctf_inherit sparent -> + mkctf_with_attrs + (fun () -> + let parent = class_type env Virtual self_scope sparent in + complete_class_type parent.cltyp_loc + env Virtual Class_type parent.cltyp_type; + inherit_class_type ~strict:false loc env sign parent.cltyp_type; + Tctf_inherit parent) | Pctf_val ({txt=lab}, mut, virt, sty) -> - let cty = transl_simple_type env false Global sty in - let ty = cty.ctyp_type in - (mkctf (Tctf_val (lab, mut, virt, cty)) :: fields, - add_val lab (mut, virt, ty) val_sig, concr_meths, inher) + mkctf_with_attrs + (fun () -> + let cty = transl_simple_type env false Global sty in + let ty = cty.ctyp_type in + add_instance_variable ~strict:false loc env lab mut virt ty sign; + Tctf_val (lab, mut, virt, cty)) | Pctf_method ({txt=lab}, priv, virt, sty) -> - let cty = - declare_method env meths self_type lab priv sty ctf.pctf_loc in - let concr_meths = - match virt with - | Concrete -> Concr.add lab concr_meths - | Virtual -> concr_meths - in - (mkctf (Tctf_method (lab, priv, virt, cty)) :: fields, - val_sig, concr_meths, inher) + mkctf_with_attrs + (fun () -> + let sty = Ast_helper.Typ.force_poly sty in + match sty.ptyp_desc, priv with + | Ptyp_poly ([],sty'), Public -> + let expected_ty = Ctype.newvar () in + add_method loc env lab priv virt expected_ty sign; + let returned_cty = ctyp Ttyp_any (Ctype.newty Tnil) env loc in + delayed_meth_specs := + Warnings.mk_lazy (fun () -> + let cty = transl_simple_type_univars env sty' in + let ty = cty.ctyp_type in + unify_delayed_method_type loc env lab ty expected_ty; + returned_cty.ctyp_desc <- Ttyp_poly ([], cty); + returned_cty.ctyp_type <- ty; + ) :: !delayed_meth_specs; + Tctf_method (lab, priv, virt, returned_cty) + | _ -> + let cty = transl_simple_type env false Global sty in + let ty = cty.ctyp_type in + add_method loc env lab priv virt ty sign; + Tctf_method (lab, priv, virt, cty)) | Pctf_constraint (sty, sty') -> - let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in - (mkctf (Tctf_constraint (cty, cty')) :: fields, - val_sig, concr_meths, inher) + mkctf_with_attrs + (fun () -> + let (cty, cty') = type_constraint env sty sty' ctf.pctf_loc in + Tctf_constraint (cty, cty')) | Pctf_attribute x -> Builtin_attributes.warning_attribute x; - (mkctf (Tctf_attribute x) :: fields, - val_sig, concr_meths, inher) + mkctf (Tctf_attribute x) | Pctf_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) -and class_signature env {pcsig_self=sty; pcsig_fields=sign} = - let meths = ref Meths.empty in +and class_signature virt env pcsig self_scope loc = + let {pcsig_self=sty; pcsig_fields=psign} = pcsig in + let sign = Ctype.new_class_signature () in + (* Introduce a dummy method preventing self type from being closed. *) + Ctype.add_dummy_method env ~scope:self_scope sign; + let self_cty = transl_simple_type env false Global sty in - let self_cty = { self_cty with - ctyp_type = Ctype.expand_head env self_cty.ctyp_type } in - let self_type = self_cty.ctyp_type in - - (* Check that the binder is a correct type, and introduce a dummy - method preventing self type from being closed. *) - let dummy_obj = Ctype.newvar () in - Ctype.unify env (Ctype.filter_method env dummy_method Private dummy_obj) - (Ctype.newty (Ttuple [])); + let self_type = self_cty.ctyp_type in begin try - Ctype.unify env self_type dummy_obj + Ctype.unify env self_type sign.csig_self with Ctype.Unify _ -> raise(Error(sty.ptyp_loc, env, Pattern_type_clash self_type)) end; (* Class type fields *) - let (rev_fields, val_sig, concr_meths, inher) = + let fields = Builtin_attributes.warning_scope [] - (fun () -> - List.fold_left (class_type_field env self_type meths) - ([], Vars.empty, Concr.empty, []) - sign - ) - in - let cty = {csig_self = self_type; - csig_vars = val_sig; - csig_concr = concr_meths; - csig_inher = inher} + (fun () -> List.map (class_type_field env sign self_scope) psign) in + check_virtual loc env virt Class_type sign; { csig_self = self_cty; - csig_fields = List.rev rev_fields; - csig_type = cty; - } + csig_fields = fields; + csig_type = sign; } -and class_type env scty = +and class_type env virt self_scope scty = Builtin_attributes.warning_scope scty.pcty_attributes - (fun () -> class_type_aux env scty) + (fun () -> class_type_aux env virt self_scope scty) -and class_type_aux env scty = +and class_type_aux env virt self_scope scty = let cltyp desc typ = { cltyp_desc = desc; @@ -539,13 +382,17 @@ and class_type_aux env scty = } in match scty.pcty_desc with - Pcty_constr (lid, styl) -> + | Pcty_constr (lid, styl) -> let (path, decl) = Env.lookup_cltype ~loc:scty.pcty_loc lid.txt env in if Path.same decl.clty_path unbound_class then raise(Error(scty.pcty_loc, env, Unbound_class_type_2 lid.txt)); let (params, clty) = Ctype.instance_class decl.clty_params decl.clty_type in + (* Adding a dummy method to the self type prevents it from being closed / + escaping. *) + Ctype.add_dummy_method env ~scope:self_scope + (Btype.signature_of_class_type clty); if List.length params <> List.length styl then raise(Error(scty.pcty_loc, env, Parameter_arity_mismatch (lid.txt, List.length params, @@ -555,17 +402,19 @@ and class_type_aux env scty = let cty' = transl_simple_type env false Global sty in let ty' = cty'.ctyp_type in begin - try Ctype.unify env ty' ty with Ctype.Unify trace -> - raise(Error(sty.ptyp_loc, env, Parameter_mismatch trace)) + try Ctype.unify env ty' ty with Ctype.Unify err -> + raise(Error(sty.ptyp_loc, env, Parameter_mismatch err)) end; cty' ) styl params in let typ = Cty_constr (path, params, clty) in + (* Check for unexpected virtual methods *) + check_virtual_clty scty.pcty_loc env virt Class_type typ; cltyp (Tcty_constr ( path, lid , ctys)) typ | Pcty_signature pcsig -> - let clsig = class_signature env pcsig in + let clsig = class_signature virt env pcsig self_scope scty.pcty_loc in let typ = Cty_signature clsig.csig_type in cltyp (Tcty_signature clsig) typ @@ -576,240 +425,535 @@ and class_type_aux env scty = if Btype.is_optional l then Ctype.newty (Tconstr(Predef.path_option,[ty], ref Mnil)) else ty in - let clty = class_type env scty in + let clty = class_type env virt self_scope scty in let typ = Cty_arrow (l, ty, clty.cltyp_type) in cltyp (Tcty_arrow (l, cty, clty)) typ | Pcty_open (od, e) -> let (od, newenv) = !type_open_descr env od in - let clty = class_type newenv e in + let clty = class_type newenv virt self_scope e in cltyp (Tcty_open (od, clty)) clty.cltyp_type | Pcty_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) -let class_type env scty = +let class_type env virt self_scope scty = delayed_meth_specs := []; - let cty = class_type env scty in + let cty = class_type env virt self_scope scty in List.iter Lazy.force (List.rev !delayed_meth_specs); delayed_meth_specs := []; cty (*******************************) -let rec class_field self_loc cl_num self_type meths vars arg cf = - Builtin_attributes.warning_scope cf.pcf_attributes - (fun () -> class_field_aux self_loc cl_num self_type meths vars arg cf) +let enter_ancestor_val name val_env = + Env.enter_unbound_value name Val_unbound_ancestor val_env -and class_field_aux self_loc cl_num self_type meths vars - (class_env, fields, concr_meths, warn_vals, inher, - local_meths, local_vals) cf = - let loc = cf.pcf_loc in - let mkcf desc = - { cf_desc = desc; cf_loc = loc; cf_attributes = cf.pcf_attributes } +let enter_self_val name val_env = + Env.enter_unbound_value name Val_unbound_self val_env + +let enter_instance_var_val name val_env = + Env.enter_unbound_value name Val_unbound_instance_variable val_env + +let enter_ancestor_met ~loc name ~sign ~meths ~cl_num ~ty ~attrs met_env = + let check s = Warnings.Unused_ancestor s in + let kind = Val_anc (sign, meths, cl_num) in + let desc = + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } in - let {val_env; met_env; par_env} = class_env in + Env.enter_value ~check name desc met_env + +let add_self_met loc id sign self_var_kind vars cl_num + as_var ty attrs met_env = + let check = + if as_var then (fun s -> Warnings.Unused_var s) + else (fun s -> Warnings.Unused_var_strict s) + in + let kind = Val_self (sign, self_var_kind, vars, cl_num) in + let desc = + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + in + Env.add_value ~check id desc met_env + +let add_instance_var_met loc label id sign cl_num attrs met_env = + let mut, ty = + match Vars.find label sign.csig_vars with + | (mut, _, ty) -> mut, ty + | exception Not_found -> assert false + in + let kind = Val_ivar (mut, cl_num) in + let desc = + { val_type = ty; val_kind = kind; + val_attributes = attrs; + Types.val_loc = loc; + val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + in + Env.add_value id desc met_env + +let add_instance_vars_met loc vars sign cl_num met_env = + List.fold_left + (fun met_env (label, id) -> + add_instance_var_met loc label id sign cl_num [] met_env) + met_env vars + +type intermediate_class_field = + | Inherit of + { override : override_flag; + parent : class_expr; + super : string option; + inherited_vars : (string * Ident.t) list; + super_meths : (string * Ident.t) list; + loc : Location.t; + attributes : attribute list; } + | Virtual_val of + { label : string loc; + mut : mutable_flag; + id : Ident.t; + cty : core_type; + already_declared : bool; + loc : Location.t; + attributes : attribute list; } + | Concrete_val of + { label : string loc; + mut : mutable_flag; + id : Ident.t; + override : override_flag; + definition : expression; + already_declared : bool; + loc : Location.t; + attributes : attribute list; } + | Virtual_method of + { label : string loc; + priv : private_flag; + cty : core_type; + loc : Location.t; + attributes : attribute list; } + | Concrete_method of + { label : string loc; + priv : private_flag; + override : override_flag; + sdefinition : Parsetree.expression; + warning_state : Warnings.state; + loc : Location.t; + attributes : attribute list; } + | Constraint of + { cty1 : core_type; + cty2 : core_type; + loc : Location.t; + attributes : attribute list; } + | Initializer of + { sexpr : Parsetree.expression; + warning_state : Warnings.state; + loc : Location.t; + attributes : attribute list; } + | Attribute of + { attribute : attribute; + loc : Location.t; + attributes : attribute list; } + +type first_pass_accummulater = + { rev_fields : intermediate_class_field list; + val_env : Env.t; + par_env : Env.t; + concrete_meths : MethSet.t; + concrete_vals : VarSet.t; + local_meths : MethSet.t; + local_vals : VarSet.t; + vars : Ident.t Vars.t; } + +let rec class_field_first_pass self_loc cl_num sign self_scope acc cf = + let { rev_fields; val_env; par_env; concrete_meths; concrete_vals; + local_meths; local_vals; vars } = acc + in + let loc = cf.pcf_loc in + let attributes = cf.pcf_attributes in + let with_attrs f = Builtin_attributes.warning_scope attributes f in match cf.pcf_desc with - Pcf_inherit (ovf, sparent, super) -> - let parent = class_expr cl_num val_env par_env sparent in - let inher = - match parent.cl_type with - Cty_constr (p, tl, _) -> (p, tl) :: inher - | _ -> inher - in - let (cl_sig, concr_meths, warn_vals) = - inheritance self_type val_env (Some ovf) concr_meths warn_vals - sparent.pcl_loc parent.cl_type - in - (* Variables *) - let (class_env, inh_vars) = - Vars.fold - (fun lab info (class_env, inh_vars) -> - let mut, vr, ty = info in - let (id, class_env) = - enter_val cl_num vars true lab mut vr ty class_env - sparent.pcl_loc ; - in - (class_env, (lab, id) :: inh_vars)) - cl_sig.csig_vars (class_env, []) - in - (* Inherited concrete methods *) - let inh_meths = - Concr.fold (fun lab rem -> (lab, Ident.create_local lab)::rem) - cl_sig.csig_concr [] + | Pcf_inherit (override, sparent, super) -> + with_attrs + (fun () -> + let parent = + class_expr cl_num val_env par_env + Virtual self_scope sparent + in + complete_class_type parent.cl_loc + par_env Virtual Class parent.cl_type; + inherit_class_type ~strict:true loc val_env sign parent.cl_type; + let parent_sign = Btype.signature_of_class_type parent.cl_type in + let new_concrete_meths = Btype.concrete_methods parent_sign in + let new_concrete_vals = Btype.concrete_instance_vars parent_sign in + let over_meths = MethSet.inter new_concrete_meths concrete_meths in + let over_vals = VarSet.inter new_concrete_vals concrete_vals in + begin match override with + | Fresh -> + let cname = + match parent.cl_type with + | Cty_constr (p, _, _) -> Path.name p + | _ -> "inherited" + in + if not (MethSet.is_empty over_meths) then + Location.prerr_warning loc + (Warnings.Method_override + (cname :: MethSet.elements over_meths)); + if not (VarSet.is_empty over_vals) then + Location.prerr_warning loc + (Warnings.Instance_variable_override + (cname :: VarSet.elements over_vals)); + | Override -> + if MethSet.is_empty over_meths && VarSet.is_empty over_vals then + raise (Error(loc, val_env, No_overriding ("",""))) + end; + let concrete_vals = VarSet.union new_concrete_vals concrete_vals in + let concrete_meths = + MethSet.union new_concrete_meths concrete_meths + in + let val_env, par_env, inherited_vars, vars = + Vars.fold + (fun label _ (val_env, par_env, inherited_vars, vars) -> + let val_env = enter_instance_var_val label val_env in + let par_env = enter_instance_var_val label par_env in + let id = Ident.create_local label in + let inherited_vars = (label, id) :: inherited_vars in + let vars = Vars.add label id vars in + (val_env, par_env, inherited_vars, vars)) + parent_sign.csig_vars (val_env, par_env, [], vars) + in + (* Methods available through super *) + let super_meths = + MethSet.fold + (fun label acc -> (label, Ident.create_local label) :: acc) + new_concrete_meths [] + in + (* Super *) + let (val_env, par_env, super) = + match super with + | None -> (val_env, par_env, None) + | Some {txt=name} -> + let val_env = enter_ancestor_val name val_env in + let par_env = enter_ancestor_val name par_env in + (val_env, par_env, Some name) + in + let field = + Inherit + { override; parent; super; inherited_vars; + super_meths; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields; val_env; par_env; + concrete_meths; concrete_vals; vars }) + | Pcf_val (label, mut, Cfk_virtual styp) -> + with_attrs + (fun () -> + if !Clflags.principal then Ctype.begin_def (); + let cty = Typetexp.transl_simple_type val_env false Global styp in + let ty = cty.ctyp_type in + if !Clflags.principal then begin + Ctype.end_def (); + Ctype.generalize_structure ty + end; + add_instance_variable ~strict:true loc val_env + label.txt mut Virtual ty sign; + let already_declared, val_env, par_env, id, vars = + match Vars.find label.txt vars with + | id -> true, val_env, par_env, id, vars + | exception Not_found -> + let name = label.txt in + let val_env = enter_instance_var_val name val_env in + let par_env = enter_instance_var_val name par_env in + let id = Ident.create_local name in + let vars = Vars.add label.txt id vars in + false, val_env, par_env, id, vars + in + let field = + Virtual_val + { label; mut; id; cty; already_declared; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields; val_env; par_env; vars }) + | Pcf_val (label, mut, Cfk_concrete (override, sdefinition)) -> + with_attrs + (fun () -> + if VarSet.mem label.txt local_vals then + raise(Error(loc, val_env, + Duplicate ("instance variable", label.txt))); + if VarSet.mem label.txt concrete_vals then begin + if override = Fresh then + Location.prerr_warning label.loc + (Warnings.Instance_variable_override[label.txt]) + end else begin + if override = Override then + raise(Error(loc, val_env, + No_overriding ("instance variable", label.txt))) + end; + if !Clflags.principal then Ctype.begin_def (); + let definition = type_exp val_env sdefinition in + if !Clflags.principal then begin + Ctype.end_def (); + Ctype.generalize_structure definition.exp_type + end; + add_instance_variable ~strict:true loc val_env + label.txt mut Concrete definition.exp_type sign; + let already_declared, val_env, par_env, id, vars = + match Vars.find label.txt vars with + | id -> true, val_env, par_env, id, vars + | exception Not_found -> + let name = label.txt in + let val_env = enter_instance_var_val name val_env in + let par_env = enter_instance_var_val name par_env in + let id = Ident.create_local name in + let vars = Vars.add label.txt id vars in + false, val_env, par_env, id, vars + in + let field = + Concrete_val + { label; mut; id; override; definition; + already_declared; loc; attributes } + in + let rev_fields = field :: rev_fields in + let concrete_vals = VarSet.add label.txt concrete_vals in + let local_vals = VarSet.add label.txt local_vals in + { acc with rev_fields; val_env; par_env; + concrete_vals; local_vals; vars }) + + | Pcf_method (label, priv, Cfk_virtual sty) -> + with_attrs + (fun () -> + let sty = Ast_helper.Typ.force_poly sty in + let cty = transl_simple_type val_env false Global sty in + let ty = cty.ctyp_type in + add_method loc val_env label.txt priv Virtual ty sign; + let field = + Virtual_method { label; priv; cty; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields }) + + | Pcf_method (label, priv, Cfk_concrete (override, expr)) -> + with_attrs + (fun () -> + if MethSet.mem label.txt local_meths then + raise(Error(loc, val_env, Duplicate ("method", label.txt))); + if MethSet.mem label.txt concrete_meths then begin + if override = Fresh then begin + Location.prerr_warning loc + (Warnings.Method_override [label.txt]) + end + end else begin + if override = Override then begin + raise(Error(loc, val_env, No_overriding("method", label.txt))) + end + end; + let expr = + match expr.pexp_desc with + | Pexp_poly _ -> expr + | _ -> Ast_helper.Exp.poly ~loc:expr.pexp_loc expr None + in + let sbody, sty = + match expr.pexp_desc with + | Pexp_poly (sbody, sty) -> sbody, sty + | _ -> assert false + in + let ty = + match sty with + | None -> Ctype.newvar () + | Some sty -> + let sty = Ast_helper.Typ.force_poly sty in + let cty' = + Typetexp.transl_simple_type val_env false Global sty + in + cty'.ctyp_type + in + add_method loc val_env label.txt priv Concrete ty sign; + begin + try + match get_desc ty with + | Tvar _ -> + let ty' = Ctype.newvar () in + Ctype.unify val_env (Ctype.newmono ty') ty; + type_approx val_env sbody ty' + | Tpoly (ty1, tl) -> + let _, ty1' = Ctype.instance_poly false tl ty1 in + type_approx val_env sbody ty1' + | _ -> assert false + with Ctype.Unify err -> + raise(Error(loc, val_env, + Field_type_mismatch ("method", label.txt, err))) + end; + let sdefinition = make_method self_loc cl_num expr in + let warning_state = Warnings.backup () in + let field = + Concrete_method + { label; priv; override; sdefinition; + warning_state; loc; attributes } + in + let rev_fields = field :: rev_fields in + let concrete_meths = MethSet.add label.txt concrete_meths in + let local_meths = MethSet.add label.txt local_meths in + { acc with rev_fields; concrete_meths; local_meths }) + + | Pcf_constraint (sty1, sty2) -> + with_attrs + (fun () -> + let (cty1, cty2) = type_constraint val_env sty1 sty2 loc in + let field = + Constraint { cty1; cty2; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields }) + + | Pcf_initializer sexpr -> + with_attrs + (fun () -> + let sexpr = make_method self_loc cl_num sexpr in + let warning_state = Warnings.backup () in + let field = + Initializer { sexpr; warning_state; loc; attributes } + in + let rev_fields = field :: rev_fields in + { acc with rev_fields }) + | Pcf_attribute attribute -> + Builtin_attributes.warning_attribute attribute; + let field = Attribute { attribute; loc; attributes } in + let rev_fields = field :: rev_fields in + { acc with rev_fields } + | Pcf_extension ext -> + raise (Error_forward (Builtin_attributes.error_of_extension ext)) + +and class_fields_first_pass self_loc cl_num sign self_scope + val_env par_env cfs = + let rev_fields = [] in + let concrete_meths = MethSet.empty in + let concrete_vals = VarSet.empty in + let local_meths = MethSet.empty in + let local_vals = VarSet.empty in + let vars = Vars.empty in + let init_acc = + { rev_fields; val_env; par_env; + concrete_meths; concrete_vals; + local_meths; local_vals; vars } + in + let acc = + Builtin_attributes.warning_scope [] + (fun () -> + List.fold_left + (class_field_first_pass self_loc cl_num sign self_scope) + init_acc cfs) + in + List.rev acc.rev_fields, acc.vars + +and class_field_second_pass cl_num sign met_env field = + let mkcf desc loc attrs = + { cf_desc = desc; cf_loc = loc; cf_attributes = attrs } + in + match field with + | Inherit { override; parent; super; + inherited_vars; super_meths; loc; attributes } -> + let met_env = + add_instance_vars_met loc inherited_vars sign cl_num met_env in - (* Super *) - let (class_env,super) = + let met_env = match super with - None -> - (class_env,None) - | Some {txt=name} -> - let (_id, class_env) = - enter_met_env ~check:(fun s -> Warnings.Unused_ancestor s) - sparent.pcl_loc name (Val_anc (inh_meths, cl_num)) - Val_unbound_ancestor self_type class_env + | None -> met_env + | Some name -> + let meths = + List.fold_left + (fun acc (label, id) -> Meths.add label id acc) + Meths.empty super_meths in - (class_env,Some name) - in - (class_env, - lazy (mkcf (Tcf_inherit (ovf, parent, super, inh_vars, inh_meths))) - :: fields, - concr_meths, warn_vals, inher, local_meths, local_vals) - - | Pcf_val (lab, mut, Cfk_virtual styp) -> - if !Clflags.principal then Ctype.begin_def (); - let cty = Typetexp.transl_simple_type val_env false Global styp in - let ty = cty.ctyp_type in - if !Clflags.principal then begin - Ctype.end_def (); - Ctype.generalize_structure ty - end; - let (id, class_env') = - enter_val cl_num vars false lab.txt mut Virtual ty - class_env loc - in - (class_env', - lazy (mkcf (Tcf_val (lab, mut, id, Tcfk_virtual cty, - met_env == class_env'.met_env))) - :: fields, - concr_meths, warn_vals, inher, local_meths, local_vals) - - | Pcf_val (lab, mut, Cfk_concrete (ovf, sexp)) -> - if Concr.mem lab.txt local_vals then - raise(Error(loc, val_env, Duplicate ("instance variable", lab.txt))); - if Concr.mem lab.txt warn_vals then begin - if ovf = Fresh then - Location.prerr_warning lab.loc - (Warnings.Instance_variable_override[lab.txt]) - end else begin - if ovf = Override then - raise(Error(loc, val_env, - No_overriding ("instance variable", lab.txt))) - end; - if !Clflags.principal then Ctype.begin_def (); - let exp = type_exp val_env sexp in - if !Clflags.principal then begin - Ctype.end_def (); - Ctype.generalize_structure exp.exp_type - end; - let (id, class_env') = - enter_val cl_num vars false lab.txt mut Concrete exp.exp_type - class_env loc + let ty = Btype.self_type parent.cl_type in + let attrs = [] in + let _id, met_env = + enter_ancestor_met ~loc name ~sign ~meths + ~cl_num ~ty ~attrs met_env + in + met_env in - (class_env', - lazy (mkcf (Tcf_val (lab, mut, id, - Tcfk_concrete (ovf, exp), met_env == class_env'.met_env))) - :: fields, - concr_meths, Concr.add lab.txt warn_vals, inher, local_meths, - Concr.add lab.txt local_vals) - - | Pcf_method (lab, priv, Cfk_virtual sty) -> - let cty = virtual_method val_env meths self_type lab.txt priv sty loc in - (class_env, - lazy (mkcf(Tcf_method (lab, priv, Tcfk_virtual cty))) - ::fields, - concr_meths, warn_vals, inher, local_meths, local_vals) - - | Pcf_method (lab, priv, Cfk_concrete (ovf, expr)) -> - let expr = - match expr.pexp_desc with - | Pexp_poly _ -> expr - | _ -> Ast_helper.Exp.poly ~loc:expr.pexp_loc expr None + let desc = + Tcf_inherit(override, parent, super, inherited_vars, super_meths) in - if Concr.mem lab.txt local_meths then - raise(Error(loc, val_env, Duplicate ("method", lab.txt))); - if Concr.mem lab.txt concr_meths then begin - if ovf = Fresh then - Location.prerr_warning loc (Warnings.Method_override [lab.txt]) - end else begin - if ovf = Override then - raise(Error(loc, val_env, No_overriding("method", lab.txt))) - end; - let (_, ty) = - Ctype.filter_self_method val_env lab.txt priv meths self_type + met_env, mkcf desc loc attributes + | Virtual_val { label; mut; id; cty; already_declared; loc; attributes } -> + let met_env = + if already_declared then met_env + else begin + add_instance_var_met loc label.txt id sign cl_num attributes met_env + end in - begin try match expr.pexp_desc with - Pexp_poly (sbody, sty) -> - begin match sty with None -> () - | Some sty -> - let sty = Ast_helper.Typ.force_poly sty in - let cty' = - Typetexp.transl_simple_type val_env false Global sty - in - let ty' = cty'.ctyp_type in - Ctype.unify val_env ty' ty - end; - begin match (Ctype.repr ty).desc with - Tvar _ -> - let ty' = Ctype.newvar () in - Ctype.unify val_env (Ctype.newty (Tpoly (ty', []))) ty; - Ctype.unify val_env (type_approx val_env sbody) ty' - | Tpoly (ty1, tl) -> - let _, ty1' = Ctype.instance_poly false tl ty1 in - let ty2 = type_approx val_env sbody in - Ctype.unify val_env ty2 ty1' - | _ -> assert false - end - | _ -> assert false - with Ctype.Unify trace -> - raise(Error(loc, val_env, - Field_type_mismatch ("method", lab.txt, trace))) - end; - let meth_expr = make_method self_loc cl_num expr in - (* backup variables for Pexp_override *) - let vars_local = !vars in - - let field = - Warnings.mk_lazy - (fun () -> - (* Read the generalized type *) - let (_, ty) = Meths.find lab.txt !meths in - let meth_type = mk_expected ( - Btype.newgenty (Tarrow((Nolabel, Alloc_mode.global, Alloc_mode.global), - self_type, ty, Cok)) - ) in - Ctype.raise_nongen_level (); - vars := vars_local; - let texp = type_expect met_env meth_expr meth_type in - Ctype.end_def (); - mkcf (Tcf_method (lab, priv, Tcfk_concrete (ovf, texp))) - ) + let kind = Tcfk_virtual cty in + let desc = Tcf_val(label, mut, id, kind, already_declared) in + met_env, mkcf desc loc attributes + | Concrete_val { label; mut; id; override; + definition; already_declared; loc; attributes } -> + let met_env = + if already_declared then met_env + else begin + add_instance_var_met loc label.txt id sign cl_num attributes met_env + end in - (class_env, field::fields, - Concr.add lab.txt concr_meths, warn_vals, inher, - Concr.add lab.txt local_meths, local_vals) - - | Pcf_constraint (sty, sty') -> - let (cty, cty') = type_constraint val_env sty sty' loc in - (class_env, - lazy (mkcf (Tcf_constraint (cty, cty'))) :: fields, - concr_meths, warn_vals, inher, local_meths, local_vals) - - | Pcf_initializer expr -> - let expr = make_method self_loc cl_num expr in - let vars_local = !vars in - let field = - lazy begin - Ctype.raise_nongen_level (); - let meth_type = mk_expected ( - Ctype.newty - (Tarrow ((Nolabel, Alloc_mode.global, Alloc_mode.global), self_type, - Ctype.instance Predef.type_unit, Cok)) - ) in - vars := vars_local; - let texp = type_expect met_env expr meth_type in - Ctype.end_def (); - mkcf (Tcf_initializer texp) - end in - (class_env, field::fields, concr_meths, warn_vals, - inher, local_meths, local_vals) - | Pcf_attribute x -> - Builtin_attributes.warning_attribute x; - (class_env, - lazy (mkcf (Tcf_attribute x)) :: fields, - concr_meths, warn_vals, inher, local_meths, local_vals) - | Pcf_extension ext -> - raise (Error_forward (Builtin_attributes.error_of_extension ext)) + let kind = Tcfk_concrete(override, definition) in + let desc = Tcf_val(label, mut, id, kind, already_declared) in + met_env, mkcf desc loc attributes + | Virtual_method { label; priv; cty; loc; attributes } -> + let kind = Tcfk_virtual cty in + let desc = Tcf_method(label, priv, kind) in + met_env, mkcf desc loc attributes + | Concrete_method { label; priv; override; + sdefinition; warning_state; loc; attributes } -> + Warnings.with_state warning_state + (fun () -> + let ty = Btype.method_type label.txt sign in + let self_type = sign.Types.csig_self in + let arrow_desc = Nolabel, Alloc_mode.global, Alloc_mode.global in + let self_param_type = Btype.newgenty (Tpoly(self_type, [])) in + let meth_type = + mk_expected (Btype.newgenty + (Tarrow(arrow_desc, self_param_type, ty, commu_ok))) + in + Ctype.raise_nongen_level (); + let texp = type_expect met_env sdefinition meth_type in + Ctype.end_def (); + let kind = Tcfk_concrete (override, texp) in + let desc = Tcf_method(label, priv, kind) in + met_env, mkcf desc loc attributes) + | Constraint { cty1; cty2; loc; attributes } -> + let desc = Tcf_constraint(cty1, cty2) in + met_env, mkcf desc loc attributes + | Initializer { sexpr; warning_state; loc; attributes } -> + Warnings.with_state warning_state + (fun () -> + Ctype.raise_nongen_level (); + let unit_type = Ctype.instance Predef.type_unit in + let self_param_type = Ctype.newmono sign.Types.csig_self in + let arrow_desc = Nolabel, Alloc_mode.global, Alloc_mode.global in + let meth_type = + mk_expected (Ctype.newty + (Tarrow (arrow_desc, self_param_type, unit_type, commu_ok))) + in + let texp = type_expect met_env sexpr meth_type in + Ctype.end_def (); + let desc = Tcf_initializer texp in + met_env, mkcf desc loc attributes) + | Attribute { attribute; loc; attributes; } -> + let desc = Tcf_attribute attribute in + met_env, mkcf desc loc attributes + +and class_fields_second_pass cl_num sign met_env fields = + let _, rev_cfs = + List.fold_left + (fun (met_env, cfs) field -> + let met_env, cf = + class_field_second_pass cl_num sign met_env field + in + met_env, cf :: cfs) + (met_env, []) fields + in + List.rev rev_cfs (* N.B. the self type of a final object type doesn't contain a dummy method in the beginning. @@ -820,7 +964,7 @@ and class_field_aux self_loc cl_num self_type meths vars somehow we've unified the self type of the object with the self type of a not yet finished class. When this happens, we cannot close the object type and must error. *) -and class_structure cl_num final val_env met_env loc +and class_structure cl_num virt self_scope final val_env met_env loc { pcstr_self = spat; pcstr_fields = str } = (* Environment for substructures *) let val_env = Env.add_lock Value_mode.global val_env in @@ -830,135 +974,101 @@ and class_structure cl_num final val_env met_env loc (* Location of self. Used for locations of self arguments *) let self_loc = {spat.ppat_loc with Location.loc_ghost = true} in - let self_type = Ctype.newobj (Ctype.newvar ()) in + let sign = Ctype.new_class_signature () in - (* Adding a dummy method to the self type prevents it from being closed / - escaping. - That isn't needed for objects though. *) - if not final then - Ctype.unify val_env - (Ctype.filter_method val_env dummy_method Private self_type) - (Ctype.newty (Ttuple [])); - - (* Private self is used for private method calls *) - let private_self = if final then Ctype.newvar () else self_type in + (* Adding a dummy method to the signature prevents it from being closed / + escaping. That isn't needed for objects though. *) + begin match final with + | Not_final -> Ctype.add_dummy_method val_env ~scope:self_scope sign; + | Final -> () + end; (* Self binder *) - let (pat, meths, vars, val_env, met_env, par_env) = - type_self_pattern cl_num private_self val_env met_env par_env spat + let (self_pat, self_pat_vars) = type_self_pattern val_env spat in + let val_env, par_env = + List.fold_right + (fun {pv_id; _} (val_env, par_env) -> + let name = Ident.name pv_id in + let val_env = enter_self_val name val_env in + let par_env = enter_self_val name par_env in + val_env, par_env) + self_pat_vars (val_env, par_env) in - let public_self = pat.pat_type in (* Check that the binder has a correct type *) - let ty = - if final then Ctype.newobj (Ctype.newvar()) else self_type in - begin try Ctype.unify val_env public_self ty with + begin try Ctype.unify val_env self_pat.pat_type sign.csig_self with Ctype.Unify _ -> - raise(Error(spat.ppat_loc, val_env, Pattern_type_clash public_self)) - end; - let get_methods ty = - (fst (Ctype.flatten_fields - (Ctype.object_fields (Ctype.expand_head val_env ty)))) in - if final then begin - (* Copy known information to still empty self_type *) - List.iter - (fun (lab,kind,ty) -> - let k = - if Btype.field_kind_repr kind = Fpresent then Public else Private in - try Ctype.unify val_env ty - (Ctype.filter_method val_env lab k self_type) - with _ -> assert false) - (get_methods public_self) + raise(Error(spat.ppat_loc, val_env, + Pattern_type_clash self_pat.pat_type)) end; (* Typing of class fields *) - let class_env = {val_env; met_env; par_env} in - let (_, fields, concr_meths, _, inher, _local_meths, _local_vals) = - Builtin_attributes.warning_scope [] - (fun () -> - List.fold_left (class_field self_loc cl_num self_type meths vars) - ( class_env,[], Concr.empty, Concr.empty, [], - Concr.empty, Concr.empty) - str - ) + let (fields, vars) = + class_fields_first_pass self_loc cl_num sign self_scope + val_env par_env str in - Ctype.unify val_env self_type (Ctype.newvar ()); (* useless ? *) - let sign = - {csig_self = public_self; - csig_vars = Vars.map (fun (_id, mut, vr, ty) -> (mut, vr, ty)) !vars; - csig_concr = concr_meths; - csig_inher = inher} in - let methods = get_methods self_type in - let priv_meths = - List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind <> Fpresent) - methods in - (* ensure that inherited methods are listed too *) - List.iter (fun (met, _kind, _ty) -> - if Meths.mem met !meths then () else - ignore (Ctype.filter_self_method val_env met Private meths self_type)) - methods; - if final then begin - (* Unify private_self and a copy of self_type. self_type will not - be modified after this point *) - if not (Ctype.close_object self_type) then - raise(Error(loc, val_env, Closing_self_type self_type)); - let mets = virtual_methods {sign with csig_self = self_type} in - let vals = - Vars.fold - (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l) - sign.csig_vars [] in - if mets <> [] || vals <> [] then - raise(Error(loc, val_env, Virtual_class(true, final, mets, vals))); - let self_methods = - List.fold_right - (fun (lab,kind,ty) rem -> - Ctype.newty(Tfield(lab, Btype.copy_kind kind, ty, rem))) - methods (Ctype.newty Tnil) in - begin try - Ctype.unify val_env private_self - (Ctype.newty (Tobject(self_methods, ref None))); - Ctype.unify val_env public_self self_type - with Ctype.Unify trace -> raise(Error(loc, val_env, Final_self_clash trace)) - end; - end; + let kind = kind_of_final final in - (* Typing of method bodies *) - (* if !Clflags.principal then *) begin - let ms = !meths in - (* Generalize the spine of methods accessed through self *) - Meths.iter (fun _ (_,ty) -> Ctype.generalize_spine ty) ms; - meths := - Meths.map (fun (id,ty) -> (id, Ctype.generic_instance ty)) ms; - (* But keep levels correct on the type of self *) - Meths.iter (fun _ (_,ty) -> Ctype.unify val_env ty (Ctype.newvar ())) ms + (* Check for unexpected virtual methods *) + check_virtual loc val_env virt kind sign; + + (* Update the class signature *) + update_class_signature loc val_env + ~warn_implicit_public:false virt kind sign; + + let meths = + Meths.fold + (fun label _ meths -> + Meths.add label (Ident.create_local label) meths) + sign.csig_meths Meths.empty + in + + (* Close the signature if it is final *) + begin match final with + | Not_final -> () + | Final -> + if not (Ctype.close_class_signature val_env sign) then + raise(Error(loc, val_env, Closing_self_type sign)); end; - let fields = List.map Lazy.force (List.rev fields) in - let meths = Meths.map (function (id, _ty) -> id) !meths in - - (* Check for private methods made public *) - let pub_meths' = - List.filter (fun (_,kind,_) -> Btype.field_kind_repr kind = Fpresent) - (get_methods public_self) in - let names = List.map (fun (x,_,_) -> x) in - let l1 = names priv_meths and l2 = names pub_meths' in - let added = List.filter (fun x -> List.mem x l1) l2 in - if added <> [] then - Location.prerr_warning loc (Warnings.Implicit_public_methods added); - let sign = if final then sign else - {sign with Types.csig_self = Ctype.expand_head val_env public_self} in - { - cstr_self = pat; + (* Typing of method bodies *) + Ctype.generalize_class_signature_spine val_env sign; + let self_var_kind = + match virt with + | Virtual -> Self_virtual(ref meths) + | Concrete -> Self_concrete meths + in + let met_env = + List.fold_right + (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} met_env -> + add_self_met pv_loc pv_id sign self_var_kind vars + cl_num pv_as_var pv_type pv_attributes met_env) + self_pat_vars met_env + in + let fields = + class_fields_second_pass cl_num sign met_env fields + in + + (* Update the class signature and warn about public methods made private *) + update_class_signature loc val_env + ~warn_implicit_public:true virt kind sign; + + let meths = + match self_var_kind with + | Self_virtual meths_ref -> !meths_ref + | Self_concrete meths -> meths + in + { cstr_self = self_pat; cstr_fields = fields; cstr_type = sign; - cstr_meths = meths}, sign (* redondant, since already in cstr_type *) + cstr_meths = meths; } -and class_expr cl_num val_env met_env scl = +and class_expr cl_num val_env met_env virt self_scope scl = Builtin_attributes.warning_scope scl.pcl_attributes - (fun () -> class_expr_aux cl_num val_env met_env scl) + (fun () -> class_expr_aux cl_num val_env met_env virt self_scope scl) -and class_expr_aux cl_num val_env met_env scl = +and class_expr_aux cl_num val_env met_env virt self_scope scl = match scl.pcl_desc with - Pcl_constr (lid, styl) -> + | Pcl_constr (lid, styl) -> let (path, decl) = Env.lookup_class ~loc:scl.pcl_loc lid.txt val_env in if Path.same decl.cty_path unbound_class then raise(Error(scl.pcl_loc, val_env, Unbound_class_2 lid.txt)); @@ -969,7 +1079,11 @@ and class_expr_aux cl_num val_env met_env scl = let (params, clty) = Ctype.instance_class decl.cty_params decl.cty_type in - let clty' = abbreviate_class_type path params clty in + let clty' = Btype.abbreviate_class_type path params clty in + (* Adding a dummy method to the self type prevents it from being closed / + escaping. *) + Ctype.add_dummy_method val_env ~scope:self_scope + (Btype.signature_of_class_type clty'); if List.length params <> List.length tyl then raise(Error(scl.pcl_loc, val_env, Parameter_arity_mismatch (lid.txt, List.length params, @@ -977,9 +1091,11 @@ and class_expr_aux cl_num val_env met_env scl = List.iter2 (fun cty' ty -> let ty' = cty'.ctyp_type in - try Ctype.unify val_env ty' ty with Ctype.Unify trace -> - raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch trace))) + try Ctype.unify val_env ty' ty with Ctype.Unify err -> + raise(Error(cty'.ctyp_loc, val_env, Parameter_mismatch err))) tyl params; + (* Check for unexpected virtual methods *) + check_virtual_clty scl.pcl_loc val_env virt Class clty'; let cl = rc {cl_desc = Tcl_ident (path, lid, tyl); cl_loc = scl.pcl_loc; @@ -996,22 +1112,26 @@ and class_expr_aux cl_num val_env met_env scl = cl_attributes = []; (* attributes are kept on the inner cl node *) } | Pcl_structure cl_str -> - let (desc, ty) = - class_structure cl_num false val_env met_env scl.pcl_loc cl_str in + let desc = + class_structure cl_num virt self_scope Not_final + val_env met_env scl.pcl_loc cl_str + in rc {cl_desc = Tcl_structure desc; cl_loc = scl.pcl_loc; - cl_type = Cty_signature ty; + cl_type = Cty_signature desc.cstr_type; cl_env = val_env; cl_attributes = scl.pcl_attributes; } | Pcl_fun (l, Some default, spat, sbody) -> + if has_poly_constraint spat then + raise(Error(spat.ppat_loc, val_env, Polymorphic_class_parameter)); let loc = default.pexp_loc in let open Ast_helper in let scases = [ Exp.case (Pat.construct ~loc (mknoloc (Longident.(Ldot (Lident "*predef*", "Some")))) - (Some (Pat.var ~loc (mknoloc "*sth*")))) + (Some ([], Pat.var ~loc (mknoloc "*sth*")))) (Exp.ident ~loc (mknoloc (Longident.Lident "*sth*"))); Exp.case @@ -1033,8 +1153,10 @@ and class_expr_aux cl_num val_env met_env scl = (* Note: we don't put the '#default' attribute, as it is not detected for class-level let bindings. See #5975.*) in - class_expr cl_num val_env met_env sfun + class_expr cl_num val_env met_env virt self_scope sfun | Pcl_fun (l, None, spat, scl') -> + if has_poly_constraint spat then + raise(Error(spat.ppat_loc, val_env, Polymorphic_class_parameter)); if !Clflags.principal then Ctype.begin_def (); let (pat, pv, val_env', met_env) = Typecore.type_class_arg_pattern cl_num val_env met_env l spat @@ -1074,7 +1196,7 @@ and class_expr_aux cl_num val_env met_env scl = in let val_env' = Env.add_lock Value_mode.global val_env' in Ctype.raise_nongen_level (); - let cl = class_expr cl_num val_env' met_env scl' in + let cl = class_expr cl_num val_env' met_env virt self_scope scl' in Ctype.end_def (); if Btype.is_optional l && not_nolabel_function cl.cl_type then Location.prerr_warning pat.pat_loc @@ -1089,10 +1211,10 @@ and class_expr_aux cl_num val_env met_env scl = | Pcl_apply (scl', sargs) -> assert (sargs <> []); if !Clflags.principal then Ctype.begin_def (); - let cl = class_expr cl_num val_env met_env scl' in + let cl = class_expr cl_num val_env met_env virt self_scope scl' in if !Clflags.principal then begin Ctype.end_def (); - generalize_class_type false cl.cl_type; + Ctype.generalize_class_type_structure cl.cl_type; end; let rec nonopt_labels ls ty_fun = match ty_fun with @@ -1242,7 +1364,7 @@ and class_expr_aux cl_num val_env met_env scl = (let_bound_idents_with_modes defs) ([], met_env) in - let cl = class_expr cl_num val_env met_env scl' in + let cl = class_expr cl_num val_env met_env virt self_scope scl' in let () = if rec_flag = Recursive then check_recursive_bindings val_env defs in @@ -1255,17 +1377,19 @@ and class_expr_aux cl_num val_env met_env scl = | Pcl_constraint (scl', scty) -> Ctype.begin_class_def (); let context = Typetexp.narrow () in - let cl = class_expr cl_num val_env met_env scl' in + let cl = class_expr cl_num val_env met_env virt self_scope scl' in + complete_class_type cl.cl_loc val_env virt Class_type cl.cl_type; Typetexp.widen context; let context = Typetexp.narrow () in - let clty = class_type val_env scty in + let clty = class_type val_env virt self_scope scty in + complete_class_type clty.cltyp_loc val_env virt Class clty.cltyp_type; Typetexp.widen context; Ctype.end_def (); - limited_generalize (Ctype.row_variable (Ctype.self_type cl.cl_type)) - cl.cl_type; - limited_generalize (Ctype.row_variable (Ctype.self_type clty.cltyp_type)) - clty.cltyp_type; + Ctype.limited_generalize_class_type + (Btype.self_type_row cl.cl_type) cl.cl_type; + Ctype.limited_generalize_class_type + (Btype.self_type_row clty.cltyp_type) clty.cltyp_type; begin match Includeclass.class_types val_env cl.cl_type clty.cltyp_type @@ -1274,9 +1398,14 @@ and class_expr_aux cl_num val_env met_env scl = | error -> raise(Error(cl.cl_loc, val_env, Class_match_failure error)) end; let (vals, meths, concrs) = extract_constraints clty.cltyp_type in + let ty = snd (Ctype.instance_class [] clty.cltyp_type) in + (* Adding a dummy method to the self type prevents it from being closed / + escaping. *) + Ctype.add_dummy_method val_env ~scope:self_scope + (Btype.signature_of_class_type ty); rc {cl_desc = Tcl_constraint (cl, Some clty, vals, meths, concrs); cl_loc = scl.pcl_loc; - cl_type = snd (Ctype.instance_class [] clty.cltyp_type); + cl_type = ty; cl_env = val_env; cl_attributes = scl.pcl_attributes; } @@ -1284,7 +1413,7 @@ and class_expr_aux cl_num val_env met_env scl = let used_slot = ref false in let (od, new_val_env) = !type_open_descr ~used_slot val_env pod in let ( _, new_met_env) = !type_open_descr ~used_slot met_env pod in - let cl = class_expr cl_num new_val_env new_met_env e in + let cl = class_expr cl_num new_val_env new_met_env virt self_scope e in rc {cl_desc = Tcl_open (od, cl); cl_loc = scl.pcl_loc; cl_type = cl.cl_type; @@ -1306,9 +1435,12 @@ let rec approx_declaration cl = Pcl_fun (l, _, _, cl) -> let arg = if Btype.is_optional l then Ctype.instance var_option - else Ctype.newvar () in - Ctype.newty (Tarrow ((l, Alloc_mode.global, Alloc_mode.global), - arg, approx_declaration cl, Cok)) + else Ctype.newvar () + in + let arg = Ctype.newmono arg in + let arrow_desc = l, Alloc_mode.global, Alloc_mode.global in + Ctype.newty + (Tarrow (arrow_desc, arg, approx_declaration cl, commu_ok)) | Pcl_let (_, _, cl) -> approx_declaration cl | Pcl_constraint (cl, _) -> @@ -1320,9 +1452,12 @@ let rec approx_description ct = Pcty_arrow (l, _, ct) -> let arg = if Btype.is_optional l then Ctype.instance var_option - else Ctype.newvar () in - Ctype.newty (Tarrow ((l, Alloc_mode.global, Alloc_mode.global), - arg, approx_description ct, Cok)) + else Ctype.newvar () + in + let arg = Ctype.newmono arg in + let arrow_desc = l, Alloc_mode.global, Alloc_mode.global in + Ctype.newty + (Tarrow (arrow_desc, arg, approx_description ct, commu_ok)) | _ -> Ctype.newvar () (*******************************) @@ -1347,7 +1482,7 @@ let temp_abbrev loc env id arity uid = type_loc = loc; type_attributes = []; (* or keep attrs from the class decl? *) type_immediate = Unknown; - type_unboxed = unboxed_false_default_false; + type_unboxed_default = false; type_uid = uid; } env @@ -1362,15 +1497,13 @@ let initial_env define_class approx let (cl_params, cl_ty, env) = temp_abbrev cl.pci_loc env cl_id arity uid in (* Temporary type for the class constructor *) + if !Clflags.principal then Ctype.begin_def (); let constr_type = approx cl.pci_expr in - if !Clflags.principal then Ctype.generalize_spine constr_type; - let dummy_cty = - Cty_signature - { csig_self = Ctype.newvar (); - csig_vars = Vars.empty; - csig_concr = Concr.empty; - csig_inher = [] } - in + if !Clflags.principal then begin + Ctype.end_def (); + Ctype.generalize_structure constr_type; + end; + let dummy_cty = Cty_signature (Ctype.new_class_signature ()) in let dummy_class = {Types.cty_params = []; (* Dummy value *) cty_variance = []; @@ -1439,34 +1572,26 @@ let class_infos define_class kind try Typecore.self_coercion := (Path.Pident obj_id, coercion_locs) :: !Typecore.self_coercion; - let res = kind env cl.pci_expr in + let res = kind env cl.pci_virt cl.pci_expr in Typecore.self_coercion := List.tl !Typecore.self_coercion; res with exn -> Typecore.self_coercion := []; raise exn in + let sign = Btype.signature_of_class_type typ in Ctype.end_def (); - let sty = Ctype.self_type typ in - - (* First generalize the type of the dummy method (cf PR#6123) *) - let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in - List.iter (fun (met, _, ty) -> if met = dummy_method then Ctype.generalize ty) - fields; (* Generalize the row variable *) - let rv = Ctype.row_variable sty in - List.iter (Ctype.limited_generalize rv) params; - limited_generalize rv typ; + List.iter (Ctype.limited_generalize sign.csig_self_row) params; + Ctype.limited_generalize_class_type sign.csig_self_row typ; (* Check the abbreviation for the object type *) let (obj_params', obj_type) = Ctype.instance_class params typ in let constr = Ctype.newconstr (Path.Pident obj_id) obj_params in begin - let ty = Ctype.self_type obj_type in - Ctype.hide_private_methods ty; - if not (Ctype.close_object ty) then - raise(Error(cl.pci_loc, env, Closing_self_type ty)); + let row = Btype.self_type_row obj_type in + Ctype.unify env row (Ctype.newty Tnil); begin try List.iter2 (Ctype.unify env) obj_params obj_params' with Ctype.Unify _ -> @@ -1475,6 +1600,7 @@ let class_infos define_class kind Ctype.newconstr (Path.Pident obj_id) obj_params'))) end; + let ty = Btype.self_type obj_type in begin try Ctype.unify env ty constr with Ctype.Unify _ -> @@ -1483,12 +1609,12 @@ let class_infos define_class kind end end; + Ctype.set_object_name obj_id params (Btype.self_type typ); + (* Check the other temporary abbreviation (#-type) *) begin let (cl_params', cl_type) = Ctype.instance_class params typ in - let ty = Ctype.self_type cl_type in - Ctype.hide_private_methods ty; - Ctype.set_object_name obj_id (Ctype.row_variable ty) cl_params ty; + let ty = Btype.self_type cl_type in begin try List.iter2 (Ctype.unify env) cl_params cl_params' with Ctype.Unify _ -> @@ -1512,16 +1638,16 @@ let class_infos define_class kind Ctype.unify env (constructor_type constr obj_type) (Ctype.instance constr_type) - with Ctype.Unify trace -> + with Ctype.Unify err -> raise(Error(cl.pci_loc, env, - Constructor_type_mismatch (cl.pci_name.txt, trace))) + Constructor_type_mismatch (cl.pci_name.txt, err))) end; (* Class and class type temporary definitions *) let cty_variance = Variance.unknown_signature ~injective:false ~arity:(List.length params) in let cltydef = - {clty_params = params; clty_type = class_body typ; + {clty_params = params; clty_type = Btype.class_body typ; clty_variance = cty_variance; clty_path = Path.Pident obj_id; clty_loc = cl.pci_loc; @@ -1548,31 +1674,14 @@ let class_infos define_class kind if define_class then Env.add_class id clty env else env) in - if cl.pci_virt = Concrete then begin - let sign = Ctype.signature_of_class_type typ in - let mets = virtual_methods sign in - let vals = - Vars.fold - (fun name (_mut, vr, _ty) l -> if vr = Virtual then name :: l else l) - sign.csig_vars [] in - if mets <> [] || vals <> [] then - raise(Error(cl.pci_loc, env, Virtual_class(define_class, false, mets, - vals))); - end; - (* Misc. *) - let arity = Ctype.class_type_arity typ in - let pub_meths = - let (fields, _) = - Ctype.flatten_fields (Ctype.object_fields (Ctype.expand_head env obj_ty)) - in - List.map (function (lab, _, _) -> lab) fields - in + let arity = Btype.class_type_arity typ in + let pub_meths = Btype.public_methods sign in (* Final definitions *) let (params', typ') = Ctype.instance_class params typ in let cltydef = - {clty_params = params'; clty_type = class_body typ'; + {clty_params = params'; clty_type = Btype.class_body typ'; clty_variance = cty_variance; clty_path = Path.Pident obj_id; clty_loc = cl.pci_loc; @@ -1608,15 +1717,14 @@ let class_infos define_class kind type_loc = cl.pci_loc; type_attributes = []; (* or keep attrs from cl? *) type_immediate = Unknown; - type_unboxed = unboxed_false_default_false; + type_unboxed_default = false; type_uid = dummy_class.cty_uid; } in let (cl_params, cl_ty) = - Ctype.instance_parameterized_type params (Ctype.self_type typ) + Ctype.instance_parameterized_type params (Btype.self_type typ) in - Ctype.hide_private_methods cl_ty; - Ctype.set_object_name obj_id (Ctype.row_variable cl_ty) cl_params cl_ty; + Ctype.set_object_name obj_id cl_params cl_ty; let cl_abbr = let arity = List.length cl_params in { @@ -1632,7 +1740,7 @@ let class_infos define_class kind type_loc = cl.pci_loc; type_attributes = []; (* or keep attrs from cl? *) type_immediate = Unknown; - type_unboxed = unboxed_false_default_false; + type_unboxed_default = false; type_uid = dummy_class.cty_uid; } in @@ -1645,39 +1753,24 @@ let final_decl env define_class arity, pub_meths, coe, expr) = begin try Ctype.collapse_conj_params env clty.cty_params - with Ctype.Unify trace -> - raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, trace))) - end; - - (* make the dummy method disappear *) - begin - let self_type = Ctype.self_type clty.cty_type in - let methods, _ = - Ctype.flatten_fields - (Ctype.object_fields (Ctype.expand_head env self_type)) - in - List.iter (fun (lab,kind,_) -> - if lab = dummy_method then - match Btype.field_kind_repr kind with - Fvar r -> Btype.set_kind r Fabsent - | _ -> () - ) methods + with Ctype.Unify err -> + raise(Error(cl.pci_loc, env, Non_collapsable_conjunction (id, clty, err))) end; List.iter Ctype.generalize clty.cty_params; - generalize_class_type true clty.cty_type; + Ctype.generalize_class_type clty.cty_type; Option.iter Ctype.generalize clty.cty_new; List.iter Ctype.generalize obj_abbr.type_params; Option.iter Ctype.generalize obj_abbr.type_manifest; List.iter Ctype.generalize cl_abbr.type_params; Option.iter Ctype.generalize cl_abbr.type_manifest; - if not (closed_class clty) then + if Ctype.nongen_class_declaration clty then raise(Error(cl.pci_loc, env, Non_generalizable_class (id, clty))); begin match Ctype.closed_class clty.cty_params - (Ctype.signature_of_class_type clty.cty_type) + (Btype.signature_of_class_type clty.cty_type) with None -> () | Some reason -> @@ -1689,7 +1782,7 @@ let final_decl env define_class raise(Error(cl.pci_loc, env, Unbound_type_var(printer, reason))) end; { id; clty; ty_id; cltydef; obj_id; obj_abbr; cl_id; cl_abbr; arity; - pub_meths; coe; expr; + pub_meths; coe; id_loc = cl.pci_name; req = { ci_loc = cl.pci_loc; ci_virt = cl.pci_virt; @@ -1760,8 +1853,8 @@ let check_coercions env { id; id_loc; clty; ty_id; cltydef; obj_id; obj_abbr; | _ -> assert false in begin try Ctype.subtype env cl_ty obj_ty () - with Ctype.Subtype (tr1, tr2) -> - raise(Typecore.Error(loc, env, Typecore.Not_subtype(tr1, tr2))) + with Ctype.Subtype err -> + raise(Typecore.Error(loc, env, Typecore.Not_subtype err)) end; if not (Ctype.opened_object cl_ty) then raise(Error(loc, env, Cannot_coerce_self obj_ty)) @@ -1816,13 +1909,19 @@ let type_classes define_class approx kind env cls = (res, env) let class_num = ref 0 -let class_declaration env sexpr = +let class_declaration env virt sexpr = incr class_num; - let expr = class_expr (Int.to_string !class_num) env env sexpr in + let self_scope = Ctype.get_current_level () in + let expr = + class_expr (Int.to_string !class_num) env env virt self_scope sexpr + in + complete_class_type expr.cl_loc env virt Class expr.cl_type; (expr, expr.cl_type) -let class_description env sexpr = - let expr = class_type env sexpr in +let class_description env virt sexpr = + let self_scope = Ctype.get_current_level () in + let expr = class_type env virt self_scope sexpr in + complete_class_type expr.cltyp_loc env virt Class_type expr.cltyp_type; (expr, expr.cltyp_type) let class_declarations env cls = @@ -1858,41 +1957,15 @@ let class_type_declarations env cls = decls, env) -let rec unify_parents env ty cl = - match cl.cl_desc with - Tcl_ident (p, _, _) -> - begin try - let decl = Env.find_class p env in - let _, body = Ctype.find_cltype_for_path env decl.cty_path in - Ctype.unify env ty (Ctype.instance body) - with - Not_found -> () - | _exn -> assert false - end - | Tcl_structure st -> unify_parents_struct env ty st - | Tcl_open (_, cl) - | Tcl_fun (_, _, _, cl, _) - | Tcl_apply (cl, _) - | Tcl_let (_, _, _, cl) - | Tcl_constraint (cl, _, _, _, _) -> unify_parents env ty cl -and unify_parents_struct env ty st = - List.iter - (function - | {cf_desc = Tcf_inherit (_, cl, _, _, _)} -> - unify_parents env ty cl - | _ -> ()) - st.cstr_fields - let type_object env loc s = incr class_num; - let (desc, sign) = - class_structure (Int.to_string !class_num) true env env loc s in - let sty = Ctype.expand_head env sign.csig_self in - Ctype.hide_private_methods sty; - let (fields, _) = Ctype.flatten_fields (Ctype.object_fields sty) in - let meths = List.map (fun (s,_,_) -> s) fields in - unify_parents_struct env sign.csig_self desc; - (desc, sign, meths) + let desc = + class_structure (Int.to_string !class_num) + Concrete Btype.lowest_level Final env env loc s + in + complete_class_signature loc env Concrete Object desc.cstr_type; + let meths = Btype.public_methods desc.cstr_type in + (desc, meths) let () = Typecore.type_object := type_object @@ -1915,20 +1988,31 @@ let approx_class_declarations env sdecls = open Format +let non_virtual_string_of_kind = function + | Object -> "object" + | Class -> "non-virtual class" + | Class_type -> "non-virtual class type" + let report_error env ppf = function | Repeated_parameter -> fprintf ppf "A type parameter occurs several times" - | Unconsistent_constraint trace -> - fprintf ppf "The class constraints are not consistent.@."; - Printtyp.report_unification_error ppf env trace + | Unconsistent_constraint err -> + fprintf ppf "@[The class constraints are not consistent.@ "; + Printtyp.report_unification_error ppf env err (fun ppf -> fprintf ppf "Type") - (fun ppf -> fprintf ppf "is not compatible with type") - | Field_type_mismatch (k, m, trace) -> - Printtyp.report_unification_error ppf env trace + (fun ppf -> fprintf ppf "is not compatible with type"); + fprintf ppf "@]" + | Field_type_mismatch (k, m, err) -> + Printtyp.report_unification_error ppf env err (function ppf -> fprintf ppf "The %s %s@ has type" k m) (function ppf -> fprintf ppf "but is expected to have type") + | Unexpected_field (ty, lab) -> + fprintf ppf + "@[@[<2>This object is expected to have type :@ %a@]\ + @ This type does not have a method %s." + Printtyp.type_expr ty lab | Structure_expected clty -> fprintf ppf "@[This class expression is not a class structure; it has type@ %a@]" @@ -1955,76 +2039,72 @@ let report_error env ppf = function Printtyp.longident cl | Abbrev_type_clash (abbrev, actual, expected) -> (* XXX Afficher une trace ? | Print a trace? *) - Printtyp.reset_and_mark_loops_list [abbrev; actual; expected]; + Printtyp.prepare_for_printing [abbrev; actual; expected]; fprintf ppf "@[The abbreviation@ %a@ expands to type@ %a@ \ but is used with type@ %a@]" - !Oprint.out_type (Printtyp.tree_of_typexp false abbrev) - !Oprint.out_type (Printtyp.tree_of_typexp false actual) - !Oprint.out_type (Printtyp.tree_of_typexp false expected) - | Constructor_type_mismatch (c, trace) -> - Printtyp.report_unification_error ppf env trace + !Oprint.out_type (Printtyp.tree_of_typexp Type abbrev) + !Oprint.out_type (Printtyp.tree_of_typexp Type actual) + !Oprint.out_type (Printtyp.tree_of_typexp Type expected) + | Constructor_type_mismatch (c, err) -> + Printtyp.report_unification_error ppf env err (function ppf -> fprintf ppf "The expression \"new %s\" has type" c) (function ppf -> fprintf ppf "but is used with type") - | Virtual_class (cl, imm, mets, vals) -> - let print_mets ppf mets = - List.iter (function met -> fprintf ppf "@ %s" met) mets in + | Virtual_class (kind, mets, vals) -> + let kind = non_virtual_string_of_kind kind in let missings = match mets, vals with [], _ -> "variables" | _, [] -> "methods" | _ -> "methods and variables" in - let print_msg ppf = - if imm then fprintf ppf "This object has virtual %s" missings - else if cl then fprintf ppf "This class should be virtual" - else fprintf ppf "This class type should be virtual" - in fprintf ppf - "@[%t.@ @[<2>The following %s are undefined :%a@]@]" - print_msg missings print_mets (mets @ vals) + "@[This %s has virtual %s.@ \ + @[<2>The following %s are virtual : %a@]@]" + kind missings missings + (pp_print_list ~pp_sep:pp_print_space pp_print_string) (mets @ vals) + | Undeclared_methods(kind, mets) -> + let kind = non_virtual_string_of_kind kind in + fprintf ppf + "@[This %s has undeclared virtual methods.@ \ + @[<2>The following methods were not declared : %a@]@]" + kind (pp_print_list ~pp_sep:pp_print_space pp_print_string) mets | Parameter_arity_mismatch(lid, expected, provided) -> fprintf ppf "@[The class constructor %a@ expects %i type argument(s),@ \ but is here applied to %i type argument(s)@]" Printtyp.longident lid expected provided - | Parameter_mismatch trace -> - Printtyp.report_unification_error ppf env trace + | Parameter_mismatch err -> + Printtyp.report_unification_error ppf env err (function ppf -> fprintf ppf "The type parameter") (function ppf -> fprintf ppf "does not meet its constraint: it should be") | Bad_parameters (id, params, cstrs) -> - Printtyp.reset_and_mark_loops_list [params; cstrs]; + Printtyp.prepare_for_printing [params; cstrs]; fprintf ppf "@[The abbreviation %a@ is used with parameters@ %a@ \ which are incompatible with constraints@ %a@]" Printtyp.ident id - !Oprint.out_type (Printtyp.tree_of_typexp false params) - !Oprint.out_type (Printtyp.tree_of_typexp false cstrs) + !Oprint.out_type (Printtyp.tree_of_typexp Type params) + !Oprint.out_type (Printtyp.tree_of_typexp Type cstrs) | Class_match_failure error -> - Includeclass.report_error ppf error + Includeclass.report_error Type ppf error | Unbound_val lab -> fprintf ppf "Unbound instance variable %s" lab | Unbound_type_var (printer, reason) -> - let print_common ppf kind ty0 real lab ty = + let print_reason ppf (ty0, real, lab, ty) = let ty1 = if real then ty0 else Btype.newgenty(Tobject(ty0, ref None)) in - List.iter Printtyp.mark_loops [ty; ty1]; + Printtyp.add_type_to_preparation ty; + Printtyp.add_type_to_preparation ty1; fprintf ppf - "The %s %s@ has type@;<1 2>%a@ where@ %a@ is unbound" - kind lab - !Oprint.out_type (Printtyp.tree_of_typexp false ty) - !Oprint.out_type (Printtyp.tree_of_typexp false ty0) + "The method %s@ has type@;<1 2>%a@ where@ %a@ is unbound" + lab + !Oprint.out_type (Printtyp.tree_of_typexp Type ty) + !Oprint.out_type (Printtyp.tree_of_typexp Type ty0) in - let print_reason ppf = function - | Ctype.CC_Method (ty0, real, lab, ty) -> - print_common ppf "method" ty0 real lab ty - | Ctype.CC_Value (ty0, real, lab, ty) -> - print_common ppf "instance variable" ty0 real lab ty - in - Printtyp.reset (); fprintf ppf "@[@[Some type variables are unbound in this type:@;<1 2>%t@]@ \ @[%a@]@]" @@ -2040,17 +2120,17 @@ let report_error env ppf = function the type of the current class:@ %a.@.\ Some occurrences are contravariant@]" Printtyp.type_scheme ty - | Non_collapsable_conjunction (id, clty, trace) -> + | Non_collapsable_conjunction (id, clty, err) -> fprintf ppf "@[The type of this class,@ %a,@ \ contains non-collapsible conjunctive types in constraints.@ %t@]" (Printtyp.class_declaration id) clty - (fun ppf -> Printtyp.report_unification_error ppf env trace + (fun ppf -> Printtyp.report_unification_error ppf env err (fun ppf -> fprintf ppf "Type") (fun ppf -> fprintf ppf "is not compatible with type") ) - | Final_self_clash trace -> - Printtyp.report_unification_error ppf env trace + | Self_clash err -> + Printtyp.report_unification_error ppf env err (function ppf -> fprintf ppf "This object is expected to have type") (function ppf -> @@ -2070,12 +2150,15 @@ let report_error env ppf = function | Duplicate (kind, name) -> fprintf ppf "@[The %s `%s'@ has multiple definitions in this object@]" kind name - | Closing_self_type self -> + | Closing_self_type sign -> fprintf ppf "@[Cannot close type of object literal:@ %a@,\ it has been unified with the self type of a class that is not yet@ \ completely defined.@]" - Printtyp.type_scheme self + Printtyp.type_scheme sign.csig_self + | Polymorphic_class_parameter -> + fprintf ppf + "Class parameters cannot be polymorphic" let report_error env ppf err = Printtyp.wrap_printing_env ~error:true diff --git a/ocaml/typing/typeclass.mli b/ocaml/typing/typeclass.mli index c3503526aec..37caa8cb5d3 100644 --- a/ocaml/typing/typeclass.mli +++ b/ocaml/typing/typeclass.mli @@ -72,8 +72,6 @@ and class_type_declaration = val approx_class_declarations: Env.t -> Parsetree.class_description list -> class_type_info list -val virtual_methods: Types.class_signature -> label list - (* val type_classes : bool -> @@ -89,9 +87,15 @@ val type_classes : list * Env.t *) +type kind = + | Object + | Class + | Class_type + type error = - Unconsistent_constraint of Ctype.Unification_trace.t - | Field_type_mismatch of string * string * Ctype.Unification_trace.t + | Unconsistent_constraint of Errortrace.unification_error + | Field_type_mismatch of string * string * Errortrace.unification_error + | Unexpected_field of type_expr * string | Structure_expected of class_type | Cannot_apply of class_type | Apply_wrong_label of arg_label @@ -100,23 +104,26 @@ type error = | Unbound_class_2 of Longident.t | Unbound_class_type_2 of Longident.t | Abbrev_type_clash of type_expr * type_expr * type_expr - | Constructor_type_mismatch of string * Ctype.Unification_trace.t - | Virtual_class of bool * bool * string list * string list + | Constructor_type_mismatch of string * Errortrace.unification_error + | Virtual_class of kind * string list * string list + | Undeclared_methods of kind * string list | Parameter_arity_mismatch of Longident.t * int * int - | Parameter_mismatch of Ctype.Unification_trace.t + | Parameter_mismatch of Errortrace.unification_error | Bad_parameters of Ident.t * type_expr * type_expr | Class_match_failure of Ctype.class_match_failure list | Unbound_val of string - | Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure + | Unbound_type_var of + (formatter -> unit) * (type_expr * bool * string * type_expr) | Non_generalizable_class of Ident.t * Types.class_declaration | Cannot_coerce_self of type_expr | Non_collapsable_conjunction of - Ident.t * Types.class_declaration * Ctype.Unification_trace.t - | Final_self_clash of Ctype.Unification_trace.t + Ident.t * Types.class_declaration * Errortrace.unification_error + | Self_clash of Errortrace.unification_error | Mutability_mismatch of string * mutable_flag | No_overriding of string * string | Duplicate of string * string - | Closing_self_type of type_expr + | Closing_self_type of class_signature + | Polymorphic_class_parameter exception Error of Location.t * Env.t * error exception Error_forward of Location.error diff --git a/ocaml/typing/typecore.ml b/ocaml/typing/typecore.ml index 1b0e86bc6a5..6d2f7783376 100644 --- a/ocaml/typing/typecore.ml +++ b/ocaml/typing/typecore.ml @@ -22,7 +22,6 @@ open Types open Typedtree open Btype open Ctype -module Value_mode = Btype.Value_mode type type_forcing_context = | If_conditional @@ -42,6 +41,12 @@ type type_expected = { explanation: type_forcing_context option; } +type to_unpack = { + tu_name: string Location.loc; + tu_loc: Location.t; + tu_uid: Uid.t +} + module Datatype_kind = struct type t = Record | Variant @@ -61,6 +66,25 @@ type wrong_name = { valid_names: string list; } +type wrong_kind_context = + | Pattern + | Expression of type_forcing_context option + +type wrong_kind_sort = + | Constructor + | Record + | Boolean + | List + | Unit + +let wrong_kind_sort_of_constructor (lid : Longident.t) = + match lid with + | Lident "true" | Lident "false" | Ldot(_, "true") | Ldot(_, "false") -> + Boolean + | Lident "[]" | Lident "::" | Ldot(_, "[]") | Ldot(_, "::") -> List + | Lident "()" | Ldot(_, "()") -> Unit + | _ -> Constructor + type existential_restriction = | At_toplevel (** no existential types at the toplevel *) | In_group (** nor with let ... and ... *) @@ -72,14 +96,14 @@ type existential_restriction = type error = | Constructor_arity_mismatch of Longident.t * int * int - | Label_mismatch of Longident.t * Ctype.Unification_trace.t + | Label_mismatch of Longident.t * Errortrace.unification_error | Pattern_type_clash : - Ctype.Unification_trace.t * _ pattern_desc option -> error - | Or_pattern_type_clash of Ident.t * Ctype.Unification_trace.t + Errortrace.unification_error * _ pattern_desc option -> error + | Or_pattern_type_clash of Ident.t * Errortrace.unification_error | Multiply_bound_variable of string | Orpat_vars of Ident.t * Ident.t list | Expr_type_clash of - Ctype.Unification_trace.t * type_forcing_context option + Errortrace.unification_error * type_forcing_context option * expression_desc option | Apply_non_function of type_expr | Apply_wrong_label of arg_label * type_expr * bool @@ -90,25 +114,32 @@ type error = | Name_type_mismatch of Datatype_kind.t * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list | Invalid_format of string + | Not_an_object of type_expr * type_forcing_context option | Undefined_method of type_expr * string * string list option - | Undefined_inherited_method of string * string list + | Undefined_self_method of string * string list | Virtual_class of Longident.t | Private_type of type_expr | Private_label of Longident.t * type_expr | Private_constructor of constructor_description * type_expr | Unbound_instance_variable of string * string list | Instance_variable_not_mutable of string - | Not_subtype of Ctype.Unification_trace.t * Ctype.Unification_trace.t + | Not_subtype of Errortrace.Subtype.error | Outside_class | Value_multiply_overridden of string | Coercion_failure of - type_expr * type_expr * Ctype.Unification_trace.t * bool - | Too_many_arguments of bool * type_expr * type_forcing_context option - | Abstract_wrong_label of arg_label * type_expr * type_forcing_context option + Errortrace.expanded_type * Errortrace.unification_error * bool + | Not_a_function of type_expr * type_forcing_context option + | Too_many_arguments of type_expr * type_forcing_context option + | Abstract_wrong_label of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + ; explanation : type_forcing_context option + } | Scoping_let_module of string * type_expr - | Not_a_variant_type of Longident.t + | Not_a_polymorphic_variant_type of Longident.t | Incoherent_label_order - | Less_general of string * Ctype.Unification_trace.t + | Less_general of string * Errortrace.unification_error | Modules_not_allowed | Cannot_infer_signature | Not_a_packed_module of type_expr @@ -134,14 +165,19 @@ type error = | Illegal_letrec_pat | Illegal_letrec_expr | Illegal_class_expr - | Letop_type_clash of string * Ctype.Unification_trace.t - | Andop_type_clash of string * Ctype.Unification_trace.t - | Bindings_type_clash of Ctype.Unification_trace.t + | Letop_type_clash of string * Errortrace.unification_error + | Andop_type_clash of string * Errortrace.unification_error + | Bindings_type_clash of Errortrace.unification_error + | Unbound_existential of Ident.t list * type_expr + | Missing_type_constraint + | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr + | Expr_not_a_record_type of type_expr | Local_value_escapes of Value_mode.error * Env.escaping_context option | Param_mode_mismatch of type_expr | Uncurried_function_escapes | Local_return_annotation_mismatch of Location.t | Bad_tail_annotation of [`Conflict|`Not_a_tailcall] + | Optional_poly_param exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -150,7 +186,7 @@ exception Error_forward of Location.error let type_module = ref ((fun _env _md -> assert false) : - Env.t -> Parsetree.module_expr -> Typedtree.module_expr) + Env.t -> Parsetree.module_expr -> Typedtree.module_expr * Shape.t) (* Forward declaration, to be filled in by Typemod.type_open *) @@ -175,7 +211,7 @@ let type_package = let type_object = ref (fun _env _s -> assert false : Env.t -> Location.t -> Parsetree.class_structure -> - Typedtree.class_structure * Types.class_signature * string list) + Typedtree.class_structure * string list) (* Saving and outputting type information. @@ -197,6 +233,8 @@ let rcp node = ;; +(* Context for inline record arguments; see [type_ident] *) + type recarg = | Allowed | Required @@ -235,8 +273,8 @@ let apply_position env (expected_mode : expected_mode) sexp : apply_position = Builtin_attributes.tailcall sexp.pexp_attributes, expected_mode.position with - | Ok None, Nontail -> Default - | Ok (None | Some `Tail), Tail -> Tail + | Ok (None | Some `Tail_if_possible), Nontail -> Default + | Ok (None | Some `Tail | Some `Tail_if_possible), Tail -> Tail | Ok (Some `Nontail), _ -> Nontail | Ok (Some `Tail), Nontail -> fail `Not_a_tailcall | Error `Conflict, _ -> fail `Conflict @@ -343,8 +381,8 @@ let mode_lazy = let submode ~loc ~env mode expected_mode = let res = match expected_mode.tuple_modes with - | [] -> Btype.Value_mode.submode mode expected_mode.mode - | ts -> Btype.Value_mode.submode_meet mode ts + | [] -> Value_mode.submode mode expected_mode.mode + | ts -> Value_mode.submode_meet mode ts in match res with | Ok () -> () @@ -356,7 +394,7 @@ let escape ~loc ~env m = submode ~loc ~env m mode_global let eqmode ~loc ~env m1 m2 err = - match Btype.Alloc_mode.equate m1 m2 with + match Alloc_mode.equate m1 m2 with | Ok () -> () | Error () -> raise (Error(loc, env, err)) @@ -458,33 +496,49 @@ let option_some env texp mode = (type_option texp.exp_type) mode texp.exp_loc texp.exp_env let extract_option_type env ty = - match expand_head env ty with {desc = Tconstr(path, [ty], _)} - when Path.same path Predef.path_option -> ty + match get_desc (expand_head env ty) with + Tconstr(path, [ty], _) when Path.same path Predef.path_option -> ty | _ -> assert false +type record_extraction_result = + | Record_type of Path.t * Path.t * Types.label_declaration list + | Not_a_record_type + | Maybe_a_record_type + let extract_concrete_record env ty = match extract_concrete_typedecl env ty with - (p0, p, {type_kind=Type_record (fields, _)}) -> (p0, p, fields) - | _ -> raise Not_found + | Typedecl(p0, p, {type_kind=Type_record (fields, _)}) -> + Record_type (p0, p, fields) + | Has_no_typedecl | Typedecl(_, _, _) -> Not_a_record_type + | May_have_typedecl -> Maybe_a_record_type + +type variant_extraction_result = + | Variant_type of Path.t * Path.t * Types.constructor_declaration list + | Not_a_variant_type + | Maybe_a_variant_type let extract_concrete_variant env ty = match extract_concrete_typedecl env ty with - (p0, p, {type_kind=Type_variant cstrs}) -> (p0, p, cstrs) - | (p0, p, {type_kind=Type_open}) -> (p0, p, []) - | _ -> raise Not_found + | Typedecl(p0, p, {type_kind=Type_variant (cstrs, _)}) -> + Variant_type (p0, p, cstrs) + | Typedecl(p0, p, {type_kind=Type_open}) -> + Variant_type (p0, p, []) + | Has_no_typedecl | Typedecl(_, _, _) -> Not_a_variant_type + | May_have_typedecl -> Maybe_a_variant_type let extract_label_names env ty = - try - let (_, _,fields) = extract_concrete_record env ty in - List.map (fun l -> l.Types.ld_id) fields - with Not_found -> - assert false + match extract_concrete_record env ty with + | Record_type (_, _,fields) -> List.map (fun l -> l.Types.ld_id) fields + | Not_a_record_type | Maybe_a_record_type -> assert false + +let is_principal ty = + not !Clflags.principal || get_level ty = generic_level let has_local_attr loc attrs = match Builtin_attributes.has_local attrs with | Ok l -> l | Error () -> - raise(Typetexp.Error(loc, Env.empty, Local_not_enabled)) + raise(Typetexp.Error(loc, Env.empty, Unsupported_extension Local)) let has_local_attr_pat ppat = has_local_attr ppat.ppat_loc ppat.ppat_attributes @@ -492,6 +546,31 @@ let has_local_attr_pat ppat = let has_local_attr_exp pexp = has_local_attr pexp.pexp_loc pexp.pexp_attributes +let has_poly_constraint spat = + match spat.ppat_desc with + | Ppat_constraint(_, styp) -> begin + match styp.ptyp_desc with + | Ptyp_poly _ -> true + | _ -> false + end + | _ -> false + +let mode_cross env (ty : type_expr) mode = + if is_principal ty then begin + match immediacy env ty with + | Type_immediacy.Always -> Value_mode.newvar () + | Type_immediacy.Always_on_64bits when Sys.word_size = 64 -> + Value_mode.newvar () (* floating and relaxed *) + | _ -> mode + end + else mode + +let expect_mode_cross env (ty : type_expr) (mode : expected_mode) = + {mode with mode = mode_cross env ty mode.mode} + +let expect_pat_mode_cross env (ty : type_expr) (mode : expected_pat_mode) = + {mode with mode = mode_cross env ty mode.mode} + (* Typing of patterns *) (* unification inside type_exp and type_expect *) @@ -501,8 +580,8 @@ let unify_exp_types loc env ty expected_ty = try unify env ty expected_ty with - Unify trace -> - raise(Error(loc, env, Expr_type_clash(trace, None, None))) + Unify err -> + raise(Error(loc, env, Expr_type_clash(err, None, None))) | Tags(l1,l2) -> raise(Typetexp.Error(loc, env, Typetexp.Variant_tags (l1, l2))) @@ -519,15 +598,15 @@ let nothing_equated = TypePairs.create 0 let unify_pat_types_return_equated_pairs ?(refine = None) loc env ty ty' = try match refine with - | Some allow_recursive -> + | Some allow_recursive_equations -> unify_gadt ~equations_level:(get_gadt_equations_level ()) - ~allow_recursive env ty ty' + ~allow_recursive_equations env ty ty' | None -> unify !env ty ty'; nothing_equated with - | Unify trace -> - raise(Error(loc, !env, Pattern_type_clash(trace, None))) + | Unify err -> + raise(Error(loc, !env, Pattern_type_clash(err, None))) | Tags(l1,l2) -> raise(Typetexp.Error(loc, !env, Typetexp.Variant_tags (l1, l2))) @@ -536,29 +615,37 @@ let unify_pat_types ?refine loc env ty ty' = let unify_pat ?refine env pat expected_ty = try unify_pat_types ?refine pat.pat_loc env pat.pat_type expected_ty - with Error (loc, env, Pattern_type_clash(trace, None)) -> - raise(Error(loc, env, Pattern_type_clash(trace, Some pat.pat_desc))) + with Error (loc, env, Pattern_type_clash(err, None)) -> + raise(Error(loc, env, Pattern_type_clash(err, Some pat.pat_desc))) + +(* unification of a type with a Tconstr with freshly created arguments *) +let unify_head_only ~refine loc env ty constr = + let path = cstr_type_path constr in + let decl = Env.find_type path !env in + let ty' = Ctype.newconstr path (Ctype.instance_list decl.type_params) in + unify_pat_types ~refine loc env ty' ty (* Creating new conjunctive types is not allowed when typing patterns *) (* make all Reither present in open variants *) let finalize_variant pat tag opat r = let row = - match expand_head pat.pat_env pat.pat_type with - {desc = Tvariant row} -> r := row; row_repr row + match get_desc (expand_head pat.pat_env pat.pat_type) with + Tvariant row -> r := row; row | _ -> assert false in - begin match row_field tag row with + let f = get_row_field tag row in + begin match row_field_repr f with | Rabsent -> () (* assert false *) - | Reither (true, [], _, e) when not row.row_closed -> - set_row_field e (Rpresent None) - | Reither (false, ty::tl, _, e) when not row.row_closed -> - set_row_field e (Rpresent (Some ty)); + | Reither (true, [], _) when not (row_closed row) -> + link_row_field_ext ~inside:f (rf_present None) + | Reither (false, ty::tl, _) when not (row_closed row) -> + link_row_field_ext ~inside:f (rf_present (Some ty)); begin match opat with None -> assert false | Some pat -> let env = ref pat.pat_env in List.iter (unify_pat env pat) (ty::tl) end - | Reither (c, _l, true, e) when not (row_fixed row) -> - set_row_field e (Reither (c, [], false, ref None)) + | Reither (c, _l, true) when not (has_fixed_explanation row) -> + link_row_field_ext ~inside:f (rf_either [] ~no_arg:c ~matched:false) | _ -> () end (* Force check of well-formedness WHY? *) @@ -663,8 +750,8 @@ let enter_orpat_variables loc env p1_vs p2_vs = unify_var env (newvar ()) t1; unify env t1 t2 with - | Unify trace -> - raise(Error(loc, env, Or_pattern_type_clash(x1, trace))) + | Unify err -> + raise(Error(loc, env, Or_pattern_type_clash(x1, err))) end; let m = Value_mode.join [m1; m2] in let var = { pv1 with pv_mode = m } in @@ -682,46 +769,54 @@ let enter_orpat_variables loc env p1_vs p2_vs = raise (Error (loc, env, err)) in unify_vars p1_vs p2_vs -let rec build_as_type_and_mode env p = - let as_ty, as_mode = build_as_type_aux env p in +let rec build_as_type_and_mode ~refine (env : Env.t ref) p = + let as_ty, as_mode = build_as_type_aux ~refine env p in let as_ty = (* Cf. #1655 *) List.fold_left (fun as_ty (extra, _loc, _attrs) -> match extra with | Tpat_type _ | Tpat_open _ | Tpat_unpack -> as_ty | Tpat_constraint cty -> + (* [generic_instance] can only be used if the variables of the original + type ([cty.ctyp_type] here) are not at [generic_level], which they are + here. + If we used [generic_instance] we would lose the sharing between + [instance ty] and [ty]. *) begin_def (); let ty = instance cty.ctyp_type in end_def (); generalize_structure ty; (* This call to unify can't fail since the pattern is well typed. *) - unify !env (instance as_ty) (instance ty); + unify_pat_types ~refine p.pat_loc env (instance as_ty) (instance ty); ty ) as_ty p.pat_extra in as_ty, as_mode -and build_as_type env p = - fst (build_as_type_and_mode env p) +and build_as_type ~refine env p = + fst (build_as_type_and_mode ~refine env p) -and build_as_type_aux env p = +and build_as_type_aux ~refine (env : Env.t ref) p = + let build_as_type = build_as_type ~refine in match p.pat_desc with - Tpat_alias(p1,_, _) -> build_as_type_and_mode env p1 + Tpat_alias(p1,_, _) -> build_as_type_and_mode ~refine env p1 | Tpat_tuple pl -> let tyl = List.map (build_as_type env) pl in newty (Ttuple tyl), p.pat_mode - | Tpat_construct(_, cstr, pl) -> + | Tpat_construct(_, cstr, pl, vto) -> let priv = (cstr.cstr_private = Private) in let mode = if priv || pl <> [] then p.pat_mode else Value_mode.newvar () in - let keep = priv || cstr.cstr_existentials <> [] in + let keep = + priv || cstr.cstr_existentials <> [] || + vto <> None (* be lazy and keep the type for node constraints *) in let ty = if keep then p.pat_type else let tyl = List.map (build_as_type env) pl in - let ty_args, ty_res = instance_constructor cstr in - List.iter2 (fun (p,ty) -> unify_pat env {p with pat_type = ty}) + let ty_args, ty_res, _ = instance_constructor cstr in + List.iter2 (fun (p,ty) (arg, _) -> unify_pat env {p with pat_type = ty} arg) (List.combine pl tyl) ty_args; ty_res in @@ -733,9 +828,9 @@ and build_as_type_aux env p = else p.pat_mode in let ty = - newty (Tvariant{row_fields=[l, Rpresent ty]; row_more=newvar(); - row_bound=(); row_name=None; - row_fixed=None; row_closed=false}) + let fields = [l, rf_present ty] in + newty (Tvariant (create_row ~fields ~more:(newvar()) + ~name:None ~fixed:None ~closed:false)) in ty, mode | Tpat_record (lpl,_) -> @@ -745,85 +840,291 @@ and build_as_type_aux env p = let ppl = List.map (fun (_, l, p) -> l.lbl_pos, p) lpl in let do_label lbl = let _, ty_arg, ty_res = instance_label false lbl in - unify_pat env {p with pat_type = ty} ty_res; + unify_pat ~refine env {p with pat_type = ty} ty_res; let refinable = lbl.lbl_mut = Immutable && List.mem_assoc lbl.lbl_pos ppl && - match (repr lbl.lbl_arg).desc with Tpoly _ -> false | _ -> true in + match get_desc lbl.lbl_arg with Tpoly _ -> false | _ -> true in if refinable then begin let arg = List.assoc lbl.lbl_pos ppl in - unify_pat env {arg with pat_type = build_as_type env arg} ty_arg + unify_pat ~refine env + {arg with pat_type = build_as_type env arg} ty_arg end else begin let _, ty_arg', ty_res' = instance_label false lbl in - unify !env ty_arg ty_arg'; - unify_pat env p ty_res' + unify_pat_types ~refine p.pat_loc env ty_arg ty_arg'; + unify_pat ~refine env p ty_res' end in Array.iter do_label lbl.lbl_all; ty, p.pat_mode | Tpat_or(p1, p2, row) -> begin match row with None -> - let ty1, mode1 = build_as_type_and_mode env p1 in - let ty2, mode2 = build_as_type_and_mode env p2 in - unify_pat env {p2 with pat_type = ty2} ty1; + let ty1, mode1 = build_as_type_and_mode ~refine env p1 in + let ty2, mode2 = build_as_type_and_mode ~refine env p2 in + unify_pat ~refine env {p2 with pat_type = ty2} ty1; ty1, Value_mode.join [mode1; mode2] | Some row -> - let row = row_repr row in + let Row {fields; fixed; name} = row_repr row in let all_constant = List.for_all - (function - | _, (Rpresent (Some _) | Reither (false, _, _, _)) -> false + (fun (_,f) -> match row_field_repr f with + | (Rpresent (Some _) | Reither (false, _, _)) -> false | _ -> true) - row.row_fields + fields in let mode = if all_constant then Value_mode.newvar () else p.pat_mode in let ty = - newty (Tvariant{row with row_closed=false; row_more=newvar()}) + newty (Tvariant (create_row ~fields ~fixed ~name + ~closed:false ~more:(newvar ()))) in ty, mode end | Tpat_constant _ -> let mode = - if Ctype.maybe_pointer_type !env p.pat_type then p.pat_mode - else Value_mode.newvar () + match Ctype.immediacy !env p.pat_type with + | Always -> Value_mode.newvar () + | Unknown | Always_on_64bits -> p.pat_mode in p.pat_type, mode | Tpat_any | Tpat_var _ | Tpat_array _ | Tpat_lazy _ -> p.pat_type, p.pat_mode +(* Constraint solving during typing of patterns *) + +let solve_Ppat_alias ~refine env pat = + begin_def (); + let ty_var, mode = build_as_type_and_mode ~refine env pat in + end_def (); + generalize ty_var; + ty_var, mode + +let solve_Ppat_tuple (type a) ~refine ~alloc_mode loc env (args : a list) expected_ty = + let arity = List.length args in + assert (arity >= 2); + let arg_modes = + if List.compare_length_with alloc_mode.tuple_modes arity = 0 then + alloc_mode.tuple_modes + else + List.init arity (fun _ -> alloc_mode.mode) + in + let ann = + List.map2 + (fun p mode -> (p, newgenvar (), simple_pat_mode mode)) + args arg_modes + in + let ty = newgenty (Ttuple (List.map snd3 ann)) in + let expected_ty = generic_instance expected_ty in + unify_pat_types ~refine loc env ty expected_ty; + ann + +let solve_constructor_annotation env name_list sty ty_args ty_ex = + let expansion_scope = get_gadt_equations_level () in + let ids = + List.map + (fun name -> + let decl = new_local_type ~loc:name.loc () in + let (id, new_env) = + Env.enter_type ~scope:expansion_scope name.txt decl !env in + env := new_env; + {name with txt = id}) + name_list + in + begin_def (); + let cty, ty, force = Typetexp.transl_simple_type_delayed !env Global sty in + end_def (); + generalize_structure ty; + pattern_force := force :: !pattern_force; + let ty_args = + let ty1 = instance ty and ty2 = instance ty in + match ty_args with + [] -> assert false + | [ty_arg] -> + unify_pat_types cty.ctyp_loc env ty1 ty_arg; + [ty2] + | _ -> + unify_pat_types cty.ctyp_loc env ty1 (newty (Ttuple ty_args)); + match get_desc (expand_head !env ty2) with + Ttuple tyl -> tyl + | _ -> assert false + in + if ids <> [] then ignore begin + let ids = List.map (fun x -> x.txt) ids in + let rem = + List.fold_left + (fun rem tv -> + match get_desc tv with + Tconstr(Path.Pident id, [], _) when List.mem id rem -> + list_remove id rem + | _ -> + raise (Error (cty.ctyp_loc, !env, + Unbound_existential (ids, ty)))) + ids ty_ex + in + if rem <> [] then + raise (Error (cty.ctyp_loc, !env, + Unbound_existential (ids, ty))) + end; + ty_args, Some (ids, cty) + +let solve_Ppat_construct ~refine env loc constr no_existentials + existential_styp expected_ty = + (* if constructor is gadt, we must verify that the expected type has the + correct head *) + if constr.cstr_generalized then + unify_head_only ~refine loc env (instance expected_ty) constr; + begin_def (); + let expected_ty = instance expected_ty in + (* PR#7214: do not use gadt unification for toplevel lets *) + let unify_res ty_res = + let refine = + match refine, no_existentials with + | None, None when constr.cstr_generalized -> Some false + | _ -> refine + in + unify_pat_types_return_equated_pairs ~refine loc env ty_res expected_ty + in + let expansion_scope = get_gadt_equations_level () in + let ty_args_ty, ty_args_gf, ty_res, equated_types, existential_ctyp = + match existential_styp with + None -> + let ty_args, ty_res, _ = + instance_constructor ~in_pattern:(env, expansion_scope) constr in + let ty_args_ty, ty_args_gf = List.split ty_args in + ty_args_ty, ty_args_gf, ty_res, unify_res ty_res, None + | Some (name_list, sty) -> + let in_pattern = + if name_list = [] then Some (env, expansion_scope) else None in + let ty_args, ty_res, ty_ex = + instance_constructor ?in_pattern constr in + let equated_types = unify_res ty_res in + let ty_args_ty, ty_args_gf = List.split ty_args in + let ty_args_ty, existential_ctyp = + solve_constructor_annotation env name_list sty ty_args_ty ty_ex in + ty_args_ty, ty_args_gf, ty_res, equated_types, existential_ctyp + in + if constr.cstr_existentials <> [] then + lower_variables_only !env expansion_scope ty_res; + end_def (); + generalize_structure expected_ty; + generalize_structure ty_res; + List.iter generalize_structure ty_args_ty; + if !Clflags.principal && refine = None then begin + (* Do not warn for couter examples *) + let exception Warn_only_once in + try + TypePairs.iter + (fun (t1, t2) -> + generalize_structure t1; + generalize_structure t2; + if not (fully_generic t1 && fully_generic t2) then + let msg = + Format.asprintf + "typing this pattern requires considering@ %a@ and@ %a@ as \ + equal.@,\ + But the knowledge of these types" + Printtyp.type_expr t1 + Printtyp.type_expr t2 + in + Location.prerr_warning loc (Warnings.Not_principal msg); + raise Warn_only_once) + equated_types + with Warn_only_once -> () + end; + (ty_args_ty, ty_args_gf, existential_ctyp) + +let solve_Ppat_record_field ~refine loc env label label_lid record_ty = + begin_def (); + let (_, ty_arg, ty_res) = instance_label false label in + begin try + unify_pat_types ~refine loc env ty_res (instance record_ty) + with Error(_loc, _env, Pattern_type_clash(err, _)) -> + raise(Error(label_lid.loc, !env, + Label_mismatch(label_lid.txt, err))) + end; + end_def (); + generalize_structure ty_res; + generalize_structure ty_arg; + ty_arg + +let solve_Ppat_array ~refine loc env expected_ty = + let ty_elt = newgenvar() in + let expected_ty = generic_instance expected_ty in + unify_pat_types ~refine + loc env (Predef.type_array ty_elt) expected_ty; + ty_elt + +let solve_Ppat_lazy ~refine loc env expected_ty = + let nv = newgenvar () in + unify_pat_types ~refine loc env (Predef.type_lazy_t nv) + (generic_instance expected_ty); + nv + +let solve_Ppat_constraint ~refine loc env mode sty expected_ty = + begin_def(); + let cty, ty, force = Typetexp.transl_simple_type_delayed !env mode sty in + end_def(); + pattern_force := force :: !pattern_force; + generalize_structure ty; + let ty, expected_ty' = instance ty, ty in + unify_pat_types ~refine loc env ty (instance expected_ty); + let expected_ty' = + match get_desc expected_ty' with + | Tpoly (expected_ty', tl) -> + snd (instance_poly ~keep_names:true false tl expected_ty') + | _ -> expected_ty' + in + (cty, ty, expected_ty') + +let solve_Ppat_variant ~refine loc env tag no_arg expected_ty = + let arg_type = if no_arg then [] else [newgenvar()] in + let fields = [tag, rf_either ~no_arg arg_type ~matched:true] in + let make_row more = + create_row ~fields ~closed:false ~more ~fixed:None ~name:None + in + let row = make_row (newgenvar ()) in + let expected_ty = generic_instance expected_ty in + (* PR#7404: allow some_private_tag blindly, as it would not unify with + the abstract row variable *) + if tag <> Parmatch.some_private_tag then + unify_pat_types ~refine loc env (newgenty(Tvariant row)) expected_ty; + (arg_type, make_row (newvar ()), instance expected_ty) + +(* Building the or-pattern corresponding to a polymorphic variant type *) let build_or_pat env loc mode lid = let path, decl = Env.lookup_type ~loc:lid.loc lid.txt env in let tyl = List.map (fun _ -> newvar()) decl.type_params in let row0 = let ty = expand_head env (newty(Tconstr(path, tyl, ref Mnil))) in - match ty.desc with + match get_desc ty with Tvariant row when static_row row -> row - | _ -> raise(Error(lid.loc, env, Not_a_variant_type lid.txt)) + | _ -> raise(Error(lid.loc, env, Not_a_polymorphic_variant_type lid.txt)) in let pats, fields = List.fold_left (fun (pats,fields) (l,f) -> match row_field_repr f with Rpresent None -> + let f = rf_either [] ~no_arg:true ~matched:true in (l,None) :: pats, - (l, Reither(true,[], true, ref None)) :: fields + (l, f) :: fields | Rpresent (Some ty) -> + let f = rf_either [ty] ~no_arg:false ~matched:true in (l, Some {pat_desc=Tpat_any; pat_loc=Location.none; pat_env=env; pat_type=ty; pat_mode=mode; pat_extra=[]; pat_attributes=[]}) :: pats, - (l, Reither(false, [ty], true, ref None)) :: fields + (l, f) :: fields | _ -> pats, fields) - ([],[]) (row_repr row0).row_fields in - let row = - { row_fields = List.rev fields; row_more = newvar(); row_bound = (); - row_closed = false; row_fixed = None; row_name = Some (path, tyl) } - in - let ty = newty (Tvariant row) in + ([],[]) (row_fields row0) in + let fields = List.rev fields in + let name = Some (path, tyl) in + let make_row more = + create_row ~fields ~more ~closed:false ~fixed:None ~name in + let ty = newty (Tvariant (make_row (newvar()))) in let gloc = {loc with Location.loc_ghost=true} in - let row' = ref {row with row_more=newvar()} in + let row' = ref (make_row (newvar())) in let pats = List.map (fun (l,p) -> @@ -836,7 +1137,7 @@ let build_or_pat env loc mode lid = [] -> (* empty polymorphic variants: not possible with the concrete language but valid at the ast level *) - raise(Error(lid.loc, env, Not_a_variant_type lid.txt)) + raise(Error(lid.loc, env, Not_a_polymorphic_variant_type lid.txt)) | pat :: pats -> let r = List.fold_left @@ -845,7 +1146,7 @@ let build_or_pat env loc mode lid = pat_loc=gloc; pat_env=env; pat_type=ty; pat_mode=mode; pat_attributes=[]}) pat pats in - (path, rp { r with pat_loc = loc },ty) + (path, rp { r with pat_loc = loc }) let split_cases env cases = let add_case lst case = function @@ -883,8 +1184,8 @@ let rec expand_path env p = in match decl with Some {type_manifest = Some ty} -> - begin match repr ty with - {desc=Tconstr(p,_,_)} -> expand_path env p + begin match get_desc ty with + Tconstr(p,_,_) -> expand_path env p | _ -> assert false end | _ -> @@ -898,7 +1199,7 @@ let compare_type_path env tpath1 tpath2 = exception Wrong_name_disambiguation of Env.t * wrong_name let get_constr_type_path ty = - match (repr ty).desc with + match get_desc ty with | Tconstr(p, _, _) -> p | _ -> assert false @@ -970,14 +1271,16 @@ end) = struct (* warn if there are several distinct candidates in scope *) let warn_if_ambiguous warn lid env lbl rest = - Printtyp.Conflicts.reset (); - let paths = ambiguous_types env lbl rest in - let expansion = - Format.asprintf "%t" Printtyp.Conflicts.print_explanations in - if paths <> [] then - warn lid.loc - (Warnings.Ambiguous_name ([Longident.last lid.txt], - paths, false, expansion)) + if Warnings.is_active (Ambiguous_name ([],[],false,"")) then begin + Printtyp.Conflicts.reset (); + let paths = ambiguous_types env lbl rest in + let expansion = + Format.asprintf "%t" Printtyp.Conflicts.print_explanations in + if paths <> [] then + warn lid.loc + (Warnings.Ambiguous_name ([Longident.last lid.txt], + paths, false, expansion)) + end (* a non-principal type was used for disambiguation *) let warn_non_principal warn lid = @@ -988,11 +1291,13 @@ end) = struct (* we selected a name out of the lexical scope *) let warn_out_of_scope warn lid env tpath = - let path_s = - Printtyp.wrap_printing_env ~error:true env - (fun () -> Printtyp.string_of_path tpath) in - warn lid.loc - (Warnings.Name_out_of_scope (path_s, [Longident.last lid.txt], false)) + if Warnings.is_active (Name_out_of_scope ("",[],false)) then begin + let path_s = + Printtyp.wrap_printing_env ~error:true env + (fun () -> Printtyp.string_of_path tpath) in + warn lid.loc + (Warnings.Name_out_of_scope (path_s, [Longident.last lid.txt], false)) + end (* warn if the selected name is not the last introduced in scope -- in these cases the resolution is different from pre-disambiguation OCaml @@ -1124,12 +1429,12 @@ let wrap_disambiguate msg ty f x = module Label = NameChoice (struct type t = label_description - type usage = unit + type usage = Env.label_usage let kind = Datatype_kind.Record let get_name lbl = lbl.lbl_name let get_type lbl = lbl.lbl_res - let lookup_all_from_type loc () path env = - Env.lookup_all_labels_from_type ~loc path env + let lookup_all_from_type loc usage path env = + Env.lookup_all_labels_from_type ~loc usage path env let in_env lbl = match lbl.lbl_repres with | Record_regular | Record_float | Record_unboxed false -> true @@ -1162,7 +1467,7 @@ let disambiguate_label_by_ids closed ids labels : (_, _) result = Ok labels (* Only issue warnings once per record constructor/pattern *) -let disambiguate_lid_a_list loc closed env expected_type lid_a_list = +let disambiguate_lid_a_list loc closed env usage expected_type lid_a_list = let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in let w_pr = ref false and w_amb = ref [] and w_scope = ref [] and w_scope_ty = ref "" in @@ -1176,10 +1481,10 @@ let disambiguate_lid_a_list loc closed env expected_type lid_a_list = | _ -> Location.prerr_warning loc msg in let process_label lid = - let scope = Env.lookup_all_labels ~loc:lid.loc lid.txt env in + let scope = Env.lookup_all_labels ~loc:lid.loc usage lid.txt env in let filter : Label.nonempty_candidate_filter = disambiguate_label_by_ids closed ids in - Label.disambiguate ~warn ~filter () lid env expected_type scope in + Label.disambiguate ~warn ~filter usage lid env expected_type scope in let lbl_a_list = List.map (fun (lid,a) -> lid, process_label lid, a) lid_a_list in if !w_pr then @@ -1217,7 +1522,7 @@ let map_fold_cont f xs k = xs (fun ys -> k (List.rev ys)) [] let type_label_a_list - ?labels loc closed env type_lbl_a expected_type lid_a_list k = + ?labels loc closed env usage type_lbl_a expected_type lid_a_list k = let lbl_a_list = match lid_a_list, labels with ({txt=Longident.Lident s}, _)::_, Some labels when Hashtbl.mem labels s -> @@ -1239,7 +1544,7 @@ let type_label_a_list | _ -> lid_a) lid_a_list in - disambiguate_lid_a_list loc closed env expected_type lid_a_list + disambiguate_lid_a_list loc closed env usage expected_type lid_a_list in (* Invariant: records are sorted in the typed tree *) let lbl_a_list = @@ -1304,18 +1609,6 @@ module Constructor = NameChoice (struct let in_env _ = true end) -(* unification of a type with a tconstr with - freshly created arguments *) -let unify_head_only ~refine loc env ty constr = - let (_, ty_res) = instance_constructor constr in - let ty_res = repr ty_res in - match ty_res.desc with - | Tconstr(p,args,m) -> - ty_res.desc <- Tconstr(p,List.map (fun _ -> newvar ()) args,m); - enforce_constraints !env ty_res; - unify_pat_types ~refine loc env ty_res ty - | _ -> assert false - (* Typing of patterns *) (* "half typed" cases are produced in [type_cases] when we've just typechecked @@ -1345,7 +1638,7 @@ let rec has_literal_pattern p = match p.ppat_desc with false | Ppat_exception p | Ppat_variant (_, Some p) - | Ppat_construct (_, Some p) + | Ppat_construct (_, Some (_, p)) | Ppat_constraint (p, _) | Ppat_alias (p, _) | Ppat_lazy p @@ -1361,8 +1654,13 @@ let rec has_literal_pattern p = match p.ppat_desc with let check_scope_escape loc env level ty = try Ctype.check_scope_escape env level ty - with Unify trace -> - raise(Error(loc, env, Pattern_type_clash(trace, None))) + with Escape esc -> + (* We don't expand the type here because if we do, we might expand to the + type that escaped, leading to confusing error messages. *) + let trace = Errortrace.[Escape (map_escape trivial_expansion esc)] in + raise (Error(loc, + env, + Pattern_type_clash(Errortrace.unification_error ~trace, None))) type pattern_checking_mode = | Normal @@ -1502,7 +1800,7 @@ type abort_reason = Adds_constraints | Empty No variable information, as we only backtrack on patterns without variables (cf. assert statements). *) type state = - { snapshot: Btype.snapshot; + { snapshot: snapshot; levels: Ctype.levels; env: Env.t; } let save_state env = @@ -1599,8 +1897,11 @@ let as_comp_pattern In counter-example mode, [Empty_branch] is raised when the counter-example does not match any value. *) let rec type_pat - : type k r . k pattern_category -> no_existentials:_ -> mode:_ -> - alloc_mode:_ -> env:_ -> _ -> _ -> (k general_pattern -> r) -> r + : type k r . k pattern_category -> + no_existentials: existential_restriction option -> + mode: pattern_checking_mode -> alloc_mode:expected_pat_mode -> + env: Env.t ref -> Parsetree.pattern -> + type_expr -> (k general_pattern -> r) -> r = fun category ~no_existentials ~mode ~alloc_mode ~env sp expected_ty k -> Builtin_attributes.warning_scope sp.ppat_attributes @@ -1621,7 +1922,7 @@ and type_pat_aux let loc = sp.ppat_loc in let refine = match mode with Normal -> None | Counter_example _ -> Some true in - let unif (x : pattern) : pattern = + let solve_expected (x : pattern) : pattern = unify_pat ~refine env x (instance expected_ty); x in @@ -1675,7 +1976,7 @@ and type_pat_aux end | Ppat_var name -> let ty = instance expected_ty in - let alloc_mode = alloc_mode in + let alloc_mode = expect_pat_mode_cross !env expected_ty alloc_mode in let id = (* PR#7330 *) if name.txt = "*extension*" then Ident.create_local name.txt @@ -1715,45 +2016,11 @@ and type_pat_aux pat_attributes = []; pat_env = !env } end - | Ppat_constraint( - {ppat_desc=Ppat_var name; ppat_loc=lloc; ppat_attributes = attrs}, - ({ptyp_desc=Ptyp_poly _} as sty)) -> - (* explicitly polymorphic type *) - assert construction_not_used_in_counterexamples; - let type_mode = - if has_local_attr_pat sp then Alloc_mode.Local - else Alloc_mode.Global - in - let cty, ty, force = - Typetexp.transl_simple_type_delayed !env type_mode sty - in - unify_pat_types ~refine lloc env ty (instance expected_ty); - pattern_force := force :: !pattern_force; - begin match ty.desc with - | Tpoly (body, tyl) -> - begin_def (); - init_def generic_level; - let _, ty' = instance_poly ~keep_names:true false tyl body in - end_def (); - let id = enter_variable lloc name alloc_mode.mode ty' attrs in - rvp k { - pat_desc = Tpat_var (id, name); - pat_loc = lloc; - pat_extra = [Tpat_constraint cty, loc, sp.ppat_attributes]; - pat_type = ty; - pat_mode = alloc_mode.mode; - pat_attributes = []; - pat_env = !env - } - | _ -> assert false - end | Ppat_alias(sq, name) -> assert construction_not_used_in_counterexamples; type_pat Value sq expected_ty (fun q -> - begin_def (); - let ty_var, mode = build_as_type_and_mode env q in - end_def (); - generalize ty_var; + let ty_var, mode = solve_Ppat_alias ~refine env q in + let mode = mode_cross !env expected_ty mode in let id = enter_variable ~is_as_variable:true loc name mode ty_var sp.ppat_attributes @@ -1767,7 +2034,7 @@ and type_pat_aux pat_env = !env }) | Ppat_constant cst -> let cst = constant_or_raise !env loc cst in - rvp k @@ unif { + rvp k @@ solve_expected { pat_desc = Tpat_constant cst; pat_loc = loc; pat_extra=[]; pat_type = type_constant cst; @@ -1791,24 +2058,8 @@ and type_pat_aux | Ppat_interval _ -> raise (Error (loc, !env, Invalid_interval)) | Ppat_tuple spl -> - let arity = List.length spl in - assert (arity >= 2); - let arg_modes = - if List.compare_length_with alloc_mode.tuple_modes arity = 0 then - alloc_mode.tuple_modes - else - List.init arity (fun _ -> alloc_mode.mode) - in - let spl_ann = - List.map2 - (fun p mode -> (p, newgenvar (), simple_pat_mode mode)) - spl arg_modes - in - let ty = newgenty (Ttuple(List.map snd3 spl_ann)) in - let expected_ty = generic_instance expected_ty in - unify_pat_types ~refine loc env ty expected_ty; - map_fold_cont - (fun (p,t,alloc_mode) -> type_pat Value ~alloc_mode p t) spl_ann + let spl_ann = solve_Ppat_tuple ~refine ~alloc_mode loc env spl expected_ty in + map_fold_cont (fun (p,t,alloc_mode) -> type_pat Value ~alloc_mode p t) spl_ann (fun pl -> rvp k { pat_desc = Tpat_tuple pl; @@ -1819,13 +2070,14 @@ and type_pat_aux pat_env = !env }) | Ppat_construct(lid, sarg) -> let expected_type = - try - let (p0, p, _) = extract_concrete_variant !env expected_ty in - let principal = - (repr expected_ty).level = generic_level || not !Clflags.principal - in - Some (p0, p, principal) - with Not_found -> None + match extract_concrete_variant !env expected_ty with + | Variant_type(p0, p, _) -> + Some (p0, p, is_principal expected_ty) + | Maybe_a_variant_type -> None + | Not_a_variant_type -> + let srt = wrong_kind_sort_of_constructor lid.txt in + let error = Wrong_expected_kind(srt, Pattern, expected_ty) in + raise (Error (loc, !env, error)) in let constr = match lid.txt, mode with @@ -1848,23 +2100,33 @@ and type_pat_aux | Some r, (_ :: _ as exs) -> let exs = List.map (Ctype.existential_name constr) exs in let name = constr.cstr_name in - raise (Error (loc, !env, Unexpected_existential (r,name, exs))) + raise (Error (loc, !env, Unexpected_existential (r, name, exs))) end; - (* if constructor is gadt, we must verify that the expected type has the - correct head *) - if constr.cstr_generalized then - unify_head_only ~refine loc env (instance expected_ty) constr; - let sargs = + let sarg', existential_styp = match sarg with + None -> None, None + | Some (vl, {ppat_desc = Ppat_constraint (sp, sty)}) + when vl <> [] || constr.cstr_arity > 1 -> + Some sp, Some (vl, sty) + | Some ([], sp) -> + Some sp, None + | Some (_, sp) -> + raise (Error (sp.ppat_loc, !env, Missing_type_constraint)) + in + let sargs = + match sarg' with None -> [] | Some {ppat_desc = Ppat_tuple spl} when constr.cstr_arity > 1 || Builtin_attributes.explicit_arity sp.ppat_attributes -> spl - | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity <> 1 -> - if constr.cstr_arity = 0 then - Location.prerr_warning sp.ppat_loc - Warnings.Wildcard_arg_to_constant_constr; + | Some({ppat_desc = Ppat_any} as sp) when + constr.cstr_arity = 0 && existential_styp = None + -> + Location.prerr_warning sp.ppat_loc + Warnings.Wildcard_arg_to_constant_constr; + [] + | Some({ppat_desc = Ppat_any} as sp) when constr.cstr_arity > 1 -> replicate_list sp constr.cstr_arity | Some sp -> [sp] in if Builtin_attributes.warn_on_literal_pattern constr.cstr_attributes then @@ -1876,45 +2138,11 @@ and type_pat_aux if List.length sargs <> constr.cstr_arity then raise(Error(loc, !env, Constructor_arity_mismatch(lid.txt, constr.cstr_arity, List.length sargs))); - begin_def (); - let (ty_args, ty_res) = - instance_constructor ~in_pattern:(env, get_gadt_equations_level ()) - constr - in - let expected_ty = instance expected_ty in - (* PR#7214: do not use gadt unification for toplevel lets *) - let refine = - if refine = None && constr.cstr_generalized && no_existentials = None - then Some false - else refine - in - let equated_types = - unify_pat_types_return_equated_pairs ~refine loc env ty_res expected_ty + + let (ty_args_ty, ty_args_gf, existential_ctyp) = + solve_Ppat_construct ~refine env loc constr no_existentials + existential_styp expected_ty in - end_def (); - generalize_structure expected_ty; - generalize_structure ty_res; - List.iter generalize_structure ty_args; - if !Clflags.principal then ( - let exception Warn_only_once in - try - TypePairs.iter (fun (t1, t2) -> - generalize_structure t1; - generalize_structure t2; - if not (fully_generic t1 && fully_generic t2) then - let msg = - Format.asprintf - "typing this pattern requires considering@ %a@ and@ %a@ as \ - equal.@,\ - But the knowledge of these types" - Printtyp.type_expr t1 - Printtyp.type_expr t2 - in - Location.prerr_warning loc (Warnings.Not_principal msg); - raise Warn_only_once - ) equated_types - with Warn_only_once -> () - ); let rec check_non_escaping p = match p.ppat_desc with @@ -1928,39 +2156,41 @@ and type_pat_aux | _ -> () in - if constr.cstr_inlined <> None then List.iter check_non_escaping sargs; + if constr.cstr_inlined <> None then begin + List.iter check_non_escaping sargs; + Option.iter (fun (_, sarg) -> check_non_escaping sarg) sarg + end; map_fold_cont - (fun (p,t) -> type_pat Value p t) - (List.combine sargs ty_args) + (fun (p,(ty, gf)) -> + let alloc_mode = + match gf with + | Global -> Value_mode.global + | Nonlocal -> Value_mode.local_to_regional alloc_mode.mode + | Unrestricted -> alloc_mode.mode + in + let alloc_mode = simple_pat_mode alloc_mode in + type_pat ~alloc_mode Value p ty) + (List.combine sargs (List.combine ty_args_ty ty_args_gf)) (fun args -> rvp k { - pat_desc=Tpat_construct(lid, constr, args); + pat_desc=Tpat_construct(lid, constr, args, existential_ctyp); pat_loc = loc; pat_extra=[]; pat_type = instance expected_ty; pat_mode = alloc_mode.mode; pat_attributes = sp.ppat_attributes; pat_env = !env }) - | Ppat_variant(l, sarg) -> - let arg_type = match sarg with None -> [] | Some _ -> [newgenvar()] in - let row = { row_fields = - [l, Reither(sarg = None, arg_type, true, ref None)]; - row_bound = (); - row_closed = false; - row_more = newgenvar (); - row_fixed = None; - row_name = None } in - let expected_ty = generic_instance expected_ty in - (* PR#7404: allow some_private_tag blindly, as it would not unify with - the abstract row variable *) - if l = Parmatch.some_private_tag - then assert (match mode with Normal -> false | Counter_example _ -> true) - else unify_pat_types ~refine loc env (newgenty(Tvariant row)) expected_ty; + | Ppat_variant(tag, sarg) -> + if tag = Parmatch.some_private_tag then + assert (match mode with Normal -> false | Counter_example _ -> true); + let constant = (sarg = None) in + let arg_type, row, pat_type = + solve_Ppat_variant ~refine loc env tag constant expected_ty in let k arg = rvp k { - pat_desc = Tpat_variant(l, arg, ref {row with row_more = newvar()}); - pat_loc = loc; pat_extra=[]; - pat_type = instance expected_ty; + pat_desc = Tpat_variant(tag, arg, ref row); + pat_loc = loc; pat_extra = []; + pat_type = pat_type; pat_mode = alloc_mode.mode; pat_attributes = sp.ppat_attributes; pat_env = !env } @@ -1973,27 +2203,18 @@ and type_pat_aux | Ppat_record(lid_sp_list, closed) -> assert (lid_sp_list <> []); let expected_type, record_ty = - try - let (p0, p,_) = extract_concrete_record !env expected_ty in - let ty = generic_instance expected_ty in - let principal = - (repr expected_ty).level = generic_level || not !Clflags.principal - in - Some (p0, p, principal), ty - with Not_found -> None, newvar () + match extract_concrete_record !env expected_ty with + | Record_type(p0, p, _) -> + let ty = generic_instance expected_ty in + Some (p0, p, is_principal expected_ty), ty + | Maybe_a_record_type -> None, newvar () + | Not_a_record_type -> + let error = Wrong_expected_kind(Record, Pattern, expected_ty) in + raise (Error (loc, !env, error)) in let type_label_pat (label_lid, label, sarg) k = - begin_def (); - let (_, ty_arg, ty_res) = instance_label false label in - begin try - unify_pat_types ~refine loc env ty_res (instance record_ty) - with Error(_loc, _env, Pattern_type_clash(trace, _)) -> - raise(Error(label_lid.loc, !env, - Label_mismatch(label_lid.txt, trace))) - end; - end_def (); - generalize_structure ty_res; - generalize_structure ty_arg; + let ty_arg = + solve_Ppat_record_field ~refine loc env label label_lid record_ty in let alloc_mode = match label.lbl_global with | Global -> Value_mode.global @@ -2015,24 +2236,23 @@ and type_pat_aux pat_env = !env; } in - let k' pat = rvp k (unif pat) in + let k' pat = rvp k @@ solve_expected pat in begin match mode with | Normal -> k' (wrap_disambiguate "This record pattern is expected to have" (mk_expected expected_ty) - (type_label_a_list loc false !env type_label_pat expected_type - lid_sp_list) + (type_label_a_list loc false !env Env.Projection + type_label_pat expected_type lid_sp_list) make_record_pat) | Counter_example {labels; _} -> - type_label_a_list ~labels loc false !env type_label_pat expected_type - lid_sp_list (fun lbl_pat_list -> k' (make_record_pat lbl_pat_list)) + type_label_a_list ~labels loc false !env Env.Projection + type_label_pat expected_type lid_sp_list + (fun lbl_pat_list -> k' (make_record_pat lbl_pat_list)) end | Ppat_array spl -> - let ty_elt = newgenvar() in - let expected_ty = generic_instance expected_ty in - unify_pat_types ~refine - loc env (Predef.type_array ty_elt) expected_ty; - map_fold_cont (fun p -> type_pat Value p ty_elt) spl (fun pl -> + let ty_elt = solve_Ppat_array ~refine loc env expected_ty in + map_fold_cont (fun p -> type_pat ~alloc_mode:(simple_pat_mode Value_mode.global) + Value p ty_elt) spl (fun pl -> rvp k { pat_desc = Tpat_array pl; pat_loc = loc; pat_extra=[]; @@ -2041,89 +2261,94 @@ and type_pat_aux pat_attributes = sp.ppat_attributes; pat_env = !env }) | Ppat_or(sp1, sp2) -> - let may_split, must_split = - match get_splitting_mode mode with - | None -> false, false - | Some Backtrack_or -> true, true - | Some (Refine_or _) -> true, false in - let state = save_state env in - let split_or sp = - assert may_split; - let typ pat = type_pat category pat expected_ty k in - find_valid_alternative (fun pat -> set_state state env; typ pat) sp in - if must_split then split_or sp else begin - let initial_pattern_variables = !pattern_variables in - let initial_module_variables = !module_variables in - let equation_level = !gadt_equations_level in - let outter_lev = get_current_level () in - (* introduce a new scope *) - begin_def (); - let lev = get_current_level () in - gadt_equations_level := Some lev; - let env1 = ref !env in - let inside_or = enter_nonsplit_or mode in - let type_pat_result env sp : (_, abort_reason) result = - match - type_pat category ~mode:inside_or sp expected_ty ~env (fun x -> x) - with - | res -> Ok res - | exception Need_backtrack -> Error Adds_constraints - | exception Empty_branch -> Error Empty - in - let p1 = type_pat_result env1 sp1 in - let p1_variables = !pattern_variables in - let p1_module_variables = !module_variables in - pattern_variables := initial_pattern_variables; - module_variables := initial_module_variables; - let env2 = ref !env in - let p2 = type_pat_result env2 sp2 in - end_def (); - gadt_equations_level := equation_level; - let p2_variables = !pattern_variables in - (* Make sure no variable with an ambiguous type gets added to the - environment. *) - List.iter (fun { pv_type; pv_loc; _ } -> - check_scope_escape pv_loc !env1 outter_lev pv_type - ) p1_variables; - List.iter (fun { pv_type; pv_loc; _ } -> - check_scope_escape pv_loc !env2 outter_lev pv_type - ) p2_variables; - begin match p1, p2 with - | Error Empty, Error Empty -> - raise Empty_branch - | Error Adds_constraints, Error _ - | Error _, Error Adds_constraints -> - let inside_nonsplit_or = - match get_splitting_mode mode with - | None | Some Backtrack_or -> false - | Some (Refine_or {inside_nonsplit_or}) -> inside_nonsplit_or in - if inside_nonsplit_or - then raise Need_backtrack - else split_or sp - | Ok p, Error _ - | Error _, Ok p -> - rp k p - | Ok p1, Ok p2 -> - let vars, alpha_env = - enter_orpat_variables loc !env p1_variables p2_variables - in - let p2 = alpha_pat alpha_env p2 in - pattern_variables := vars; - module_variables := p1_module_variables; - let make_pat desc = - { pat_desc = desc; - pat_loc = loc; pat_extra=[]; - pat_type = instance expected_ty; - pat_mode = alloc_mode.mode; - pat_attributes = sp.ppat_attributes; - pat_env = !env } in - rp k (make_pat (Tpat_or(p1, p2, None))) - end + begin match mode with + | Normal -> + let initial_pattern_variables = !pattern_variables in + let initial_module_variables = !module_variables in + let equation_level = !gadt_equations_level in + let outter_lev = get_current_level () in + (* introduce a new scope *) + begin_def (); + let lev = get_current_level () in + gadt_equations_level := Some lev; + let type_pat_rec env sp = + type_pat category sp expected_ty ~env (fun x -> x) in + let env1 = ref !env in + let p1 = type_pat_rec env1 sp1 in + let p1_variables = !pattern_variables in + let p1_module_variables = !module_variables in + pattern_variables := initial_pattern_variables; + module_variables := initial_module_variables; + let env2 = ref !env in + let p2 = type_pat_rec env2 sp2 in + end_def (); + gadt_equations_level := equation_level; + let p2_variables = !pattern_variables in + (* Make sure no variable with an ambiguous type gets added to the + environment. *) + List.iter (fun { pv_type; pv_loc; _ } -> + check_scope_escape pv_loc !env1 outter_lev pv_type + ) p1_variables; + List.iter (fun { pv_type; pv_loc; _ } -> + check_scope_escape pv_loc !env2 outter_lev pv_type + ) p2_variables; + let vars, alpha_env = + enter_orpat_variables loc !env p1_variables p2_variables in + let p2 = alpha_pat alpha_env p2 in + pattern_variables := vars; + module_variables := p1_module_variables; + rp k { pat_desc = Tpat_or (p1, p2, None); + pat_loc = loc; pat_extra = []; + pat_type = instance expected_ty; + pat_mode = alloc_mode.mode; + pat_attributes = sp.ppat_attributes; + pat_env = !env } + | Counter_example {splitting_mode; _} -> + (* We are in counter-example mode, but try to avoid backtracking *) + let must_split = + match splitting_mode with + | Backtrack_or -> true + | Refine_or _ -> false in + let state = save_state env in + let split_or sp = + let typ pat = type_pat category pat expected_ty k in + find_valid_alternative (fun pat -> set_state state env; typ pat) sp + in + if must_split then split_or sp else + let type_pat_result env sp : (_, abort_reason) result = + let mode = enter_nonsplit_or mode in + match type_pat category ~mode sp expected_ty ~env (fun x -> x) with + | res -> Ok res + | exception Need_backtrack -> Error Adds_constraints + | exception Empty_branch -> Error Empty + in + let p1 = type_pat_result (ref !env) sp1 in + let p2 = type_pat_result (ref !env) sp2 in + match p1, p2 with + | Error Empty, Error Empty -> + raise Empty_branch + | Error Adds_constraints, Error _ + | Error _, Error Adds_constraints -> + let inside_nonsplit_or = + match splitting_mode with + | Backtrack_or -> false + | Refine_or {inside_nonsplit_or} -> inside_nonsplit_or in + if inside_nonsplit_or + then raise Need_backtrack + else split_or sp + | Ok p, Error _ + | Error _, Ok p -> + rp k p + | Ok p1, Ok p2 -> + rp k { pat_desc = Tpat_or (p1, p2, None); + pat_loc = loc; pat_extra = []; + pat_type = instance expected_ty; + pat_mode = alloc_mode.mode; + pat_attributes = sp.ppat_attributes; + pat_env = !env } end | Ppat_lazy sp1 -> - let nv = newgenvar () in - unify_pat_types ~refine loc env (Predef.type_lazy_t nv) - (generic_instance expected_ty); + let nv = solve_Ppat_lazy ~refine loc env expected_ty in (* do not explode under lazy: PR#7421 *) type_pat Value ~mode:(no_explosion mode) sp1 nv (fun p1 -> rvp k { @@ -2134,54 +2359,41 @@ and type_pat_aux pat_attributes = sp.ppat_attributes; pat_env = !env }) | Ppat_constraint(sp', sty) -> + assert construction_not_used_in_counterexamples; (* Pretend separate = true *) - begin_def(); let type_mode = if has_local_attr_pat sp then Alloc_mode.Local else Alloc_mode.Global in - let cty, ty, force = - Typetexp.transl_simple_type_delayed !env type_mode sty - in - end_def(); - generalize_structure ty; - let ty, expected_ty' = instance ty, ty in - unify_pat_types ~refine loc env ty (instance expected_ty); - type_pat category sp' expected_ty' (fun p -> + let cty, ty, expected_ty' = + solve_Ppat_constraint ~refine loc env type_mode sty expected_ty in + type_pat ~alloc_mode category sp' expected_ty' (fun p -> (*Format.printf "%a@.%a@." Printtyp.raw_type_expr ty Printtyp.raw_type_expr p.pat_type;*) - pattern_force := force :: !pattern_force; let extra = (Tpat_constraint cty, loc, sp'.ppat_attributes) in let p : k general_pattern = - match category, (p : k general_pattern) with - | Value, {pat_desc = Tpat_var (id,s); _} -> - {p with - pat_type = ty; - pat_desc = - Tpat_alias - ({p with pat_desc = Tpat_any; pat_attributes = []}, id,s); - pat_extra = [extra]; - } - | _, p -> - { p with pat_type = ty; pat_extra = extra::p.pat_extra } + { p with pat_type = ty; pat_extra = extra::p.pat_extra } in k p) | Ppat_type lid -> - let (path, p,ty) = - build_or_pat !env loc alloc_mode.mode lid - in - unify_pat_types ~refine loc env ty (instance expected_ty); - k @@ pure category @@ { p with pat_extra = - (Tpat_type (path, lid), loc, sp.ppat_attributes) + assert construction_not_used_in_counterexamples; + let (path, p) = build_or_pat !env loc alloc_mode.mode lid in + k @@ pure category @@ solve_expected + { p with pat_extra = (Tpat_type (path, lid), loc, sp.ppat_attributes) :: p.pat_extra } | Ppat_open (lid,p) -> + assert construction_not_used_in_counterexamples; let path, new_env = !type_open Asttypes.Fresh !env sp.ppat_loc lid in - let new_env = ref new_env in - type_pat category ~env:new_env p expected_ty ( fun p -> - env := Env.copy_local !env ~from:!new_env; - k { p with pat_extra =( Tpat_open (path,lid,!new_env), - loc, sp.ppat_attributes) :: p.pat_extra } + env := new_env; + type_pat category ~env p expected_ty ( fun p -> + let new_env = !env in + begin match Env.remove_last_open path new_env with + | None -> assert false + | Some closed_env -> env := closed_env + end; + k { p with pat_extra = (Tpat_open (path,lid,new_env), + loc, sp.ppat_attributes) :: p.pat_extra } ) | Ppat_exception p -> let alloc_mode = simple_pat_mode Value_mode.global in @@ -2285,13 +2497,15 @@ let type_pattern_list let pvs = get_ref pattern_variables in let unpacks = List.map (fun (name, loc) -> - name, loc, Uid.mk ~current_unit:(Env.get_unit_name ()) + {tu_name = name; tu_loc = loc; + tu_uid = Uid.mk ~current_unit:(Env.get_unit_name ())} ) (get_ref module_variables) in let new_env = add_pattern_variables !new_env pvs in (patl, new_env, get_ref pattern_force, pvs, unpacks) let type_class_arg_pattern cl_num val_env met_env l spat = + if !Clflags.principal then Ctype.begin_def (); reset_pattern false; let nv = newvar () in let alloc_mode = simple_pat_mode Value_mode.global in @@ -2304,6 +2518,11 @@ let type_class_arg_pattern cl_num val_env met_env l spat = end; List.iter (fun f -> f()) (get_ref pattern_force); if is_optional l then unify_pat (ref val_env) pat (type_option (newvar ())); + let pvs = !pattern_variables in + if !Clflags.principal then begin + Ctype.end_def (); + iter_pattern_variables_type generalize_structure pvs; + end; let (pv, val_env, met_env) = List.fold_right (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} @@ -2334,48 +2553,22 @@ let type_class_arg_pattern cl_num val_env met_env l spat = met_env in ((id', pv_id, pv_type)::pv, val_env, met_env)) - !pattern_variables ([], val_env, met_env) + pvs ([], val_env, met_env) in (pat, pv, val_env, met_env) -let type_self_pattern cl_num privty val_env met_env par_env spat = +let type_self_pattern env spat = let open Ast_helper in - let spat = - Pat.mk (Ppat_alias (Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")), - mknoloc ("selfpat-" ^ cl_num))) - in + let spat = Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")) in reset_pattern false; let nv = newvar() in let alloc_mode = simple_pat_mode Value_mode.global in let pat = - type_pat Value ~no_existentials:In_self_pattern - ~alloc_mode (ref val_env) spat nv - in + type_pat Value ~no_existentials:In_self_pattern ~alloc_mode (ref env) spat nv in List.iter (fun f -> f()) (get_ref pattern_force); - let meths = ref Meths.empty in - let vars = ref Vars.empty in let pv = !pattern_variables in pattern_variables := []; - let (val_env, met_env, par_env) = - List.fold_right - (fun {pv_id; pv_type; pv_loc; pv_as_var; pv_attributes} - (val_env, met_env, par_env) -> - let name = Ident.name pv_id in - (Env.enter_unbound_value name Val_unbound_self val_env, - Env.add_value pv_id - {val_type = pv_type; - val_kind = Val_self (meths, vars, cl_num, privty); - val_attributes = pv_attributes; - val_loc = pv_loc; - val_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); - } - ~check:(fun s -> if pv_as_var then Warnings.Unused_var s - else Warnings.Unused_var_strict s) - met_env, - Env.enter_unbound_value name Val_unbound_self par_env)) - pv (val_env, met_env, par_env) - in - (pat, meths, vars, val_env, met_env, par_env) + pat, pv type pat_tuple_arity = | Not_local_tuple @@ -2451,16 +2644,16 @@ let is_prim ~name funct = (* List labels in a function type, and whether return type is a variable *) let rec list_labels_aux env visited ls ty_fun = let ty = expand_head env ty_fun in - if List.memq ty visited then + if TypeSet.mem ty visited then List.rev ls, false - else match ty.desc with + else match get_desc ty with Tarrow ((l,_,_), _, ty_res, _) -> - list_labels_aux env (ty::visited) (l::ls) ty_res + list_labels_aux env (TypeSet.add ty visited) (l::ls) ty_res | _ -> List.rev ls, is_Tvar ty let list_labels env ty = - wrap_trace_gadt_instances env (list_labels_aux env [] []) ty + wrap_trace_gadt_instances env (list_labels_aux env TypeSet.empty []) ty (* Collecting arguments for function applications *) @@ -2473,7 +2666,7 @@ type untyped_apply_arg = wrapped_in_some : bool; } | Unknown_arg of { sarg : Parsetree.expression; - ty_arg : type_expr; + ty_arg_mono : type_expr; mode_arg : Alloc_mode.t; } | Eliminated_optional_arg of { mode_fun: Alloc_mode.t; @@ -2503,11 +2696,13 @@ let remaining_function_type ty_ret mode_ret rev_args = | Arg (Unknown_arg { mode_arg; _ } | Known_arg { mode_arg; _ }) -> let closed_args = mode_arg :: closed_args in (ty_ret, mode_ret, closed_args) - | Arg (Eliminated_optional_arg { mode_fun; ty_arg; mode_arg; level }) + | Arg (Eliminated_optional_arg + { mode_fun; ty_arg; mode_arg; level }) | Omitted { mode_fun; ty_arg; mode_arg; level } -> + let arrow_desc = lbl, mode_arg, mode_ret in let ty_ret = - newty2 level - (Tarrow ((lbl, mode_arg, mode_ret), ty_arg, ty_ret, Cok)) + newty2 ~level + (Tarrow (arrow_desc, ty_arg, ty_ret, commu_ok)) in let mode_ret = Alloc_mode.join (mode_fun :: closed_args) @@ -2517,7 +2712,7 @@ let remaining_function_type ty_ret mode_ret rev_args = in ty_ret -let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs = +let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs ret_tvar = let labels_match ~param ~arg = param = arg || !Clflags.classic && arg = Nolabel && not (is_optional param) @@ -2530,13 +2725,14 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs = match sargs with | [] -> ty_fun, mode_fun, List.rev rev_args | (lbl, sarg) :: rest -> - let (mode_arg, ty_arg, mode_res, ty_res) = + let (mode_arg, ty_arg_mono, mode_res, ty_res) = let ty_fun = expand_head env ty_fun in - match ty_fun.desc with + match get_desc ty_fun with | Tvar _ -> - let ty_arg = newvar () in + let ty_arg_mono = newvar () in + let ty_arg = newmono ty_arg_mono in let ty_res = newvar () in - if ty_fun.level >= ty_arg.level && + if ret_tvar && not (is_prim ~name:"%identity" funct) && not (is_prim ~name:"%obj_magic" funct) then @@ -2546,15 +2742,15 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs = let mode_res = Alloc_mode.newvar () in let kind = (lbl, mode_arg, mode_res) in unify env ty_fun - (newty (Tarrow(kind,ty_arg,ty_res,Clink(ref Cunknown)))); - (mode_arg, ty_arg, mode_res, ty_res) + (newty (Tarrow(kind,ty_arg,ty_res,commu_var ()))); + (mode_arg, ty_arg_mono, mode_res, ty_res) | Tarrow ((l, mode_arg, mode_res), ty_arg, ty_res, _) when labels_match ~param:l ~arg:lbl -> - (mode_arg, ty_arg, mode_res, ty_res) + (mode_arg, tpoly_get_mono ty_arg, mode_res, ty_res) | td -> let ty_fun = match td with Tarrow _ -> newty td | _ -> ty_fun in let ty_res = remaining_function_type ty_fun mode_fun rev_args in - match ty_res.desc with + match get_desc ty_res with | Tarrow _ -> if !Clflags.classic || not (has_label lbl ty_fun) then raise (Error(sarg.pexp_loc, env, @@ -2565,18 +2761,20 @@ let collect_unknown_apply_args env funct ty_fun mode_fun rev_args sargs = raise(Error(funct.exp_loc, env, Apply_non_function (expand_head env funct.exp_type))) in - let arg = Unknown_arg { sarg; ty_arg; mode_arg } in + let arg = Unknown_arg { sarg; ty_arg_mono; mode_arg; } in loop ty_res mode_res ((lbl, Arg arg) :: rev_args) rest in loop ty_fun mode_fun rev_args sargs -let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs = +let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs ret_tvar = let warned = ref false in let rec loop ty_fun ty_fun0 mode_fun rev_args sargs = - match expand_head env ty_fun, expand_head env ty_fun0 with - | {desc=Tarrow (ad, ty_arg, ty_ret, com); level=lv} as ty_fun', - {desc=Tarrow (_, ty_arg0, ty_ret0, _)} - when sargs <> [] && commu_repr com = Cok -> + let ty_fun' = expand_head env ty_fun in + match get_desc ty_fun', get_desc (expand_head env ty_fun0) with + | Tarrow (ad, ty_arg, ty_ret, com), + Tarrow (_, ty_arg0, ty_ret0, _) + when sargs <> [] && is_commu_ok com -> + let lv = get_level ty_fun' in let (l, mode_arg, mode_ret) = ad in let may_warn loc w = if not !warned && !Clflags.principal && lv <> generic_level @@ -2592,7 +2790,8 @@ let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs = if wrapped_in_some then may_warn sarg.pexp_loc (Warnings.Not_principal "using an optional argument here"); - Arg (Known_arg { sarg; ty_arg; ty_arg0; mode_arg; wrapped_in_some }) + Arg (Known_arg + { sarg; ty_arg; ty_arg0; mode_arg; wrapped_in_some }) in let eliminate_optional_arg () = may_warn funct.exp_loc @@ -2649,7 +2848,7 @@ let collect_apply_args env funct ignore_labels ty_fun ty_fun0 mode_fun sargs = | _ -> (* We're not looking at a *known* function type anymore, or there are no arguments left. *) - collect_unknown_apply_args env funct ty_fun0 mode_fun rev_args sargs + collect_unknown_apply_args env funct ty_fun0 mode_fun rev_args sargs ret_tvar in loop ty_fun ty_fun0 mode_fun [] sargs @@ -2663,9 +2862,10 @@ let type_omitted_parameters expected_mode env ty_ret mode_ret args = let args = (lbl, arg) :: args in (ty_ret, mode_ret, open_args, closed_args, args) | Omitted { mode_fun; ty_arg; mode_arg; level } -> + let arrow_desc = (lbl, mode_arg, mode_ret) in let ty_ret = - newty2 level - (Tarrow ((lbl, mode_arg, mode_ret), ty_arg, ty_ret, Cok)) + newty2 ~level + (Tarrow (arrow_desc, ty_arg, ty_ret, commu_ok)) in let new_closed_args = List.map @@ -2736,7 +2936,7 @@ let rec is_nonexpansive exp = | Texp_ifthenelse(_cond, ifso, ifnot) -> is_nonexpansive ifso && is_nonexpansive_opt ifnot | Texp_sequence (_e1, e2) -> is_nonexpansive e2 (* PR#4354 *) - | Texp_new (_, _, cl_decl, _) -> Ctype.class_type_arity cl_decl.cty_type > 0 + | Texp_new (_, _, cl_decl, _) -> Btype.class_type_arity cl_decl.cty_type > 0 (* Note: nonexpansive only means no _observable_ side effects *) | Texp_lazy e -> is_nonexpansive e | Texp_object ({cstr_fields=fields; cstr_type = { csig_vars=vars}}, _) -> @@ -2939,11 +3139,30 @@ let is_local_returning_function cases = let rec approx_type env sty = match sty.ptyp_desc with - Ptyp_arrow (p, _, sty) -> - let ty1 = if is_optional p then type_option (newvar ()) else newvar () in + | Ptyp_arrow (p, ({ ptyp_desc = Ptyp_poly _ } as arg_sty), sty) -> + if is_optional p then newvar () + else begin + let arg_mode = Typetexp.get_alloc_mode arg_sty in + let arg_ty = + (* Polymorphic types will only unify with types that match all of their + polymorphic parts, so we need to fully translate the type here + unlike in the monomorphic case *) + Typetexp.transl_simple_type env false arg_mode arg_sty + in + let ret = approx_type env sty in + let marg = Alloc_mode.of_const arg_mode in + let mret = Alloc_mode.newvar () in + newty (Tarrow ((p,marg,mret), arg_ty.ctyp_type, ret, commu_ok)) + end + | Ptyp_arrow (p, arg_sty, sty) -> + let arg_mode = Typetexp.get_alloc_mode arg_sty in + let arg = + if is_optional p then type_option (newvar ()) else newvar () + in let ret = approx_type env sty in - let marg = Alloc_mode.newvar () and mret = Alloc_mode.newvar () in - newty (Tarrow ((p,marg,mret), ty1, ret, Cok)) + let marg = Alloc_mode.of_const arg_mode in + let mret = Alloc_mode.newvar () in + newty (Tarrow ((p,marg,mret), newmono arg, ret, commu_ok)) | Ptyp_tuple args -> newty (Ttuple (List.map (approx_type env) args)) | Ptyp_constr (lid, ctl) -> @@ -2953,60 +3172,113 @@ let rec approx_type env sty = let tyl = List.map (approx_type env) ctl in newconstr path tyl end - | Ptyp_poly (_, sty) -> - approx_type env sty | _ -> newvar () -let rec type_approx env sexp = - match sexp.pexp_desc with - Pexp_let (_, _, e) -> type_approx env e - | Pexp_fun (p, _, spat, e) -> - let marg = - if has_local_attr_pat spat then Alloc_mode.local - else Alloc_mode.newvar () +let type_pattern_approx env spat ty_expected = + match spat.ppat_desc with + | Ppat_constraint(_, ({ptyp_desc=Ptyp_poly _} as sty)) -> + let arg_type_mode = + if has_local_attr_pat spat then Alloc_mode.Local + else Alloc_mode.Global in - let mret = Alloc_mode.newvar () in - let ty = if is_optional p then type_option (newvar ()) else newvar () in - let ret = type_approx env e in - newty (Tarrow((p,marg,mret), ty, ret, Cok)) + let ty_pat = + Typetexp.transl_simple_type env false arg_type_mode sty + in + begin try unify env ty_pat.ctyp_type ty_expected with Unify trace -> + raise(Error(spat.ppat_loc, env, Pattern_type_clash(trace, None))) + end; + | _ -> () + +let rec type_function_approx env loc label spato sexp in_function ty_expected = + let has_local, has_poly = + match spato with + | None -> false, false + | Some spat -> + let has_local = has_local_attr_pat spat in + let has_poly = has_poly_constraint spat in + if has_poly && is_optional label then + raise(Error(spat.ppat_loc, env, Optional_poly_param)); + has_local, has_poly + in + let loc_fun, ty_fun = + match in_function with + | Some (loc, ty) -> loc, ty + | None -> loc, ty_expected + in + let (arg_mode, ty_arg, _, ty_res) = + try filter_arrow env ty_expected label ~force_tpoly:(not has_poly) + with Filter_arrow_failed err -> + let explanation = None in + let err = match err with + | Unification_error unif_err -> + Expr_type_clash(unif_err, explanation, None) + | Label_mismatch { got; expected; expected_type} -> + Abstract_wrong_label { got; expected; expected_type; explanation } + | Not_a_function -> begin + match in_function with + | Some _ -> Too_many_arguments(ty_fun, explanation) + | None -> Not_a_function(ty_fun, explanation) + end + in + raise (Error(loc_fun, env, err)) + in + if has_local then + eqmode ~loc ~env arg_mode Alloc_mode.local + (Param_mode_mismatch ty_expected); + if has_poly then begin + match spato with + | None -> () + | Some spat -> type_pattern_approx env spat ty_arg + end; + let in_function = Some (loc_fun, ty_fun) in + type_approx_aux env sexp in_function ty_res + +and type_approx_aux env sexp in_function ty_expected = + match sexp.pexp_desc with + Pexp_let (_, _, e) -> type_approx_aux env e None ty_expected + | Pexp_fun (l, _, p, e) -> + type_function_approx env sexp.pexp_loc l (Some p) e + in_function ty_expected | Pexp_function ({pc_rhs=e}::_) -> - let ret = type_approx env e in - let marg = Alloc_mode.newvar () and mret = Alloc_mode.newvar () in - newty (Tarrow((Nolabel,marg,mret), newvar (), ret, Cok)) - | Pexp_match (_, {pc_rhs=e}::_) -> type_approx env e - | Pexp_try (e, _) -> type_approx env e - | Pexp_tuple l -> newty (Ttuple(List.map (type_approx env) l)) - | Pexp_ifthenelse (_,e,_) -> type_approx env e - | Pexp_sequence (_,e) -> type_approx env e + type_function_approx env sexp.pexp_loc Nolabel None e + in_function ty_expected + | Pexp_match (_, {pc_rhs=e}::_) -> type_approx_aux env e None ty_expected + | Pexp_try (e, _) -> type_approx_aux env e None ty_expected + | Pexp_tuple l -> + let tys = List.map (fun _ -> newvar ()) l in + let ty = newty (Ttuple tys) in + begin try unify env ty ty_expected with Unify err -> + raise(Error(sexp.pexp_loc, env, Expr_type_clash (err, None, None))) + end; + List.iter2 + (fun e ty -> type_approx_aux env e None ty) + l tys + | Pexp_ifthenelse (_,e,_) -> type_approx_aux env e None ty_expected + | Pexp_sequence (_,e) -> type_approx_aux env e None ty_expected | Pexp_constraint (e, sty) -> - let ty = type_approx env e in - let ty1 = approx_type env sty in - begin try unify env ty ty1 with Unify trace -> - raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None, None))) + let ty_expected' = approx_type env sty in + begin try unify env ty_expected' ty_expected with Unify err -> + raise(Error(sexp.pexp_loc, env, Expr_type_clash (err, None, None))) end; - ty1 - | Pexp_coerce (e, sty1, sty2) -> - let approx_ty_opt = function - | None -> newvar () - | Some sty -> approx_type env sty - in - let ty = type_approx env e - and ty1 = approx_ty_opt sty1 - and ty2 = approx_type env sty2 in - begin try unify env ty ty1 with Unify trace -> + type_approx_aux env e None ty_expected' + | Pexp_coerce (_, _, sty) -> + let ty = approx_type env sty in + begin try unify env ty ty_expected with Unify trace -> raise(Error(sexp.pexp_loc, env, Expr_type_clash (trace, None, None))) - end; - ty2 + end | Pexp_apply ({ pexp_desc = Pexp_extension( {txt = "extension.local"|"ocaml.local"|"local"}, PStr []) }, [Nolabel, e]) -> - type_approx env e + type_approx_aux env e None ty_expected | Pexp_apply ({ pexp_desc = Pexp_extension({txt = "extension.escape"}, PStr []) }, [Nolabel, e]) -> - type_approx env e - | _ -> newvar () + type_approx_aux env e None ty_expected + | _ -> () + +let type_approx env sexp ty = + type_approx_aux env sexp None ty (* Check that all univars are safe in a type. Both exp.exp_type and ty_expected should already be generalized. *) @@ -3014,7 +3286,7 @@ let check_univars env kind exp ty_expected vars = let pty = instance ty_expected in begin_def (); let exp_ty, vars = - match pty.desc with + match get_desc pty with Tpoly (body, tl) -> (* Enforce scoping for type_let: since body is not generic, instance_poly only makes @@ -3031,8 +3303,12 @@ let check_univars env kind exp ty_expected vars = let ty, complete = polyfy env exp_ty vars in if not complete then let ty_expected = instance ty_expected in - raise (Error (exp.exp_loc, env, - Less_general(kind, [Unification_trace.diff ty ty_expected]))) + raise (Error(exp.exp_loc, + env, + Less_general(kind, + Errortrace.unification_error + ~trace:[Ctype.expanded_diff env + ~got:ty ~expected:ty_expected]))) let generalize_and_check_univars env kind exp ty_expected vars = generalize exp.exp_type; @@ -3040,37 +3316,65 @@ let generalize_and_check_univars env kind exp ty_expected vars = List.iter generalize vars; check_univars env kind exp ty_expected vars -let check_partial_application statement exp = - let rec f delay = - let ty = (expand_head exp.exp_env exp.exp_type).desc in - let check_statement () = - match ty with - | Tconstr (p, _, _) when Path.same p Predef.path_unit -> - () - | _ -> - if statement then - let rec loop {exp_loc; exp_desc; exp_extra; _} = - match exp_desc with - | Texp_let (_, _, e) - | Texp_sequence (_, e) - | Texp_letexception (_, e) - | Texp_letmodule (_, _, _, _, e) -> - loop e - | _ -> - let loc = - match List.find_opt (function - | (Texp_constraint _, _, _) -> true - | _ -> false) exp_extra - with - | Some (_, loc, _) -> loc - | None -> exp_loc - in - Location.prerr_warning loc Warnings.Non_unit_statement +(* [check_statement] implements the [non-unit-statement] check. + + This check is called in contexts where the value of the expression is known + to be discarded (eg. the lhs of a sequence). We check that [exp] has type + unit, or has an explicit type annotation; otherwise we raise the + [non-unit-statement] warning. *) + +let check_statement exp = + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in + match ty with + | Tconstr (p, _, _) when Path.same p Predef.path_unit -> () + | Tvar _ -> () + | _ -> + let rec loop {exp_loc; exp_desc; exp_extra; _} = + match exp_desc with + | Texp_let (_, _, e) + | Texp_sequence (_, e) + | Texp_letexception (_, e) + | Texp_letmodule (_, _, _, _, e) -> + loop e + | _ -> + let loc = + match List.find_opt (function + | (Texp_constraint _, _, _) -> true + | _ -> false) exp_extra + with + | Some (_, loc, _) -> loc + | None -> exp_loc in - loop exp - in - match ty, exp.exp_desc with - | Tarrow _, _ -> + Location.prerr_warning loc Warnings.Non_unit_statement + in + loop exp + + +(* [check_partial_application] implements the [ignored-partial-application] + warning (and if [statement] is [true], also [non-unit-statement]). + + If [exp] has a function type, we check that it is not syntactically the + result of a function application, as this is often a bug in certain contexts + (eg the rhs of a let-binding or in the argument of [ignore]). For example, + [ignore (List.map print_int)] written by mistake instad of [ignore (List.map + print_int li)]. + + The check can be disabled by explicitly annotating the expression with a type + constraint, eg [(e : _ -> _)]. + + If [statement] is [true] and the [ignored-partial-application] is {em not} + triggered, then the [non-unit-statement] check is performaed (see + [check_statement]). + + If the type of [exp] is not known at the time this function is called, the + check is retried again after typechecking. *) + +let check_partial_application ~statement exp = + let check_statement () = if statement then check_statement exp in + let doit () = + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in + match ty with + | Tarrow _ -> let rec check {exp_desc; exp_loc; exp_extra; _} = if List.exists (function | (Texp_constraint _, _, _) -> true @@ -3103,20 +3407,25 @@ let check_partial_application statement exp = end in check exp - | Tvar _, _ -> - if delay then add_delayed_check (fun () -> f false) | _ -> check_statement () in - f true + let ty = get_desc (expand_head exp.exp_env exp.exp_type) in + match ty with + | Tvar _ -> + (* The type of [exp] is not known. Delay the check until after + typechecking in order to give a chance for the type to become known + through unification. *) + add_delayed_check doit + | _ -> + doit () (* Check that a type is generalizable at some level *) let generalizable level ty = let rec check ty = - let ty = repr ty in - if ty.level < lowest_level then () else - if ty.level <= level then raise Exit else - (mark_type_node ty; iter_type_expr check ty) + if not_marked_node ty then + if get_level ty <= level then raise Exit else + (flip_mark_node ty; iter_type_expr check ty) in try check ty; unmark_type ty; true with Exit -> unmark_type ty; false @@ -3124,40 +3433,22 @@ let generalizable level ty = (* Hack to allow coercion of self. Will clean-up later. *) let self_coercion = ref ([] : (Path.t * Location.t list ref) list) -(* Helpers for packaged modules. *) -let create_package_type loc env (p, l) = - let s = !Typetexp.transl_modtype_longident loc env p in - let fields = - List.map - (fun (name, ct) -> - name, Typetexp.transl_simple_type env false Global ct) - l - in - let ty = newty (Tpackage (s, - List.map fst l, - List.map (fun (_, cty) -> cty.ctyp_type) fields)) - in - (s, fields, ty) - (* Helpers for type_cases *) let contains_variant_either ty = let rec loop ty = - let ty = repr ty in - if ty.level >= lowest_level then begin - mark_type_node ty; - match ty.desc with + if try_mark_node ty then + begin match get_desc ty with Tvariant row -> - let row = row_repr row in if not (is_fixed row) then List.iter (fun (_,f) -> match row_field_repr f with Reither _ -> raise Exit | _ -> ()) - row.row_fields; + (row_fields row); iter_row loop row | _ -> iter_type_expr loop ty - end + end in try loop ty; unmark_type ty; false with Exit -> unmark_type ty; true @@ -3165,12 +3456,14 @@ let contains_variant_either ty = let shallow_iter_ppat f p = match p.ppat_desc with | Ppat_any | Ppat_var _ | Ppat_constant _ | Ppat_interval _ + | Ppat_construct (_, None) | Ppat_extension _ | Ppat_type _ | Ppat_unpack _ -> () | Ppat_array pats -> List.iter f pats | Ppat_or (p1,p2) -> f p1; f p2 - | Ppat_variant (_, arg) | Ppat_construct (_, arg) -> Option.iter f arg + | Ppat_variant (_, arg) -> Option.iter f arg | Ppat_tuple lst -> List.iter f lst + | Ppat_construct (_, Some (_, p)) | Ppat_exception p | Ppat_alias (p,_) | Ppat_open (_,p) | Ppat_constraint (p,_) | Ppat_lazy p -> f p @@ -3195,7 +3488,7 @@ let contains_polymorphic_variant p = let contains_gadt p = exists_general_pattern { f = fun (type k) (p : k general_pattern) -> match p.pat_desc with - | Tpat_construct (_, cd, _) when cd.cstr_generalized -> true + | Tpat_construct (_, cd, _, _) when cd.cstr_generalized -> true | _ -> false } p (* There are various things that we need to do in presence of GADT constructors @@ -3206,7 +3499,7 @@ let contains_gadt p = let may_contain_gadts p = exists_ppat (function - | {ppat_desc = Ppat_construct (_, _)} -> true + | {ppat_desc = Ppat_construct _} -> true | _ -> false) p @@ -3214,16 +3507,17 @@ let check_absent_variant env = iter_general_pattern { f = fun (type k) (pat : k general_pattern) -> match pat.pat_desc with | Tpat_variant (s, arg, row) -> - let row = row_repr !row in + let row = !row in if List.exists (fun (s',fi) -> s = s' && row_field_repr fi <> Rabsent) - row.row_fields + (row_fields row) || not (is_fixed row) && not (static_row row) (* same as Ctype.poly *) then () else let ty_arg = match arg with None -> [] | Some p -> [correct_levels p.pat_type] in - let row' = {row_fields = [s, Reither(arg=None,ty_arg,true,ref None)]; - row_more = newvar (); row_bound = (); - row_closed = false; row_fixed = None; row_name = None} in + let fields = [s, rf_either ty_arg ~no_arg:(arg=None) ~matched:true] in + let row' = + create_row ~fields + ~more:(newvar ()) ~closed:false ~fixed:None ~name:None in (* Should fail *) unify_pat (ref env) {pat with pat_type = newty (Tvariant row')} (correct_levels pat.pat_type) @@ -3269,8 +3563,8 @@ let unify_exp env exp expected_ty = let loc = proper_exp_loc exp in try unify_exp_types loc env exp.exp_type expected_ty - with Error(loc, env, Expr_type_clash(trace, tfc, None)) -> - raise (Error(loc, env, Expr_type_clash(trace, tfc, Some exp.exp_desc))) + with Error(loc, env, Expr_type_clash(err, tfc, None)) -> + raise (Error(loc, env, Expr_type_clash(err, tfc, Some exp.exp_desc))) (* If [is_inferred e] is true, [e] will be typechecked without using the "expected type" provided by the context. *) @@ -3283,6 +3577,47 @@ let rec is_inferred sexp = | Pexp_ifthenelse (_, e1, Some e2) -> is_inferred e1 && is_inferred e2 | _ -> false +(* check if the type of %apply or %revapply matches the type expected by + the specialized typing rule for those primitives. +*) +type apply_prim = + | Apply + | Revapply +let check_apply_prim_type prim typ = + match get_desc typ with + | Tarrow ((Nolabel,_,_),a,b,_) when tpoly_is_mono a -> + let a = tpoly_get_mono a in + begin match get_desc b with + | Tarrow((Nolabel,_,_),c,d,_) when tpoly_is_mono c -> + let c = tpoly_get_mono c in + let f, x, res = + match prim with + | Apply -> a, c, d + | Revapply -> c, a, d + in + begin match get_desc f with + | Tarrow((Nolabel,_,_),fl,fr,_) -> + let fl = tpoly_get_mono fl in + is_Tvar fl && is_Tvar fr && is_Tvar x && is_Tvar res + && Types.eq_type fl x && Types.eq_type fr res + | _ -> false + end + | _ -> false + end + | _ -> false + +(* Merge explanation to type clash error *) + +let with_explanation explanation f = + match explanation with + | None -> f () + | Some explanation -> + try f () + with Error (loc', env', Expr_type_clash(err', None, exp')) + when not loc'.Location.loc_ghost -> + let err = Expr_type_clash(err', Some explanation, exp') in + raise (Error (loc', env', err)) + let rec type_exp ?recarg env expected_mode sexp = (* We now delegate everything to type_expect *) type_expect ?recarg env expected_mode sexp (mk_expected (newvar ())) @@ -3307,16 +3642,6 @@ and type_expect ?in_function ?recarg env (Cmt_format.Partial_expression exp :: previous_saved_types); exp -and with_explanation explanation f = - match explanation with - | None -> f () - | Some explanation -> - try f () - with Error (loc', env', Expr_type_clash(trace', None, exp')) - when not loc'.Location.loc_ghost -> - let err = Expr_type_clash(trace', Some explanation, exp') in - raise (Error (loc', env', err)) - and type_expect_ ?in_function ?(recarg=Rejected) env (expected_mode : expected_mode) sexp ty_expected_explained = @@ -3348,7 +3673,7 @@ and type_expect_ match lid.txt with Longident.Lident txt -> { txt; loc = lid.loc } | _ -> assert false) - | Val_self (_, _, cl_num, _) -> + | Val_self (_, _, _, cl_num) -> let (path, _) = Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env in @@ -3371,9 +3696,9 @@ and type_expect_ Path.(Pdot (Pident (Ident.create_persistent "CamlinternalFormatBasics"), "format6")) in - let is_format = match ty_exp.desc with + let is_format = match get_desc ty_exp with | Tconstr(path, _, _) when Path.same path fmt6_path -> - if !Clflags.principal && ty_exp.level <> generic_level then + if !Clflags.principal && get_level ty_exp <> generic_level then Location.prerr_warning loc (Warnings.Not_principal "this coercion to format6"); true @@ -3443,11 +3768,13 @@ and type_expect_ (* Defaults are always global. They can be moved out of the function's region by Simplf.split_default_wrapper, or they could be evaluated later than expected by Translcore.push_defaults *) + if has_poly_constraint spat then + raise(Error(spat.ppat_loc, env, Optional_poly_param)); let scases = [ Exp.case (Pat.construct ~loc:default_loc (mknoloc (Longident.(Ldot (Lident "*predef*", "Some")))) - (Some (Pat.var ~loc:default_loc (mknoloc "*sth*")))) + (Some ([], Pat.var ~loc:default_loc (mknoloc "*sth*")))) (Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*"))); Exp.case @@ -3477,33 +3804,42 @@ and type_expect_ let has_local = has_local_attr_pat spat in type_function ?in_function loc sexp.pexp_attributes env expected_mode ty_expected_explained - l has_local [Exp.case pat body] + l ~has_local ~has_poly:false [Exp.case pat body] | Pexp_fun (l, None, spat, sbody) -> let has_local = has_local_attr_pat spat in + let has_poly = has_poly_constraint spat in + if has_poly && is_optional l then + raise(Error(spat.ppat_loc, env, Optional_poly_param)); + if has_poly + && not (Clflags.Extension.is_enabled Polymorphic_parameters) then + raise (Typetexp.Error (loc, env, + Unsupported_extension Polymorphic_parameters)); type_function ?in_function loc sexp.pexp_attributes env - expected_mode ty_expected_explained l has_local - [Ast_helper.Exp.case spat sbody] + expected_mode ty_expected_explained l ~has_local + ~has_poly [Ast_helper.Exp.case spat sbody] | Pexp_function caselist -> type_function ?in_function loc sexp.pexp_attributes env expected_mode - ty_expected_explained Nolabel false caselist + ty_expected_explained Nolabel ~has_local:false ~has_poly:false caselist | Pexp_apply ({ pexp_desc = Pexp_extension({txt = "extension.local"}, PStr []) }, [Nolabel, sbody]) -> if not (Clflags.Extension.is_enabled Local) then - raise (Typetexp.Error (loc, Env.empty, Local_not_enabled)); + raise (Typetexp.Error (loc, Env.empty, Unsupported_extension Local)); + let mode = expect_mode_cross env ty_expected mode_local in submode ~loc ~env Value_mode.local expected_mode; let exp = - type_expect ?in_function ~recarg env mode_local sbody + type_expect ?in_function ~recarg env mode sbody ty_expected_explained in { exp with exp_loc = loc } | Pexp_apply ({ pexp_desc = Pexp_extension({txt = ("ocaml.local" | "local")}, PStr []) }, [Nolabel, sbody]) -> - submode ~loc ~env Value_mode.local expected_mode; + let mode = expect_mode_cross env ty_expected mode_local in + submode ~loc ~env mode.mode expected_mode; let exp = - type_expect ?in_function ~recarg env mode_local sbody + type_expect ?in_function ~recarg env mode sbody ty_expected_explained in { exp with exp_loc = loc } @@ -3527,15 +3863,24 @@ and type_expect_ let mode = Value_mode.newvar () in mode, mode_nontail mode in - let rec lower_args seen ty_fun = + (* does the function return a tvar which is too generic? *) + let rec ret_tvar seen ty_fun = let ty = expand_head env ty_fun in - if List.memq ty seen then () else - match ty.desc with + if TypeSet.mem ty seen then false else + match get_desc ty with Tarrow (_l, ty_arg, ty_fun, _com) -> (try unify_var env (newvar()) ty_arg with Unify _ -> assert false); - lower_args (ty::seen) ty_fun - | _ -> () + ret_tvar (TypeSet.add ty seen) ty_fun + | Tvar _ -> + let v = newvar () in + let rt = get_level ty > get_level v in + unify_var env v ty; + rt + | _ -> + let v = newvar () in + unify_var env v ty; + false in let type_sfunct sfunct = begin_def (); (* one more level for non-returning functions *) @@ -3547,8 +3892,8 @@ and type_expect_ end; let ty = instance funct.exp_type in end_def (); - wrap_trace_gadt_instances env (lower_args []) ty; - funct + let rt = wrap_trace_gadt_instances env (ret_tvar TypeSet.empty) ty in + rt, funct in let type_sfunct_args sfunct extra_args = match sfunct.pexp_desc with @@ -3557,27 +3902,27 @@ and type_expect_ | _ -> type_sfunct sfunct, extra_args in - let funct, sargs = - let funct = type_sfunct sfunct in + let (rt, funct), sargs = + let rt, funct = type_sfunct sfunct in match funct.exp_desc, sargs with - | Texp_ident (_, _, {val_kind = Val_prim {prim_name = "%revapply"}}, + | Texp_ident (_, _, {val_kind = Val_prim {prim_name = "%revapply"}; val_type}, Id_prim _), [Nolabel, sarg; Nolabel, actual_sfunct] - when is_inferred actual_sfunct -> + when is_inferred actual_sfunct + && check_apply_prim_type Revapply val_type -> type_sfunct_args actual_sfunct [Nolabel, sarg] - | Texp_ident (_, _, {val_kind = Val_prim {prim_name = "%apply"}}, + | Texp_ident (_, _, {val_kind = Val_prim {prim_name = "%apply"}; val_type}, Id_prim _), - [Nolabel, actual_sfunct; Nolabel, sarg] -> + [Nolabel, actual_sfunct; Nolabel, sarg] + when check_apply_prim_type Apply val_type -> type_sfunct_args actual_sfunct [Nolabel, sarg] | _ -> - funct, sargs + (rt, funct), sargs in - begin_def (); let (args, ty_res, position) = - type_application env loc expected_mode position funct funct_mode sargs + type_application env loc expected_mode position funct funct_mode sargs rt in - end_def (); - unify_var env (newvar()) funct.exp_type; + rue { exp_desc = Texp_apply(funct, args, position); exp_loc = loc; exp_extra = []; @@ -3647,7 +3992,7 @@ and type_expect_ let expl = List.map2 (fun body (ty, argument_mode) -> - type_expect env (mode_nontail argument_mode) + type_expect env (mode_nontail (mode_cross env ty argument_mode)) body (mk_expected ty)) sexpl types_and_modes in @@ -3669,11 +4014,14 @@ and type_expect_ let ty_expected0 = instance ty_expected in let argument_mode = mode_subcomponent expected_mode in begin try match - sarg, expand_head env ty_expected, expand_head env ty_expected0 with - | Some sarg, {desc = Tvariant row}, {desc = Tvariant row0} -> - let row = row_repr row in - begin match row_field_repr (List.assoc l row.row_fields), - row_field_repr (List.assoc l row0.row_fields) with + sarg, get_desc (expand_head env ty_expected), + get_desc (expand_head env ty_expected0) + with + | Some sarg, Tvariant row, Tvariant row0 -> + begin match + row_field_repr (get_row_field l row), + row_field_repr (get_row_field l row0) + with Rpresent (Some ty), Rpresent (Some ty0) -> let arg = type_argument env argument_mode sarg ty ty0 in re { exp_desc = Texp_variant(l, Some arg); @@ -3682,21 +4030,24 @@ and type_expect_ exp_mode = expected_mode.mode; exp_attributes = sexp.pexp_attributes; exp_env = env } - | _ -> raise Not_found + | _ -> raise Exit end - | _ -> raise Not_found - with Not_found -> + | _ -> raise Exit + with Exit -> let arg = Option.map (type_exp env argument_mode) sarg in let arg_type = Option.map (fun arg -> arg.exp_type) arg in + let row = + create_row + ~fields: [l, rf_present arg_type] + ~more: (newvar ()) + ~closed: false + ~fixed: None + ~name: None + in rue { exp_desc = Texp_variant(l, arg); exp_loc = loc; exp_extra = []; - exp_type= newty (Tvariant{row_fields = [l, Rpresent arg_type]; - row_more = newvar (); - row_bound = (); - row_closed = false; - row_fixed = None; - row_name = None}); + exp_type = newty (Tvariant row); exp_mode = expected_mode.mode; exp_attributes = sexp.pexp_attributes; exp_env = env } @@ -3717,43 +4068,45 @@ and type_expect_ Some exp in let ty_record, expected_type = - let get_path ty = - try - let (p0, p,_) = extract_concrete_record env ty in - let principal = - (repr ty).level = generic_level || not !Clflags.principal + let expected_opath = + match extract_concrete_record env ty_expected with + | Record_type (p0, p, _) -> Some (p0, p, is_principal ty_expected) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let error = + Wrong_expected_kind(Record, Expression explanation, ty_expected) in - Some (p0, p, principal) - with Not_found -> None + raise (Error (loc, env, error)) in - let opath = get_path ty_expected in - match opath with - None | Some (_, _, false) -> - let ty = if opath = None then newvar () else ty_expected in - begin match opt_exp with - None -> ty, opath - | Some exp -> - match get_path exp.exp_type with - None -> - ty, opath - | Some (_, p', _) as opath -> - let decl = Env.find_type p' env in - begin_def (); - let ty = - newconstr p' (instance_list decl.type_params) in - end_def (); - generalize_structure ty; - ty, opath - end - | _ -> ty_expected, opath + let opt_exp_opath = + match opt_exp with + | None -> None + | Some exp -> + match extract_concrete_record env exp.exp_type with + | Record_type (p0, p, _) -> Some (p0, p, is_principal exp.exp_type) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let error = Expr_not_a_record_type exp.exp_type in + raise (Error (exp.exp_loc, env, error)) + in + match expected_opath, opt_exp_opath with + | None, None -> newvar (), None + | Some _, None -> ty_expected, expected_opath + | Some(_, _, true), Some _ -> ty_expected, expected_opath + | (None | Some (_, _, false)), Some (_, p', _) -> + let decl = Env.find_type p' env in + begin_def (); + let ty = newconstr p' (instance_list decl.type_params) in + end_def (); + generalize_structure ty; + ty, opt_exp_opath in let closed = (opt_sexp = None) in let lbl_exp_list = wrap_disambiguate "This record expression is expected to have" (mk_expected ty_record) - (type_label_a_list loc closed env - (fun e k -> - k (type_label_exp true env expected_mode loc ty_record e)) + (type_label_a_list loc closed env Env.Construct + (fun e k -> k (type_label_exp true env expected_mode loc ty_record e)) expected_type lid_sexp_list) (fun x -> x) in @@ -3852,17 +4205,34 @@ and type_expect_ exp_attributes = sexp.pexp_attributes; exp_env = env } | Pexp_field(srecord, lid) -> - let (record, rmode, label, _) = type_label_access env srecord lid in + let (record, rmode, label, _) = + type_label_access env srecord Env.Projection lid + in let mode = match label.lbl_global with | Global -> Value_mode.global | Nonlocal -> Value_mode.local_to_regional rmode | Unrestricted -> rmode in - submode ~loc ~env mode expected_mode; + + if !Clflags.principal then + begin_def (); + + (* ty_arg is the type of field *) + (* ty_res is the type of record *) + (* they could share type variables *) + (* which are now instantiated *) let (_, ty_arg, ty_res) = instance_label false label in + + (* we now link the two record types *) unify_exp env record ty_res; - rue { + + if !Clflags.principal then begin + end_def (); + generalize_structure ty_arg + end; + let mode = mode_cross env ty_arg mode in + ruem ~mode ~expected_mode { exp_desc = Texp_field(record, lid, label); exp_loc = loc; exp_extra = []; exp_type = ty_arg; @@ -3871,7 +4241,7 @@ and type_expect_ exp_env = env } | Pexp_setfield(srecord, lid, snewval) -> let (record, rmode, label, expected_type) = - type_label_access env srecord lid in + type_label_access env srecord Env.Mutation lid in let ty_record = if expected_type = None then newvar () else record.exp_type in let (label_loc, label, newval) = @@ -3893,7 +4263,7 @@ and type_expect_ let to_unify = Predef.type_array ty in with_explanation (fun () -> unify_exp_types loc env to_unify (generic_instance ty_expected)); - let argument_mode = mode_subcomponent expected_mode in + let argument_mode = expect_mode_cross env ty mode_global in let argl = List.map (fun sarg -> type_expect env argument_mode sarg (mk_expected ty)) @@ -4013,8 +4383,8 @@ and type_expect_ let ty = cty.ctyp_type in end_def (); generalize_structure ty; - let arg = type_argument env expected_mode sarg ty (instance ty) in let ty' = instance ty in + let arg = type_argument env expected_mode sarg ty (instance ty) in rue { exp_desc = arg.exp_desc; exp_loc = arg.exp_loc; @@ -4043,9 +4413,9 @@ and type_expect_ let arg = type_exp env expected_mode sarg in end_def (); let tv = newvar () in - let gen = generalizable tv.level arg.exp_type in + let gen = generalizable (get_level tv) arg.exp_type in unify_var env tv arg.exp_type; - begin match arg.exp_desc, !self_coercion, (repr ty').desc with + begin match arg.exp_desc, !self_coercion, get_desc ty' with Texp_ident(_, _, {val_kind=Val_self _}, _), (path,r) :: _, Tconstr(path',_,_) when Path.same path path' -> (* prerr_endline "self coercion"; *) @@ -4067,16 +4437,17 @@ and type_expect_ if not gen && !Clflags.principal then Location.prerr_warning loc (Warnings.Not_principal "this ground coercion"); - with Subtype (tr1, tr2) -> + with Subtype err -> (* prerr_endline "coercion failed"; *) - raise(Error(loc, env, Not_subtype(tr1, tr2))) + raise (Error(loc, env, Not_subtype err)) end; | _ -> let ty, b = enlarge_type env ty' in force (); - begin try Ctype.unify env arg.exp_type ty with Unify trace -> + begin try Ctype.unify env arg.exp_type ty with Unify err -> + let expanded = full_expand ~may_forget_scope:true env ty' in raise(Error(sarg.pexp_loc, env, - Coercion_failure(ty', full_expand env ty', trace, b))) + Coercion_failure({ty = ty'; expanded}, err, b))) end end; (arg, ty', None, cty') @@ -4087,15 +4458,15 @@ and type_expect_ and (cty', ty', force') = Typetexp.transl_simple_type_delayed env type_mode sty' in - begin try - let force'' = subtype env ty ty' in - force (); force' (); force'' () - with Subtype (tr1, tr2) -> - raise(Error(loc, env, Not_subtype(tr1, tr2))) - end; end_def (); generalize_structure ty; generalize_structure ty'; + begin try + let force'' = subtype env (instance ty) (instance ty') in + force (); force' (); force'' () + with Subtype err -> + raise (Error(loc, env, Not_subtype err)) + end; (type_argument env expected_mode sarg ty (instance ty), instance ty', Some cty, cty') in @@ -4112,134 +4483,114 @@ and type_expect_ | Pexp_send (e, {txt=met}) -> if !Clflags.principal then begin_def (); let obj = type_exp env mode_global e in - let obj_meths = ref None in let ap_pos = apply_position env expected_mode sexp in - begin try - let (meth, exp, typ) = - match obj.exp_desc with - Texp_ident(_p, _, {val_kind = Val_self (meths, _, _, privty)}, _) -> - obj_meths := Some meths; - let (id, typ) = - filter_self_method env met Private meths privty - in - if is_Tvar (repr typ) then - Location.prerr_warning loc - (Warnings.Undeclared_virtual_method met); - (Tmeth_val id, None, typ) - | Texp_ident(_p, lid, {val_kind = Val_anc (methods, cl_num)}, _) -> - let method_id = - begin try List.assoc met methods with Not_found -> - let valid_methods = List.map fst methods in - raise(Error(e.pexp_loc, env, - Undefined_inherited_method (met, valid_methods))) - end - in - begin match - Env.find_value_by_name - (Longident.Lident ("selfpat-" ^ cl_num)) env, - Env.find_value_by_name - (Longident.Lident ("self-" ^cl_num)) env - with - | (_, ({val_kind = Val_self (meths, _, _, privty)} as desc)), - (path, _) -> - obj_meths := Some meths; - let (_, typ) = - filter_self_method env met Private meths privty - in - let method_type = newvar () in - let (marg, obj_ty, mres, res_ty) = - filter_arrow env method_type Nolabel - in - unify_alloc_mode marg Alloc_mode.global; - unify_alloc_mode mres Alloc_mode.global; - unify env obj_ty desc.val_type; - unify env res_ty (instance typ); - let method_desc = - {val_type = method_type; - val_kind = Val_reg; - val_attributes = []; - val_loc = Location.none; - val_uid = Uid.internal_not_actually_unique; - } + let (meth, typ) = + match obj.exp_desc with + | Texp_ident(_, _, {val_kind = Val_self(sign, meths, _, _)}, _) -> + let id, typ = + match meths with + | Self_concrete meths -> + let id = + match Meths.find met meths with + | id -> id + | exception Not_found -> + let valid_methods = + Meths.fold (fun lab _ acc -> lab :: acc) meths [] + in + raise (Error(e.pexp_loc, env, + Undefined_self_method (met, valid_methods))) in - let exp_env = Env.add_value method_id method_desc env in - let exp = - Texp_apply({exp_desc = - Texp_ident(Path.Pident method_id, - lid, method_desc, Id_value); - exp_loc = loc; exp_extra = []; - exp_type = method_type; - exp_mode = Value_mode.global; - exp_attributes = []; (* check *) - exp_env = exp_env}, - [ Nolabel, - Arg {exp_desc = Texp_ident(path, lid, desc, Id_value); - exp_loc = obj.exp_loc; exp_extra = []; - exp_type = desc.val_type; - exp_mode = Value_mode.global; - exp_attributes = []; (* check *) - exp_env = exp_env} - ], ap_pos) + let typ = Btype.method_type met sign in + id, typ + | Self_virtual meths_ref -> begin + match Meths.find met !meths_ref with + | id -> id, Btype.method_type met sign + | exception Not_found -> + let id = Ident.create_local met in + let ty = newvar () in + meths_ref := Meths.add met id !meths_ref; + add_method env met Private Virtual ty sign; + Location.prerr_warning loc + (Warnings.Undeclared_virtual_method met); + id, ty + end + in + Tmeth_val id, typ + | Texp_ident(_, _, {val_kind = Val_anc (sign, meths, cl_num)}, _) -> + let id = + match Meths.find met meths with + | id -> id + | exception Not_found -> + let valid_methods = + Meths.fold (fun lab _ acc -> lab :: acc) meths [] in - (Tmeth_name met, Some (re {exp_desc = exp; - exp_loc = loc; exp_extra = []; - exp_type = typ; - exp_mode = expected_mode.mode; - exp_attributes = []; (* check *) - exp_env = exp_env}), typ) - | _ -> - assert false - end - | _ -> - (Tmeth_name met, None, - filter_method env met Public obj.exp_type) - in - if !Clflags.principal then begin - end_def (); - generalize_structure typ; - end; - let typ = - match repr typ with - {desc = Tpoly (ty, [])} -> - instance ty - | {desc = Tpoly (ty, tl); level = l} -> - if !Clflags.principal && l <> generic_level then - Location.prerr_warning loc - (Warnings.Not_principal "this use of a polymorphic method"); - snd (instance_poly false tl ty) - | {desc = Tvar _} as ty -> - let ty' = newvar () in - unify env (instance ty) (newty(Tpoly(ty',[]))); - (* if not !Clflags.nolabels then - Location.prerr_warning loc (Warnings.Unknown_method met); *) - ty' - | _ -> - assert false - in - rue { - exp_desc = Texp_send(obj, meth, exp, ap_pos); - exp_loc = loc; exp_extra = []; - exp_type = typ; - exp_mode = expected_mode.mode; - exp_attributes = sexp.pexp_attributes; - exp_env = env } - with Unify _ -> - let valid_methods = - match !obj_meths with - | Some meths -> - Some (Meths.fold (fun meth _meth_ty li -> meth::li) !meths []) - | None -> - match (expand_head env obj.exp_type).desc with - | Tobject (fields, _) -> - let (fields, _) = Ctype.flatten_fields fields in - let collect_fields li (meth, meth_kind, _meth_ty) = - if meth_kind = Fpresent then meth::li else li in - Some (List.fold_left collect_fields [] fields) - | _ -> None - in - raise(Error(e.pexp_loc, env, - Undefined_method (obj.exp_type, met, valid_methods))) - end + raise (Error(e.pexp_loc, env, + Undefined_self_method (met, valid_methods))) + in + let typ = Btype.method_type met sign in + let (self_path, _) = + Env.find_value_by_name + (Longident.Lident ("self-" ^ cl_num)) env + in + Tmeth_ancestor(id, self_path), typ + | _ -> + let ty = + match filter_method env met obj.exp_type with + | ty -> ty + | exception Filter_method_failed err -> + let error = + match err with + | Unification_error err -> + Expr_type_clash(err, explanation, None) + | Not_an_object ty -> + Not_an_object(ty, explanation) + | Not_a_method -> + let valid_methods = + match get_desc (expand_head env obj.exp_type) with + | Tobject (fields, _) -> + let (fields, _) = Ctype.flatten_fields fields in + let collect_fields li (meth, meth_kind, _meth_ty) = + if field_kind_repr meth_kind = Fpublic + then meth::li else li + in + Some (List.fold_left collect_fields [] fields) + | _ -> None + in + Undefined_method(obj.exp_type, met, valid_methods) + in + raise (Error(e.pexp_loc, env, error)) + in + Tmeth_name met, ty + in + if !Clflags.principal then begin + end_def (); + generalize_structure typ; + end; + let typ = + match get_desc typ with + | Tpoly (ty, []) -> + instance ty + | Tpoly (ty, tl) -> + if !Clflags.principal && get_level typ <> generic_level then + Location.prerr_warning loc + (Warnings.Not_principal "this use of a polymorphic method"); + snd (instance_poly false tl ty) + | Tvar _ -> + let ty' = newvar () in + unify env (instance typ) (newty(Tpoly(ty',[]))); + (* if not !Clflags.nolabels then + Location.prerr_warning loc (Warnings.Unknown_method met); *) + ty' + | _ -> + assert false + in + rue { + exp_desc = Texp_send(obj, meth, ap_pos); + exp_loc = loc; exp_extra = []; + exp_type = typ; + exp_mode = expected_mode.mode; + exp_attributes = sexp.pexp_attributes; + exp_env = env } | Pexp_new cl -> let (cl_path, cl_decl) = Env.lookup_class ~loc:cl.loc cl.txt env in let ap_pos = apply_position env expected_mode sexp in @@ -4294,17 +4645,16 @@ and type_expect_ with Not_found -> raise(Error(loc, env, Outside_class)) with - (_, {val_type = self_ty; val_kind = Val_self (_, vars, _, _)}), + (_, {val_type = self_ty; val_kind = Val_self (sign, _, vars, _)}), (path_self, _) -> let type_override (lab, snewval) = begin try - let (id, _, _, ty) = Vars.find lab.txt !vars in - (Path.Pident id, lab, - type_expect env mode_global snewval - (mk_expected (instance ty))) + let id = Vars.find lab.txt vars in + let ty = Btype.instance_variable_type lab.txt sign in + (id, lab, type_expect env mode_global snewval (mk_expected (instance ty))) with Not_found -> - let vars = Vars.fold (fun var _ li -> var::li) !vars [] in + let vars = Vars.fold (fun var _ li -> var::li) vars [] in raise(Error(loc, env, Unbound_instance_variable (lab.txt, vars))) end @@ -4325,8 +4675,8 @@ and type_expect_ (* remember original level *) begin_def (); let context = Typetexp.narrow () in - let modl = !type_module env smodl in - Mtype.lower_nongen ty.level modl.mod_type; + let modl, md_shape = !type_module env smodl in + Mtype.lower_nongen (get_level ty) modl.mod_type; let pres = match modl.mod_type with | Mty_alias _ -> Mp_absent @@ -4341,7 +4691,9 @@ and type_expect_ match name.txt with | None -> None, env | Some name -> - let id, env = Env.enter_module_declaration ~scope name pres md env in + let id, env = + Env.enter_module_declaration ~scope ~shape:md_shape name pres md env + in Some id, env in Typetexp.widen context; @@ -4411,11 +4763,11 @@ and type_expect_ exp_env = env; } | Pexp_object s -> - let desc, sign, meths = !type_object env loc s in + let desc, meths = !type_object env loc s in rue { - exp_desc = Texp_object (desc, (*sign,*) meths); + exp_desc = Texp_object (desc, meths); exp_loc = loc; exp_extra = []; - exp_type = sign.csig_self; + exp_type = desc.cstr_type.csig_self; exp_mode = expected_mode.mode; exp_attributes = sexp.pexp_attributes; exp_env = env; @@ -4423,11 +4775,11 @@ and type_expect_ | Pexp_poly(sbody, sty) -> if !Clflags.principal then begin_def (); let ty, cty = - match sty with None -> repr ty_expected, None + match sty with None -> ty_expected, None | Some sty -> let sty = Ast_helper.Typ.force_poly sty in let cty = Typetexp.transl_simple_type env false Global sty in - repr cty.ctyp_type, Some cty + cty.ctyp_type, Some cty in if !Clflags.principal then begin end_def (); @@ -4437,7 +4789,7 @@ and type_expect_ with_explanation (fun () -> unify_exp_types loc env (instance ty) (instance ty_expected)); let exp = - match (expand_head env ty).desc with + match get_desc (expand_head env ty) with Tpoly (ty', []) -> let exp = type_expect env expected_mode sbody (mk_expected ty') in { exp with exp_type = instance ty } @@ -4456,7 +4808,7 @@ and type_expect_ { exp with exp_type = instance ty } | Tvar _ -> let exp = type_exp env expected_mode sbody in - let exp = {exp with exp_type = newty (Tpoly (exp.exp_type, []))} in + let exp = {exp with exp_type = newmono exp.exp_type} in unify_exp env exp ty; exp | _ -> assert false @@ -4473,23 +4825,7 @@ and type_expect_ (* remember original level *) begin_def (); (* Create a fake abstract type declaration for name. *) - let decl = { - type_params = []; - type_arity = 0; - type_kind = Type_abstract; - type_private = Public; - type_manifest = None; - type_variance = []; - type_separability = []; - type_is_newtype = true; - type_expansion_scope = Btype.lowest_level; - type_loc = loc; - type_attributes = []; - type_immediate = Unknown; - type_unboxed = unboxed_false_default_false; - type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); - } - in + let decl = new_local_type ~loc () in let scope = create_scope () in let (id, new_env) = Env.enter_type ~scope name decl env in @@ -4498,10 +4834,10 @@ and type_expect_ type. *) let seen = Hashtbl.create 8 in let rec replace t = - if Hashtbl.mem seen t.id then () + if Hashtbl.mem seen (get_id t) then () else begin - Hashtbl.add seen t.id (); - match t.desc with + Hashtbl.add seen (get_id t) (); + match get_desc t with | Tconstr (Path.Pident id', _, _) when id == id' -> link_type t ty | _ -> Btype.iter_type_expr replace t end @@ -4519,25 +4855,26 @@ and type_expect_ exp_extra = (Texp_newtype name, loc, sexp.pexp_attributes) :: body.exp_extra } | Pexp_pack m -> - let (p, nl) = - match Ctype.expand_head env (instance ty_expected) with - {desc = Tpackage (p, nl, _tl)} -> + let (p, fl) = + match get_desc (Ctype.expand_head env (instance ty_expected)) with + Tpackage (p, fl) -> if !Clflags.principal && - (Ctype.expand_head env ty_expected).level < Btype.generic_level + get_level (Ctype.expand_head env ty_expected) + < Btype.generic_level then Location.prerr_warning loc (Warnings.Not_principal "this module packing"); - (p, nl) - | {desc = Tvar _} -> + (p, fl) + | Tvar _ -> raise (Error (loc, env, Cannot_infer_signature)) | _ -> raise (Error (loc, env, Not_a_packed_module ty_expected)) in - let (modl, tl') = !type_package env m p nl in + let (modl, fl') = !type_package env m p fl in rue { exp_desc = Texp_pack modl; exp_loc = loc; exp_extra = []; - exp_type = newty (Tpackage (p, nl, tl')); + exp_type = newty (Tpackage (p, fl')); exp_mode = expected_mode.mode; exp_attributes = sexp.pexp_attributes; exp_env = env } @@ -4574,22 +4911,21 @@ and type_expect_ let op_type = instance op_desc.val_type in let spat_params, ty_params = loop slet.pbop_pat (newvar ()) sands in let ty_func_result = newvar () in + let arrow_desc = Nolabel, Alloc_mode.global, Alloc_mode.global in let ty_func = - newty (Tarrow( - (Nolabel, Alloc_mode.global, Alloc_mode.global), - ty_params, ty_func_result, Cok)) + newty (Tarrow(arrow_desc, newmono ty_params, ty_func_result, commu_ok)) in let ty_result = newvar () in let ty_andops = newvar () in let ty_op = - newty (Tarrow((Nolabel, Alloc_mode.global, Alloc_mode.global), ty_andops, - newty (Tarrow((Nolabel, Alloc_mode.global, Alloc_mode.global), - ty_func, ty_result, Cok)), Cok)) + newty (Tarrow(arrow_desc, newmono ty_andops, + newty (Tarrow(arrow_desc, newmono ty_func, + ty_result, commu_ok)), commu_ok)) in begin try unify env op_type ty_op - with Unify trace -> - raise(Error(let_loc, env, Letop_type_clash(slet.pbop_op.txt, trace))) + with Unify err -> + raise(Error(let_loc, env, Letop_type_clash(slet.pbop_op.txt, err))) end; if !Clflags.principal then begin end_def (); @@ -4734,11 +5070,11 @@ and type_expect_ and type_ident env ?(recarg=Rejected) lid = let (path, desc, mode) = Env.lookup_value ~loc:lid.loc lid.txt env in let is_recarg = - match (repr desc.val_type).desc with + match get_desc desc.val_type with | Tconstr(p, _, _) -> Path.is_constructor_typath p | _ -> false in - begin match is_recarg, recarg, (repr desc.val_type).desc with + begin match is_recarg, recarg, get_desc desc.val_type with | _, Allowed, _ | true, Required, _ | false, Rejected, _ -> () @@ -4769,7 +5105,7 @@ and type_binding_op_ident env s = match desc.val_kind with | Val_ivar _ -> fatal_error "Illegal name for instance variable" - | Val_self (_, _, cl_num, _) -> + | Val_self (_, _, _, cl_num) -> let path, _ = Env.find_value_by_name (Longident.Lident ("self-" ^ cl_num)) env in @@ -4781,7 +5117,7 @@ and type_binding_op_ident env s = path, desc and type_function ?in_function loc attrs env (expected_mode : expected_mode) - ty_expected_explained l has_local caselist = + ty_expected_explained arg_label ~has_local ~has_poly caselist = let { ty = ty_expected; explanation } = ty_expected_explained in register_allocation expected_mode; let alloc_mode = Value_mode.regional_to_global_alloc expected_mode.mode in @@ -4800,47 +5136,61 @@ and type_function ?in_function loc attrs env (expected_mode : expected_mode) in let ty_expected' = instance ty_expected in let (arg_mode, ty_arg, ret_mode, ty_res) = - try filter_arrow env ty_expected' l - with Unify _ -> - match expand_head env ty_expected with - {desc = Tarrow _} as ty -> - raise(Error(loc, env, Abstract_wrong_label(l, ty, explanation))) - | _ -> - raise(Error(loc_fun, env, - Too_many_arguments (in_function <> None, - ty_fun, - explanation))) + let force_tpoly = + (* If [has_poly] is true then we rely on the later call to + type_pat to enforce the invariant that the parameter type + be a [Tpoly] node *) + not has_poly + in + try filter_arrow env ty_expected' arg_label ~force_tpoly + with Filter_arrow_failed err -> + let err = match err with + | Unification_error unif_err -> + Expr_type_clash(unif_err, explanation, None) + | Label_mismatch { got; expected; expected_type} -> + Abstract_wrong_label { got; expected; expected_type; explanation } + | Not_a_function -> begin + match in_function with + | Some _ -> Too_many_arguments(ty_fun, explanation) + | None -> Not_a_function(ty_fun, explanation) + end + in + raise (Error(loc_fun, env, err)) in if has_local then eqmode ~loc ~env arg_mode Alloc_mode.local (Param_mode_mismatch ty_expected'); if uncurried_function then begin - begin match Btype.Alloc_mode.submode arg_mode ret_mode with + begin match Alloc_mode.submode arg_mode ret_mode with | Ok () -> () | Error () -> raise (Error(loc_fun, env, Uncurried_function_escapes)) end; - begin match Btype.Alloc_mode.submode alloc_mode ret_mode with + begin match Alloc_mode.submode alloc_mode ret_mode with | Ok () -> () | Error () -> raise (Error(loc_fun, env, Uncurried_function_escapes)) end end; - let ty_arg = - if is_optional l then - let tv = newvar() in - begin - try unify env ty_arg (type_option tv) - with Unify _ -> assert false - end; - type_option tv - else ty_arg - in if separate then begin end_def (); generalize_structure ty_arg; generalize_structure ty_res end; + if not has_poly && not (tpoly_is_mono ty_arg) && !Clflags.principal + && get_level ty_arg < Btype.generic_level then begin + let snap = Btype.snapshot () in + let really_poly = + try + unify env (newmono (newvar ())) ty_arg; + false + with Unify _ -> true + in + Btype.backtrack snap; + if really_poly then + Location.prerr_warning loc + (Warnings.Not_principal "this higher-rank function"); + end; let env, region_locked = match in_function with | Some (_, _, region_locked) -> env, region_locked @@ -4865,6 +5215,8 @@ and type_function ?in_function loc attrs env (expected_mode : expected_mode) in let cases_expected_mode, curry = if uncurried_function then + (* no need to check mode crossing in this case*) + (* because ty_res always a function *) mode_nontail (Value_mode.of_alloc ret_mode), More_args { partial_mode = ret_mode } else begin @@ -4872,9 +5224,10 @@ and type_function ?in_function loc attrs env (expected_mode : expected_mode) let ret_value_mode = if region_locked then Value_mode.local_to_regional ret_value_mode else ret_value_mode - in + in + let ret_value_mode = mode_cross env ty_res ret_value_mode in mode_return ret_value_mode, - Final_arg { partial_mode = Btype.Alloc_mode.join [arg_mode; alloc_mode] } + Final_arg { partial_mode = Alloc_mode.join [arg_mode; alloc_mode] } end in let in_function = @@ -4883,14 +5236,28 @@ and type_function ?in_function loc attrs env (expected_mode : expected_mode) else None in + let ty_arg_mono = + if has_poly then ty_arg + else begin + let ty, vars = tpoly_get_poly ty_arg in + if vars = [] then ty + else begin + begin_def (); + init_def generic_level; + let _, ty_arg = instance_poly ~keep_names:true false vars ty in + end_def (); + ty_arg + end + end + in let cases, partial = type_cases Value ?in_function env (simple_pat_mode arg_value_mode) - cases_expected_mode ty_arg (mk_expected ty_res) true loc caselist in + cases_expected_mode ty_arg_mono (mk_expected ty_res) true loc caselist in let not_nolabel_function ty = let ls, tvar = list_labels env ty in List.for_all ((<>) Nolabel) ls && not tvar in - if is_optional l && not_nolabel_function ty_res then + if is_optional arg_label && not_nolabel_function ty_res then Location.prerr_warning (List.hd cases).c_lhs.pat_loc Warnings.Unerasable_optional_argument; let param = name_cases "param" cases in @@ -4899,16 +5266,17 @@ and type_function ?in_function loc attrs env (expected_mode : expected_mode) re { exp_desc = Texp_function - { arg_label = l; param; cases; partial; region; curry; warnings }; + { arg_label; param; cases; partial; region; curry; warnings }; exp_loc = loc; exp_extra = []; exp_type = - instance (newgenty (Tarrow((l,arg_mode,ret_mode), ty_arg, ty_res, Cok))); + instance (newgenty (Tarrow((arg_label,arg_mode,ret_mode), + ty_arg, ty_res, commu_ok))); exp_mode = expected_mode.mode; exp_attributes = attrs; exp_env = env } -and type_label_access env srecord lid = +and type_label_access env srecord usage lid = if !Clflags.principal then begin_def (); let mode = Value_mode.newvar () in let record = type_exp ~recarg:Allowed env (mode_nontail mode) srecord in @@ -4918,15 +5286,18 @@ and type_label_access env srecord lid = end; let ty_exp = record.exp_type in let expected_type = - try - let (p0, p,_) = extract_concrete_record env ty_exp in - Some(p0, p, (repr ty_exp).level = generic_level || not !Clflags.principal) - with Not_found -> None + match extract_concrete_record env ty_exp with + | Record_type(p0, p, _) -> + Some(p0, p, is_principal ty_exp) + | Maybe_a_record_type -> None + | Not_a_record_type -> + let error = Expr_not_a_record_type ty_exp in + raise (Error (record.exp_loc, env, error)) in - let labels = Env.lookup_all_labels ~loc:lid.loc lid.txt env in + let labels = Env.lookup_all_labels ~loc:lid.loc usage lid.txt env in let label = wrap_disambiguate "This expression has" (mk_expected ty_exp) - (Label.disambiguate () lid env expected_type) labels in + (Label.disambiguate usage lid env expected_type) labels in (record, mode, label, expected_type) (* Typing format strings for printing or reading. @@ -5190,8 +5561,8 @@ and type_label_exp create env (expected_mode : expected_mode) loc ty_expected end; begin try unify env (instance ty_res) (instance ty_expected) - with Unify trace -> - raise (Error(lid.loc, env, Label_mismatch(lid.txt, trace))) + with Unify err -> + raise (Error(lid.loc, env, Label_mismatch(lid.txt, err))) end; (* Instantiate so that we can generalize internal nodes *) let ty_arg = instance ty_arg in @@ -5260,24 +5631,56 @@ and type_argument ?explanation ?recarg env (mode : expected_mode) sarg in let inferred = is_inferred sarg in let rec loosen_ret_modes ty' ty = - match expand_head env ty', expand_head env ty with - | {desc = Tarrow((l, marg, mret), ty_arg', ty_res', _); level = lv'}, - {desc = Tarrow(_, ty_arg, ty_res, _); level = lv } + let expty = expand_head env ty in + let expty' = expand_head env ty' in + let lv = get_level expty in + let lv' = get_level expty' in + match get_desc expty', get_desc expty with + | Tarrow((l, marg, mret), ty_arg', ty_res', _), + Tarrow(_, ty_arg, ty_res, _) when lv' = generic_level || not !Clflags.principal -> - let ty_res', ty_res = loosen_ret_modes ty_res' ty_res in - let mret, _ = Alloc_mode.newvar_below mret in - newty2 lv' (Tarrow((l, marg, mret), ty_arg', ty_res', Cok)), - newty2 lv (Tarrow((l, marg, mret), ty_arg, ty_res, Cok)) + let ty_res', ty_res, changed = loosen_ret_modes ty_res' ty_res in + let mret, changed' = Alloc_mode.newvar_below mret in + if changed || changed' then + newty2 ~level:lv' (Tarrow((l, marg, mret), ty_arg', ty_res', commu_ok)), + newty2 ~level:lv (Tarrow((l, marg, mret), ty_arg, ty_res, commu_ok)), + true + else + ty', ty, false | _ -> - ty', ty + ty', ty, false in let ty_expected', ty_expected = - if inferred then loosen_ret_modes ty_expected' ty_expected - else ty_expected', ty_expected + if inferred then + (* Do not expand local constraints unnecessarily (PR#10277) *) + let snap = + if Env.has_local_constraints env + then Some (Btype.snapshot ()) + else None + in + let t', t, changed = loosen_ret_modes ty_expected' ty_expected in + if not changed then Option.iter Btype.backtrack snap; + t', t + else + ty_expected', ty_expected + in + let may_coerce = + if not inferred then None else + let work () = + let te = expand_head env ty_expected' in + match get_desc te with + Tarrow((Nolabel,_,_),_,ty_res0,_) -> + Some (no_labels ty_res0, get_level te) + | _ -> None + in + (* Need to be careful not to expand local constraints here *) + if Env.has_local_constraints env then + let snap = Btype.snapshot () in + try_finally ~always:(fun () -> Btype.backtrack snap) work + else work () in - match expand_head env ty_expected' with - {desc = Tarrow((Nolabel,marg,mret),ty_arg,ty_res,_); level = lv} - when inferred -> + match may_coerce with + Some (safe_expect, lv) -> (* apply optional arguments when expected type is "" *) (* we must be very careful about not breaking the semantics *) if !Clflags.principal then begin_def (); @@ -5288,10 +5691,13 @@ and type_argument ?explanation ?recarg env (mode : expected_mode) sarg generalize_structure texp.exp_type end; let rec make_args args ty_fun = - match (expand_head env ty_fun).desc with + match get_desc (expand_head env ty_fun) with | Tarrow ((l,marg,_mret),ty_arg,ty_fun,_) when is_optional l -> let marg = Value_mode.of_alloc marg in - let ty = option_none env (instance ty_arg) marg sarg.pexp_loc in + let ty = + option_none env (instance (tpoly_get_mono ty_arg)) + marg sarg.pexp_loc + in make_args ((l, Arg ty) :: args) ty_fun | Tarrow ((l,_,_),_,ty_res',_) when l = Nolabel || !Clflags.classic -> List.rev args, ty_fun, no_labels ty_res' @@ -5299,15 +5705,21 @@ and type_argument ?explanation ?recarg env (mode : expected_mode) sarg | _ -> [], texp.exp_type, false in (* If make_args ends in Tvar, then simple_res is false, no_labels *) - let args, ty_fun', simple_res = make_args [] texp.exp_type in - let warn = !Clflags.principal && - (lv <> generic_level || (repr ty_fun').level <> generic_level) - and texp = {texp with exp_type = instance texp.exp_type} - and ty_fun = instance ty_fun' in - if not (simple_res || no_labels ty_res) then begin + let args, ty_fun', simple_res = make_args [] texp.exp_type + and texp = {texp with exp_type = instance texp.exp_type} in + if not (simple_res || safe_expect) then begin unify_exp env texp ty_expected; texp end else begin + let warn = !Clflags.principal && + (lv <> generic_level || get_level ty_fun' <> generic_level) + and ty_fun = instance ty_fun' in + let marg, ty_arg, mret, ty_res = + match get_desc (expand_head env ty_expected') with + Tarrow((Nolabel,marg,mret),ty_arg,ty_res,_) -> + marg, ty_arg, mret, ty_res + | _ -> assert false + in unify_exp env {texp with exp_type = ty_fun} ty_expected; if args = [] then texp else begin (* In this case, we're allocating a new closure, so [sarg] needs @@ -5371,35 +5783,80 @@ and type_argument ?explanation ?recarg env (mode : expected_mode) sarg func let_var) } end end - | _ -> + | None -> + let mode = expect_mode_cross env ty_expected' mode in let texp = type_expect ?recarg env mode sarg (mk_expected ?explanation ty_expected') in unify_exp env texp ty_expected; texp -and type_apply_arg env ~funct ~index ~position ~partial_app (lbl, arg) = +and type_apply_arg env ~app_loc ~funct ~index ~position ~partial_app (lbl, arg) = match arg with - | Arg (Unknown_arg { sarg; ty_arg; mode_arg }) -> + | Arg (Unknown_arg { sarg; ty_arg_mono; mode_arg }) -> let mode, _ = Alloc_mode.newvar_below mode_arg in let expected_mode = mode_argument ~funct ~index ~position ~partial_app mode in - let arg = type_expect env expected_mode sarg (mk_expected ty_arg) in + let arg = + type_expect env expected_mode sarg (mk_expected ty_arg_mono) + in if is_optional lbl then unify_exp env arg (type_option(newvar())); (lbl, Arg arg) - | Arg (Known_arg { sarg; ty_arg; ty_arg0; mode_arg; wrapped_in_some }) -> + | Arg (Known_arg { sarg; ty_arg; ty_arg0; + mode_arg; wrapped_in_some }) -> let mode, _ = Alloc_mode.newvar_below mode_arg in let expected_mode = mode_argument ~funct ~index ~position ~partial_app mode in + let ty_arg', vars = tpoly_get_poly ty_arg in let arg = - if wrapped_in_some then - option_some env - (type_argument env (mode_subcomponent expected_mode) sarg - (extract_option_type env ty_arg) - (extract_option_type env ty_arg0)) - expected_mode.mode - else - type_argument env expected_mode sarg ty_arg ty_arg0 + if vars = [] then begin + let ty_arg0' = tpoly_get_mono ty_arg0 in + if wrapped_in_some then begin + option_some env + (type_argument env (mode_subcomponent expected_mode) sarg + (extract_option_type env ty_arg') + (extract_option_type env ty_arg0')) + expected_mode.mode + end else begin + type_argument env expected_mode sarg ty_arg' ty_arg0' + end + end else begin + if !Clflags.principal + && get_level ty_arg < Btype.generic_level then begin + let snap = Btype.snapshot () in + let really_poly = + try + unify env (newmono (newvar ())) ty_arg; + false + with Unify _ -> true + in + Btype.backtrack snap; + if really_poly then + Location.prerr_warning app_loc + (Warnings.Not_principal "applying a higher-rank function here"); + end; + begin_def (); + let separate = + !Clflags.principal || Env.has_local_constraints env + in + if separate then begin_def (); + let vars, ty_arg' = instance_poly false vars ty_arg' in + if separate then begin + end_def (); + generalize_structure ty_arg'; + end; + let (ty_arg0', vars0) = tpoly_get_poly ty_arg0 in + let vars0, ty_arg0' = instance_poly false vars0 ty_arg0' in + List.iter2 (fun ty ty' -> unify_var env ty ty') vars vars0; + let arg = + type_argument env expected_mode sarg ty_arg' ty_arg0' + in + end_def (); + if maybe_expansive arg then + lower_contravariant env arg.exp_type; + generalize_and_check_univars env "argument" arg ty_arg vars; + {arg with exp_type = instance arg.exp_type} + end in (lbl, Arg arg) | Arg (Eliminated_optional_arg { ty_arg; _ }) -> @@ -5410,25 +5867,31 @@ and type_apply_arg env ~funct ~index ~position ~partial_app (lbl, arg) = (lbl, Arg arg) | Omitted _ as arg -> (lbl, arg) -and type_application env app_loc expected_mode position funct funct_mode sargs = +and type_application env app_loc expected_mode position funct funct_mode sargs ret_tvar = let is_ignore funct = is_prim ~name:"%ignore" funct && - (try ignore (filter_arrow env (instance funct.exp_type) Nolabel); true - with Unify _ -> false) + (try ignore (filter_arrow_mono env (instance funct.exp_type) Nolabel); true + with Filter_arrow_mono_failed -> false) in match sargs with | (* Special case for ignore: avoid discarding warning *) [Nolabel, sarg] when is_ignore funct -> + if !Clflags.principal then begin_def () ; let marg, ty_arg, mres, ty_res = - filter_arrow env (instance funct.exp_type) Nolabel + filter_arrow_mono env (instance funct.exp_type) Nolabel in + if !Clflags.principal then begin + end_def (); + generalize_structure ty_res + end; + let mode = mode_cross env ty_res (Value_mode.of_alloc mres) in submode ~loc:app_loc ~env - (Value_mode.of_alloc mres) expected_mode; + mode expected_mode; let marg = mode_argument ~funct ~index:0 ~position ~partial_app:false marg in let exp = type_expect env marg sarg (mk_expected ty_arg) in - check_partial_application false exp; + check_partial_application ~statement:false exp; ([Nolabel, Arg exp], ty_res, position) | _ -> let ty = funct.exp_type in @@ -5449,36 +5912,43 @@ and type_application env app_loc expected_mode position funct funct_mode sargs = true) end in + if !Clflags.principal then begin_def () ; let ty_ret, mode_ret, args = collect_apply_args env funct ignore_labels ty (instance ty) - (Value_mode.regional_to_local_alloc funct_mode) sargs + (Value_mode.regional_to_local_alloc funct_mode) sargs ret_tvar in let partial_app = is_partial_apply args in let position = if partial_app then Default else position in let args = List.mapi (fun index arg -> - type_apply_arg env ~funct ~index ~position ~partial_app arg) + type_apply_arg env ~app_loc ~funct ~index ~position ~partial_app arg) args in let ty_ret, mode_ret, args = type_omitted_parameters expected_mode env ty_ret mode_ret args in - submode ~loc:app_loc ~env - (Value_mode.of_alloc mode_ret) expected_mode; + if !Clflags.principal then begin + end_def () ; + generalize_structure ty_ret + end; + let mode = mode_cross env ty_ret (Value_mode.of_alloc mode_ret) in + submode ~loc:app_loc ~env mode expected_mode; args, ty_ret, position and type_construct env (expected_mode : expected_mode) loc lid sarg ty_expected_explained attrs = let { ty = ty_expected; explanation } = ty_expected_explained in let expected_type = - try - let (p0, p,_) = extract_concrete_variant env ty_expected in - let principal = - (repr ty_expected).level = generic_level || not !Clflags.principal - in - Some(p0, p, principal) - with Not_found -> None + match extract_concrete_variant env ty_expected with + | Variant_type(p0, p,_) -> + Some(p0, p, is_principal ty_expected) + | Maybe_a_variant_type -> None + | Not_a_variant_type -> + let srt = wrong_kind_sort_of_constructor lid.txt in + let ctx = Expression explanation in + let error = Wrong_expected_kind(srt, ctx, ty_expected) in + raise (Error (loc, env, error)) in let constrs = Env.lookup_all_constructors ~loc:lid.loc Env.Positive lid.txt env @@ -5500,7 +5970,7 @@ and type_construct env (expected_mode : expected_mode) loc lid sarg (lid.txt, constr.cstr_arity, List.length sargs))); let separate = !Clflags.principal || Env.has_local_constraints env in if separate then (begin_def (); begin_def ()); - let (ty_args, ty_res) = instance_constructor constr in + let (ty_args, ty_res, _) = instance_constructor constr in let texp = re { exp_desc = Texp_construct(lid, constr, []); @@ -5516,11 +5986,11 @@ and type_construct env (expected_mode : expected_mode) loc lid sarg unify_exp env {texp with exp_type = instance ty_res} (instance ty_expected)); end_def (); - List.iter generalize_structure ty_args; + List.iter (fun (arg, _) -> generalize_structure arg) ty_args; generalize_structure ty_res; end; let ty_args0, ty_res = - match instance_list (ty_res :: ty_args) with + match instance_list (ty_res :: (List.map fst ty_args)) with t :: tl -> tl, t | _ -> assert false in @@ -5551,7 +6021,17 @@ and type_construct env (expected_mode : expected_mode) loc lid sarg in let args = List.map2 - (fun e (t,t0) -> type_argument ~recarg env argument_mode e t t0) + (fun e ((ty, gf),t0) -> + let argument_mode = + match gf with + | Global -> + mode_global + | Nonlocal -> + mode_nonlocal argument_mode + | Unrestricted -> + argument_mode + in + type_argument ~recarg env argument_mode e ty t0) sargs (List.combine ty_args ty_args0) in if constr.cstr_private = Private then @@ -5572,7 +6052,7 @@ and type_statement ?explanation env sexp = let exp = type_exp env (mode_var ()) sexp in end_def(); let ty = expand_head env exp.exp_type and tv = newvar() in - if is_Tvar ty && ty.level > tv.level then + if is_Tvar ty && get_level ty > get_level tv then Location.prerr_warning (final_subexpression exp).exp_loc Warnings.Nonreturning_statement; @@ -5582,27 +6062,29 @@ and type_statement ?explanation env sexp = unify_exp env exp expected_ty); exp else begin - check_partial_application true exp; + check_partial_application ~statement:true exp; unify_var env tv ty; exp end -and type_unpacks ?in_function env (expected_mode : expected_mode) unpacks - sbody expected_ty = +and type_unpacks ?(in_function : (Location.t * type_expr * bool) option) + env (expected_mode : expected_mode) (unpacks : to_unpack list) sbody expected_ty = + if unpacks = [] then type_expect ?in_function env expected_mode sbody expected_ty else let ty = newvar() in (* remember original level *) let extended_env, tunpacks = - List.fold_left (fun (env, unpacks) (name, loc, uid) -> + List.fold_left (fun (env, tunpacks) unpack -> begin_def (); let context = Typetexp.narrow () in - let modl = + let modl, md_shape = !type_module env Ast_helper.( - Mod.unpack ~loc - (Exp.ident ~loc:name.loc (mkloc (Longident.Lident name.txt) - name.loc))) + Mod.unpack ~loc:unpack.tu_loc + (Exp.ident ~loc:unpack.tu_name.loc + (mkloc (Longident.Lident unpack.tu_name.txt) + unpack.tu_name.loc))) in - Mtype.lower_nongen ty.level modl.mod_type; + Mtype.lower_nongen (get_level ty) modl.mod_type; let pres = match modl.mod_type with | Mty_alias _ -> Mp_absent @@ -5610,14 +6092,16 @@ and type_unpacks ?in_function env (expected_mode : expected_mode) unpacks in let scope = create_scope () in let md = - { md_type = modl.mod_type; md_attributes = []; md_loc = name.loc; - md_uid = uid; } + { md_type = modl.mod_type; md_attributes = []; + md_loc = unpack.tu_name.loc; + md_uid = unpack.tu_uid; } in let (id, env) = - Env.enter_module_declaration ~scope name.txt pres md env + Env.enter_module_declaration ~scope ~shape:md_shape + unpack.tu_name.txt pres md env in Typetexp.widen context; - env, (id, name, pres, modl) :: unpacks + env, (id, unpack.tu_name, pres, modl) :: tunpacks ) (env, []) unpacks in (* ideally, we should catch Expr_type_clash errors @@ -5646,10 +6130,9 @@ and type_unpacks ?in_function env (expected_mode : expected_mode) unpacks (* Typing of match cases *) and type_cases - : type k . k pattern_category - -> ?in_function:_ -> _ -> _ -> _ -> _ -> _ -> _ -> _ - -> Parsetree.case list - -> k case list * partial + : type k . k pattern_category -> + ?in_function:_ -> _ -> _ -> _ -> _ -> _ -> _ -> _ -> Parsetree.case list -> + k case list * partial = fun category ?in_function env pmode emode ty_arg ty_res_explained partial_flag loc caselist -> (* ty_arg is _fully_ generalized *) @@ -5771,7 +6254,8 @@ and type_cases in let unpacks = List.map (fun (name, loc) -> - name, loc, Uid.mk ~current_unit:(Env.get_unit_name ()) + {tu_name = name; tu_loc = loc; + tu_uid = Uid.mk ~current_unit:(Env.get_unit_name ())} ) unpacks in let ty_res' = @@ -5927,22 +6411,28 @@ and type_let in attrs, pat_mode, exp_mode, spat) spat_sexp_list in + let is_recursive = (rec_flag = Recursive) in let nvs = List.map (fun _ -> newvar ()) spatl in + if is_recursive then begin_def (); let (pat_list, new_env, force, pvs, unpacks) = type_pattern_list Value existential_context env spatl nvs allow in + if is_recursive then begin + end_def (); + iter_pattern_variables_type generalize pvs + end; let attrs_list = List.map (fun (attrs, _, _, _) -> attrs) spatl in - let is_recursive = (rec_flag = Recursive) in (* If recursive, first unify with an approximation of the expression *) if is_recursive then List.iter2 (fun (_, pat) binding -> let pat = - match pat.pat_type.desc with + match get_desc pat.pat_type with | Tpoly (ty, tl) -> {pat with pat_type = snd (instance_poly ~keep_names:true false tl ty)} | _ -> pat - in unify_pat (ref env) pat (type_approx env binding.pvb_expr)) + in + type_approx env binding.pvb_expr pat.pat_type) pat_list spat_sexp_list; (* Polymorphic variant processing *) List.iter @@ -5958,11 +6448,13 @@ and type_let end_def (); iter_pattern_variables_type generalize_structure pvs; List.map (fun (m, pat) -> - generalize_structure pat.pat_type; - m, {pat with pat_type = instance pat.pat_type} + let ty = pat.pat_type in + generalize_structure ty; + m, {pat with pat_type = instance ty}, ty ) pat_list - end else - pat_list + end else begin + List.map (fun (m, pat) -> (m, pat, pat.pat_type)) pat_list + end in (* Only bind pattern variables after generalizing *) List.iter (fun f -> f()) force; @@ -5996,7 +6488,7 @@ and type_let || (is_recursive && (Warnings.is_active Warnings.Unused_rec_flag)))) attrs_list in - let mode_pat_slot_list = + let mode_typ_slot_list = (* Algorithm to detect unused declarations in recursive bindings: - During type checking of the definitions, we capture the 'value_used' events on the bound identifiers and record them in a slot corresponding @@ -6014,9 +6506,9 @@ and type_let warning is 26, not 27. *) List.map2 - (fun attrs (mode, pat) -> + (fun attrs (mode, pat, expected_ty) -> Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> - if not warn_about_unused_bindings then mode, pat, None + if not warn_about_unused_bindings then mode, expected_ty, None else let some_used = ref false in (* has one of the identifier of this pattern been used? *) @@ -6048,16 +6540,16 @@ and type_let ) ) (Typedtree.pat_bound_idents pat); - mode, pat, Some slot + mode, expected_ty, Some slot )) attrs_list pat_list in let exp_list = List.map2 - (fun {pvb_expr=sexp; pvb_attributes; _} (mode, pat, slot) -> + (fun {pvb_expr=sexp; pvb_attributes; _} (mode, expected_ty, slot) -> if is_recursive then current_slot := slot; - match pat.pat_type.desc with + match get_desc expected_ty with | Tpoly (ty, tl) -> if !Clflags.principal then begin_def (); let vars, ty' = instance_poly ~keep_names:true true tl ty in @@ -6081,13 +6573,13 @@ and type_let Builtin_attributes.warning_scope pvb_attributes (fun () -> if rec_flag = Recursive then type_unpacks exp_env mode - unpacks sexp (mk_expected pat.pat_type) + unpacks sexp (mk_expected expected_ty) else type_expect exp_env mode - sexp (mk_expected pat.pat_type)) + sexp (mk_expected expected_ty)) in exp, None) - spat_sexp_list mode_pat_slot_list in + spat_sexp_list mode_typ_slot_list in current_slot := None; if is_recursive && not !rec_needed then begin let {pvb_pat; pvb_attributes} = List.hd spat_sexp_list in @@ -6098,7 +6590,7 @@ and type_let ) end; List.iter2 - (fun (_,pat) (attrs, exp) -> + (fun (_,pat,_) (attrs, exp) -> Builtin_attributes.warning_scope ~ppwarning:false attrs (fun () -> ignore(check_partial env pat.pat_type pat.pat_loc @@ -6110,13 +6602,13 @@ and type_let let pvs = List.map (fun pv -> { pv with pv_type = instance pv.pv_type}) pvs in end_def(); List.iter2 - (fun (_,pat) (exp, _) -> + (fun (_,pat,_) (exp, _) -> if maybe_expansive exp then lower_contravariant env pat.pat_type) pat_list exp_list; iter_pattern_variables_type generalize pvs; List.iter2 - (fun (_,pat) (exp, vars) -> + (fun (_,_,expected_ty) (exp, vars) -> match vars with | None -> (* We generalize expressions even if they are not bound to a variable @@ -6132,12 +6624,12 @@ and type_let | Some vars -> if maybe_expansive exp then lower_contravariant env exp.exp_type; - generalize_and_check_univars env "definition" exp pat.pat_type vars) + generalize_and_check_univars env "definition" exp expected_ty vars) pat_list exp_list; let l = List.combine pat_list exp_list in let l = List.map2 - (fun ((_,p), (e, _)) pvb -> + (fun ((_,p,_), (e, _)) pvb -> {vb_pat=p; vb_expr=e; vb_attributes=pvb.pvb_attributes; vb_loc=pvb.pvb_loc; }) @@ -6147,14 +6639,13 @@ and type_let List.iter (fun {vb_pat=pat} -> match pat.pat_desc with Tpat_var _ -> () - | Tpat_alias ({pat_desc=Tpat_any}, _, _) -> () | _ -> raise(Error(pat.pat_loc, env, Illegal_letrec_pat))) l; List.iter (function | {vb_pat = {pat_desc = Tpat_any; pat_extra; _}; vb_expr; _} -> if not (List.exists (function (Tpat_constraint _, _, _) -> true | _ -> false) pat_extra) then - check_partial_application false vb_expr + check_partial_application ~statement:false vb_expr | _ -> ()) l; (l, new_env, unpacks) @@ -6172,18 +6663,17 @@ and type_andops env sarg sands expected_ty = let ty_arg = newvar () in let ty_rest = newvar () in let ty_result = newvar() in + let arrow_desc = (Nolabel,Alloc_mode.global,Alloc_mode.global) in let ty_rest_fun = - newty (Tarrow((Nolabel,Alloc_mode.global,Alloc_mode.global), - ty_arg, ty_result, Cok)) + newty (Tarrow(arrow_desc, newmono ty_arg, ty_result, commu_ok)) in let ty_op = - newty (Tarrow((Nolabel,Alloc_mode.global,Alloc_mode.global), - ty_rest, ty_rest_fun, Cok)) + newty (Tarrow(arrow_desc, newmono ty_rest, ty_rest_fun, commu_ok)) in begin try unify env op_type ty_op - with Unify trace -> - raise(Error(sop.loc, env, Andop_type_clash(sop.txt, trace))) + with Unify err -> + raise(Error(sop.loc, env, Andop_type_clash(sop.txt, err))) end; if !Clflags.principal then begin end_def (); @@ -6197,8 +6687,8 @@ and type_andops env sarg sands expected_ty = in begin try unify env (instance ty_result) (instance expected_ty) - with Unify trace -> - raise(Error(loc, env, Bindings_type_clash(trace))) + with Unify err -> + raise(Error(loc, env, Bindings_type_clash(err))) end; let andop = { bop_op_name = sop; @@ -6373,7 +6863,7 @@ let longident = Printtyp.longident (* Returns the first diff of the trace *) let type_clash_of_trace trace = - Ctype.Unification_trace.(explain trace (fun ~prev:_ -> function + Errortrace.(explain trace (fun ~prev:_ -> function | Diff diff -> Some diff | _ -> None )) @@ -6405,20 +6895,17 @@ let report_literal_type_constraint expected_type const = | _, _ -> [] let report_literal_type_constraint const = function - | Some Unification_trace. - { expected = { t = { desc = Tconstr (typ, [], _) } } } -> - report_literal_type_constraint typ const - | Some _ | None -> [] + | Some tr -> + begin match get_desc Errortrace.(tr.expected.ty) with + Tconstr (typ, [], _) -> + report_literal_type_constraint typ const + | _ -> [] + end + | None -> [] let report_partial_application = function | Some tr -> begin - let ty = - match tr.Unification_trace.got.Unification_trace.expanded with - | None -> tr.Unification_trace.got.Unification_trace.t - | Some ty -> ty - in - let ty = repr ty in - match ty.desc with + match get_desc tr.Errortrace.got.Errortrace.expanded with | Tarrow _ -> [ Location.msg "@[Hint: This function application is partial,@ \ @@ -6487,10 +6974,10 @@ let report_type_expected_explanation_opt expl ppf = | None -> () | Some expl -> report_type_expected_explanation expl ppf -let report_unification_error ~loc ?sub env trace +let report_unification_error ~loc ?sub env err ?type_expected_explanation txt1 txt2 = Location.error_of_printer ~loc ?sub (fun ppf () -> - Printtyp.report_unification_error ppf env trace + Printtyp.report_unification_error ppf env err ?type_expected_explanation txt1 txt2 ) () @@ -6500,26 +6987,24 @@ let report_error ~loc env = function "@[The constructor %a@ expects %i argument(s),@ \ but is applied here to %i argument(s)@]" longident lid expected provided - | Label_mismatch(lid, trace) -> - report_unification_error ~loc env trace + | Label_mismatch(lid, err) -> + report_unification_error ~loc env err (function ppf -> fprintf ppf "The record field %a@ belongs to the type" longident lid) (function ppf -> fprintf ppf "but is mixed here with fields of type") - | Pattern_type_clash (trace, pat) -> - let diff = type_clash_of_trace trace in + | Pattern_type_clash (err, pat) -> + let diff = type_clash_of_trace err.trace in let sub = report_pattern_type_clash_hints pat diff in - Location.error_of_printer ~loc ~sub (fun ppf () -> - Printtyp.report_unification_error ppf env trace - (function ppf -> - fprintf ppf "This pattern matches values of type") - (function ppf -> - fprintf ppf "but a pattern was expected which matches values of \ - type"); - ) () - | Or_pattern_type_clash (id, trace) -> - report_unification_error ~loc env trace + report_unification_error ~loc ~sub env err + (function ppf -> + fprintf ppf "This pattern matches values of type") + (function ppf -> + fprintf ppf "but a pattern was expected which matches values of \ + type"); + | Or_pattern_type_clash (id, err) -> + report_unification_error ~loc env err (function ppf -> fprintf ppf "The variable %s on the left-hand side of this \ or-pattern has type" (Ident.name id)) @@ -6536,20 +7021,18 @@ let report_error ~loc env = function (Ident.name id); spellcheck_idents ppf id valid_idents ) () - | Expr_type_clash (trace, explanation, exp) -> - let diff = type_clash_of_trace trace in + | Expr_type_clash (err, explanation, exp) -> + let diff = type_clash_of_trace err.trace in let sub = report_expr_type_clash_hints exp diff in - Location.error_of_printer ~loc ~sub (fun ppf () -> - Printtyp.report_unification_error ppf env trace - ~type_expected_explanation: - (report_type_expected_explanation_opt explanation) - (function ppf -> - fprintf ppf "This expression has type") - (function ppf -> - fprintf ppf "but an expression was expected of type"); - ) () + report_unification_error ~loc ~sub env err + ~type_expected_explanation: + (report_type_expected_explanation_opt explanation) + (function ppf -> + fprintf ppf "This expression has type") + (function ppf -> + fprintf ppf "but an expression was expected of type"); | Apply_non_function typ -> - begin match (repr typ).desc with + begin match get_desc typ with Tarrow _ -> Location.errorf ~loc "@[@[<2>This function has type@ %a@]\ @@ -6600,7 +7083,7 @@ let report_error ~loc env = function end else begin fprintf ppf "@[@[<2>%s type@ %a%t@]@ \ - The %s %s does not belong to type %a@]" + There is no %s %s within type %a@]" eorp Printtyp.type_expr ty (report_type_expected_explanation_opt explanation) (Datatype_kind.label_name kind) @@ -6625,6 +7108,13 @@ let report_error ~loc env = function ) () | Invalid_format msg -> Location.errorf ~loc "%s" msg + | Not_an_object (ty, explanation) -> + Location.error_of_printer ~loc (fun ppf () -> + fprintf ppf "This expression is not an object;@ \ + it has type %a" + Printtyp.type_expr ty; + report_type_expected_explanation_opt explanation ppf + ) () | Undefined_method (ty, me, valid_methods) -> Location.error_of_printer ~loc (fun ppf () -> Printtyp.wrap_printing_env ~error:true env (fun () -> @@ -6636,7 +7126,7 @@ let report_error ~loc env = function | Some valid_methods -> spellcheck ppf me valid_methods end )) () - | Undefined_inherited_method (me, valid_methods) -> + | Undefined_self_method (me, valid_methods) -> Location.error_of_printer ~loc (fun ppf () -> fprintf ppf "This expression has no method %s" me; spellcheck ppf me valid_methods; @@ -6651,9 +7141,9 @@ let report_error ~loc env = function ) () | Instance_variable_not_mutable v -> Location.errorf ~loc "The instance variable %s is not mutable" v - | Not_subtype(tr1, tr2) -> + | Not_subtype err -> Location.error_of_printer ~loc (fun ppf () -> - Printtyp.report_subtyping_error ppf env tr1 "is not a subtype of" tr2 + Printtyp.Subtype.report_error ppf env err "is not a subtype of" ) () | Outside_class -> Location.errorf ~loc @@ -6662,14 +7152,14 @@ let report_error ~loc env = function Location.errorf ~loc "The instance variable %s is overridden several times" v - | Coercion_failure (ty, ty', trace, b) -> + | Coercion_failure (ty_exp, err, b) -> Location.error_of_printer ~loc (fun ppf () -> - Printtyp.report_unification_error ppf env trace + Printtyp.report_unification_error ppf env err (function ppf -> - let ty, ty' = Printtyp.prepare_expansion (ty, ty') in + let ty_exp = Printtyp.prepare_expansion ty_exp in fprintf ppf "This expression cannot be coerced to type@;<1 2>%a;@ \ it has type" - (Printtyp.type_expansion ty) ty') + (Printtyp.type_expansion Type) ty_exp) (function ppf -> fprintf ppf "but is here used with type"); if b then @@ -6678,30 +7168,35 @@ let report_error ~loc env = function "Hint: Consider using a fully explicit coercion" "of the form: `(foo : ty1 :> ty2)'." ) () - | Too_many_arguments (in_function, ty, explanation) -> - if in_function then begin - Location.errorf ~loc - "This function expects too many arguments,@ \ - it should have type@ %a%t" - Printtyp.type_expr ty - (report_type_expected_explanation_opt explanation) - end else begin - Location.errorf ~loc - "This expression should not be a function,@ \ - the expected type is@ %a%t" - Printtyp.type_expr ty - (report_type_expected_explanation_opt explanation) - end - | Abstract_wrong_label (l, ty, explanation) -> - let label_mark = function - | Nolabel -> "but its first argument is not labelled" - | l -> sprintf "but its first argument is labelled %s" - (prefixed_label_name l) in + | Not_a_function (ty, explanation) -> + Location.errorf ~loc + "This expression should not be a function,@ \ + the expected type is@ %a%t" + Printtyp.type_expr ty + (report_type_expected_explanation_opt explanation) + | Too_many_arguments (ty, explanation) -> Location.errorf ~loc - "@[@[<2>This function should have type@ %a%t@]@,%s@]" + "This function expects too many arguments,@ \ + it should have type@ %a%t" Printtyp.type_expr ty (report_type_expected_explanation_opt explanation) - (label_mark l) + | Abstract_wrong_label {got; expected; expected_type; explanation} -> + let label ~long = function + | Nolabel -> "unlabeled" + | l -> (if long then "labeled " else "") ^ prefixed_label_name l + in + let second_long = match got, expected with + | Nolabel, _ | _, Nolabel -> true + | _ -> false + in + Location.errorf ~loc + "@[@[<2>This function should have type@ %a%t@]@,\ + @[but its first argument is %s@ instead of %s%s@]@]" + Printtyp.type_expr expected_type + (report_type_expected_explanation_opt explanation) + (label ~long:true got) + (if second_long then "being " else "") + (label ~long:second_long expected) | Scoping_let_module(id, ty) -> Location.errorf ~loc "This `let module' expression has type@ %a@ \ @@ -6717,15 +7212,15 @@ let report_error ~loc env = function Location.errorf ~loc "Cannot use private constructor %s to create values of type %a" constr.cstr_name Printtyp.type_expr ty - | Not_a_variant_type lid -> + | Not_a_polymorphic_variant_type lid -> Location.errorf ~loc "The type %a@ is not a variant type" longident lid | Incoherent_label_order -> Location.errorf ~loc "This function is applied to arguments@ \ in an order different from other calls.@ \ This is only allowed when the real type is known." - | Less_general (kind, trace) -> - report_unification_error ~loc env trace + | Less_general (kind, err) -> + report_unification_error ~loc env err (fun ppf -> fprintf ppf "This %s has type" kind) (fun ppf -> fprintf ppf "which is less general than") | Modules_not_allowed -> @@ -6844,24 +7339,59 @@ let report_error ~loc env = function | Illegal_class_expr -> Location.errorf ~loc "This kind of recursive class expression is not allowed" - | Letop_type_clash(name, trace) -> - report_unification_error ~loc env trace + | Letop_type_clash(name, err) -> + report_unification_error ~loc env err (function ppf -> fprintf ppf "The operator %s has type" name) (function ppf -> fprintf ppf "but it was expected to have type") - | Andop_type_clash(name, trace) -> - report_unification_error ~loc env trace + | Andop_type_clash(name, err) -> + report_unification_error ~loc env err (function ppf -> fprintf ppf "The operator %s has type" name) (function ppf -> fprintf ppf "but it was expected to have type") - | Bindings_type_clash(trace) -> - report_unification_error ~loc env trace + | Bindings_type_clash(err) -> + report_unification_error ~loc env err (function ppf -> fprintf ppf "These bindings have type") (function ppf -> fprintf ppf "but bindings were expected of type") + | Unbound_existential (ids, ty) -> + Location.errorf ~loc + "@[<2>%s:@ @[type %s.@ %a@]@]" + "This type does not bind all existentials in the constructor" + (String.concat " " (List.map Ident.name ids)) + Printtyp.type_expr ty + | Missing_type_constraint -> + Location.errorf ~loc + "@[%s@ %s@]" + "Existential types introduced in a constructor pattern" + "must be bound by a type constraint on the argument." + | Wrong_expected_kind(sort, ctx, ty) -> + let ctx, explanation = + match ctx with + | Expression explanation -> "expression", explanation + | Pattern -> "pattern", None + in + let sort = + match sort with + | Constructor -> "constructor" + | Boolean -> "boolean literal" + | List -> "list literal" + | Unit -> "unit literal" + | Record -> "record" + in + Location.errorf ~loc + "This %s should not be a %s,@ \ + the expected type is@ %a%t" + ctx sort Printtyp.type_expr ty + (report_type_expected_explanation_opt explanation) + | Expr_not_a_record_type ty -> + Location.errorf ~loc + "This expression has type %a@ \ + which is not a record type." + Printtyp.type_expr ty | Local_value_escapes(reason, context) -> let sub = escaping_hint reason context in let mode = @@ -6888,6 +7418,9 @@ let report_error ~loc env = function (match err with | `Conflict -> "is contradictory" | `Not_a_tailcall -> "is not on a tail call") + | Optional_poly_param -> + Location.errorf ~loc + "Optional parameters cannot be polymorphic" let report_error ~loc env err = Printtyp.wrap_printing_env ~error:true env diff --git a/ocaml/typing/typecore.mli b/ocaml/typing/typecore.mli index 4114543338f..908920fafc1 100644 --- a/ocaml/typing/typecore.mli +++ b/ocaml/typing/typecore.mli @@ -49,6 +49,17 @@ type type_expected = private { explanation: type_forcing_context option; } +(* Variables in patterns *) +type pattern_variable = + { + pv_id: Ident.t; + pv_mode: Value_mode.t; + pv_type: type_expr; + pv_loc: Location.t; + pv_as_var: bool; + pv_attributes: Typedtree.attributes; + } + val mk_expected: ?explanation:type_forcing_context -> type_expr -> @@ -69,6 +80,17 @@ type wrong_name = { valid_names: string list; } +type wrong_kind_context = + | Pattern + | Expression of type_forcing_context option + +type wrong_kind_sort = + | Constructor + | Record + | Boolean + | List + | Unit + type existential_restriction = | At_toplevel (** no existential types at the toplevel *) | In_group (** nor with [let ... and ...] *) @@ -94,12 +116,8 @@ val type_class_arg_pattern: (Ident.t * Ident.t * type_expr) list * Env.t * Env.t val type_self_pattern: - string -> type_expr -> Env.t -> Env.t -> Env.t -> Parsetree.pattern -> - Typedtree.pattern * - (Ident.t * type_expr) Meths.t ref * - (Ident.t * Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) - Vars.t ref * - Env.t * Env.t * Env.t + Env.t -> Parsetree.pattern -> + Typedtree.pattern * pattern_variable list val check_partial: ?lev:int -> Env.t -> type_expr -> Location.t -> Typedtree.value Typedtree.case list -> Typedtree.partial @@ -108,7 +126,7 @@ val type_expect: val type_exp: Env.t -> Parsetree.expression -> Typedtree.expression val type_approx: - Env.t -> Parsetree.expression -> type_expr + Env.t -> Parsetree.expression -> type_expr -> unit val type_argument: Env.t -> Parsetree.expression -> type_expr -> type_expr -> Typedtree.expression @@ -125,6 +143,8 @@ val force_delayed_checks: unit -> unit val reset_allocations: unit -> unit val optimise_allocations: unit -> unit +val has_poly_constraint : Parsetree.pattern -> bool + val name_pattern : string -> Typedtree.pattern list -> Ident.t val name_cases : string -> Typedtree.value Typedtree.case list -> Ident.t @@ -135,14 +155,15 @@ val self_coercion : (Path.t * Location.t list ref) list ref type error = | Constructor_arity_mismatch of Longident.t * int * int - | Label_mismatch of Longident.t * Ctype.Unification_trace.t + | Label_mismatch of Longident.t * Errortrace.unification_error | Pattern_type_clash : - Ctype.Unification_trace.t * _ Typedtree.pattern_desc option -> error - | Or_pattern_type_clash of Ident.t * Ctype.Unification_trace.t + Errortrace.unification_error * _ Typedtree.pattern_desc option + -> error + | Or_pattern_type_clash of Ident.t * Errortrace.unification_error | Multiply_bound_variable of string | Orpat_vars of Ident.t * Ident.t list | Expr_type_clash of - Ctype.Unification_trace.t * type_forcing_context option + Errortrace.unification_error * type_forcing_context option * Typedtree.expression_desc option | Apply_non_function of type_expr | Apply_wrong_label of arg_label * type_expr * bool @@ -153,25 +174,32 @@ type error = | Name_type_mismatch of Datatype_kind.t * Longident.t * (Path.t * Path.t) * (Path.t * Path.t) list | Invalid_format of string + | Not_an_object of type_expr * type_forcing_context option | Undefined_method of type_expr * string * string list option - | Undefined_inherited_method of string * string list + | Undefined_self_method of string * string list | Virtual_class of Longident.t | Private_type of type_expr | Private_label of Longident.t * type_expr | Private_constructor of constructor_description * type_expr | Unbound_instance_variable of string * string list | Instance_variable_not_mutable of string - | Not_subtype of Ctype.Unification_trace.t * Ctype.Unification_trace.t + | Not_subtype of Errortrace.Subtype.error | Outside_class | Value_multiply_overridden of string | Coercion_failure of - type_expr * type_expr * Ctype.Unification_trace.t * bool - | Too_many_arguments of bool * type_expr * type_forcing_context option - | Abstract_wrong_label of arg_label * type_expr * type_forcing_context option + Errortrace.expanded_type * Errortrace.unification_error * bool + | Not_a_function of type_expr * type_forcing_context option + | Too_many_arguments of type_expr * type_forcing_context option + | Abstract_wrong_label of + { got : arg_label + ; expected : arg_label + ; expected_type : type_expr + ; explanation : type_forcing_context option + } | Scoping_let_module of string * type_expr - | Not_a_variant_type of Longident.t + | Not_a_polymorphic_variant_type of Longident.t | Incoherent_label_order - | Less_general of string * Ctype.Unification_trace.t + | Less_general of string * Errortrace.unification_error | Modules_not_allowed | Cannot_infer_signature | Not_a_packed_module of type_expr @@ -198,15 +226,19 @@ type error = | Illegal_letrec_pat | Illegal_letrec_expr | Illegal_class_expr - | Letop_type_clash of string * Ctype.Unification_trace.t - | Andop_type_clash of string * Ctype.Unification_trace.t - | Bindings_type_clash of Ctype.Unification_trace.t - | Local_value_escapes of Btype.Value_mode.error * Env.escaping_context option + | Letop_type_clash of string * Errortrace.unification_error + | Andop_type_clash of string * Errortrace.unification_error + | Bindings_type_clash of Errortrace.unification_error + | Unbound_existential of Ident.t list * type_expr + | Missing_type_constraint + | Wrong_expected_kind of wrong_kind_sort * wrong_kind_context * type_expr + | Expr_not_a_record_type of type_expr + | Local_value_escapes of Value_mode.error * Env.escaping_context option | Param_mode_mismatch of type_expr | Uncurried_function_escapes | Local_return_annotation_mismatch of Location.t | Bad_tail_annotation of [`Conflict|`Not_a_tailcall] - + | Optional_poly_param exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -215,7 +247,8 @@ val report_error: loc:Location.t -> Env.t -> error -> Location.error (** @deprecated. Use {!Location.error_of_exn}, {!Location.print_report}. *) (* Forward declaration, to be filled in by Typemod.type_module *) -val type_module: (Env.t -> Parsetree.module_expr -> Typedtree.module_expr) ref +val type_module: + (Env.t -> Parsetree.module_expr -> Typedtree.module_expr * Shape.t) ref (* Forward declaration, to be filled in by Typemod.type_open *) val type_open: (?used_slot:bool ref -> override_flag -> Env.t -> Location.t -> @@ -229,14 +262,10 @@ val type_open_decl: (* Forward declaration, to be filled in by Typeclass.class_structure *) val type_object: (Env.t -> Location.t -> Parsetree.class_structure -> - Typedtree.class_structure * Types.class_signature * string list) ref + Typedtree.class_structure * string list) ref val type_package: - (Env.t -> Parsetree.module_expr -> Path.t -> Longident.t list -> - Typedtree.module_expr * type_expr list) ref - -val create_package_type : Location.t -> Env.t -> - Longident.t * (Longident.t * Parsetree.core_type) list -> - Path.t * (Longident.t * Typedtree.core_type) list * Types.type_expr + (Env.t -> Parsetree.module_expr -> Path.t -> (Longident.t * type_expr) list -> + Typedtree.module_expr * (Longident.t * type_expr) list) ref val constant: Parsetree.constant -> (Asttypes.constant, error) result diff --git a/ocaml/typing/typedecl.ml b/ocaml/typing/typedecl.ml index 5aedcd51de7..d6fe6d624a2 100644 --- a/ocaml/typing/typedecl.ml +++ b/ocaml/typing/typedecl.ml @@ -33,10 +33,10 @@ type error = | Duplicate_label of string | Recursive_abbrev of string | Cycle_in_def of string * type_expr - | Definition_mismatch of type_expr * Includecore.type_mismatch option - | Constraint_failed of type_expr * type_expr - | Inconsistent_constraint of Env.t * Ctype.Unification_trace.t - | Type_clash of Env.t * Ctype.Unification_trace.t + | Definition_mismatch of type_expr * Env.t * Includecore.type_mismatch option + | Constraint_failed of Env.t * Errortrace.unification_error + | Inconsistent_constraint of Env.t * Errortrace.unification_error + | Type_clash of Env.t * Errortrace.unification_error | Non_regular of { definition: Path.t; used_as: type_expr; @@ -48,13 +48,13 @@ type error = | Unbound_type_var of type_expr * type_declaration | Cannot_extend_private_type of Path.t | Not_extensible_type of Path.t - | Extension_mismatch of Path.t * Includecore.type_mismatch - | Rebind_wrong_type of Longident.t * Env.t * Ctype.Unification_trace.t + | Extension_mismatch of Path.t * Env.t * Includecore.type_mismatch + | Rebind_wrong_type of + Longident.t * Env.t * Errortrace.unification_error | Rebind_mismatch of Longident.t * Path.t * Path.t | Rebind_private of Longident.t | Variance of Typedecl_variance.error | Unavailable_type_constructor of Path.t - | Bad_fixed_type of string | Unbound_type_var_ext of type_expr * extension_constructor | Val_in_structure | Multiple_native_repr_attributes @@ -65,23 +65,22 @@ type error = | Bad_unboxed_attribute of string | Boxed_and_unboxed | Nonrec_gadt + | Invalid_private_row_declaration of type_expr + | Local_not_enabled + | Global_and_nonlocal open Typedtree exception Error of Location.t * error -(* Note: do not factor the branches in the following pattern-matching: - the records must be constants for the compiler to do sharing on them. -*) let get_unboxed_from_attributes sdecl = let unboxed = Builtin_attributes.has_unboxed sdecl.ptype_attributes in let boxed = Builtin_attributes.has_boxed sdecl.ptype_attributes in - match boxed, unboxed, !Clflags.unboxed_types with - | true, true, _ -> raise (Error(sdecl.ptype_loc, Boxed_and_unboxed)) - | true, false, _ -> unboxed_false_default_false - | false, true, _ -> unboxed_true_default_false - | false, false, false -> unboxed_false_default_true - | false, false, true -> unboxed_true_default_true + match boxed, unboxed with + | true, true -> raise (Error(sdecl.ptype_loc, Boxed_and_unboxed)) + | true, false -> Some false + | false, true -> Some true + | false, false -> None (* Enter all declared types in the environment as abstract types *) @@ -121,7 +120,7 @@ let enter_type rec_flag env sdecl (id, uid) = type_loc = sdecl.ptype_loc; type_attributes = sdecl.ptype_attributes; type_immediate = Unknown; - type_unboxed = unboxed_false_default_false; + type_unboxed_default = false; type_uid = uid; } in @@ -134,18 +133,17 @@ let update_type temp_env env id loc = | Some ty -> let params = List.map (fun _ -> Ctype.newvar ()) decl.type_params in try Ctype.unify env (Ctype.newconstr path params) ty - with Ctype.Unify trace -> - raise (Error(loc, Type_clash (env, trace))) - -let get_unboxed_type_representation env ty = - match Typedecl_unboxed.get_unboxed_type_representation env ty with - | Typedecl_unboxed.This x -> Some x - | _ -> None + with Ctype.Unify err -> + raise (Error(loc, Type_clash (env, err))) (* Determine if a type's values are represented by floats at run-time. *) let is_float env ty = - match get_unboxed_type_representation env ty with - Some {desc = Tconstr(p, _, _); _} -> Path.same p Predef.path_float + match Typedecl_unboxed.get_unboxed_type_representation env ty with + Some ty' -> + begin match get_desc ty' with + Tconstr(p, _, _) -> Path.same p Predef.path_float + | _ -> false + end | _ -> false (* Determine if a type definition defines a fixed type. (PW) *) @@ -166,28 +164,38 @@ let is_fixed_type sd = sd.ptype_private = Private && has_row_var sty -(* Set the row variable in a fixed type *) -let set_fixed_row env loc p decl = +(* Set the row variable to a fixed type in a private row type declaration. + (e.g. [ type t = private [< `A | `B ] ] or [type u = private < .. > ]) + Require [is_fixed_type decl] as a precondition +*) +let set_private_row env loc p decl = let tm = match decl.type_manifest with None -> assert false | Some t -> Ctype.expand_head env t in let rv = - match tm.desc with + match get_desc tm with Tvariant row -> - let row = Btype.row_repr row in - tm.desc <- Tvariant {row with row_fixed = Some Fixed_private}; - if Btype.static_row row then Btype.newgenty Tnil - else row.row_more + let Row {fields; more; closed; name} = row_repr row in + set_type_desc tm + (Tvariant (create_row ~fields ~more ~closed ~name + ~fixed:(Some Fixed_private))); + if Btype.static_row row then + (* the syntax hinted at the existence of a row variable, + but there is in fact no row variable to make private, e.g. + [ type t = private [< `A > `A] ] *) + raise (Error(loc, Invalid_private_row_declaration tm)) + else more | Tobject (ty, _) -> - snd (Ctype.flatten_fields ty) - | _ -> - raise (Error (loc, Bad_fixed_type "is not an object or variant")) + let r = snd (Ctype.flatten_fields ty) in + if not (Btype.is_Tvar r) then + (* a syntactically open object was closed by a constraint *) + raise (Error(loc, Invalid_private_row_declaration tm)); + r + | _ -> assert false in - if not (Btype.is_Tvar rv) then - raise (Error (loc, Bad_fixed_type "has no row variable")); - rv.desc <- Tconstr (p, decl.type_params, ref Mnil) + set_type_desc rv (Tconstr (p, decl.type_params, ref Mnil)) (* Translate one type declaration *) @@ -200,7 +208,22 @@ let make_params env params = in List.map make_param params -let transl_labels env closed lbls = + +let transl_global_flags loc attrs = + let transl_global_flag loc (r : (bool,unit) result) = + match r with + | Ok b -> b + | Error () -> raise(Error(loc, Local_not_enabled)) + in + let global = transl_global_flag loc (Builtin_attributes.has_global attrs) in + let nonlocal = transl_global_flag loc (Builtin_attributes.has_nonlocal attrs) in + match global, nonlocal with + | true, true -> raise(Error(loc, Global_and_nonlocal)) + | true, false -> Types.Global + | false, true -> Types.Nonlocal + | false, false -> Types.Unrestricted + +let transl_labels env univars closed lbls = assert (lbls <> []); let all_labels = ref String.Set.empty in List.iter @@ -214,9 +237,14 @@ let transl_labels env closed lbls = Builtin_attributes.warning_scope attrs (fun () -> let arg = Ast_helper.Typ.force_poly arg in - let cty = transl_simple_type env closed Global arg in + let cty = transl_simple_type env ?univars closed Global arg in + let gbl = + match mut with + | Mutable -> Types.Global + | Immutable -> transl_global_flags loc attrs + in {ld_id = Ident.create_local name.txt; - ld_name = name; ld_mutable = mut; + ld_name = name; ld_mutable = mut; ld_global = gbl; ld_type = cty; ld_loc = loc; ld_attributes = attrs} ) in @@ -225,21 +253,10 @@ let transl_labels env closed lbls = List.map (fun ld -> let ty = ld.ld_type.ctyp_type in - let ty = match ty.desc with Tpoly(t,[]) -> t | _ -> ty in - let gbl = - match ld.ld_mutable with - | Mutable -> Types.Global - | Immutable -> - if Builtin_attributes.has_global ld.ld_attributes then - Types.Global - else if Builtin_attributes.has_nonlocal ld.ld_attributes then - Types.Nonlocal - else - Types.Unrestricted - in + let ty = match get_desc ty with Tpoly(t,[]) -> t | _ -> ty in {Types.ld_id = ld.ld_id; ld_mutable = ld.ld_mutable; - ld_global = gbl; + ld_global = ld.ld_global; ld_type = ty; ld_loc = ld.ld_loc; ld_attributes = ld.ld_attributes; @@ -249,21 +266,31 @@ let transl_labels env closed lbls = lbls in lbls, lbls' -let transl_constructor_arguments env closed = function +let transl_types_gf env univars closed tyl = + let mk arg = + let cty = transl_simple_type env ?univars closed Global arg in + let gf = transl_global_flags arg.ptyp_loc arg.ptyp_attributes in + (cty, gf) + in + let tyl_gfl = List.map mk tyl in + let tyl_gfl' = List.map (fun (cty, gf) -> cty.ctyp_type, gf) tyl_gfl in + tyl_gfl, tyl_gfl' + +let transl_constructor_arguments env univars closed = function | Pcstr_tuple l -> - let l = List.map (transl_simple_type env closed Global) l in - Types.Cstr_tuple (List.map (fun t -> t.ctyp_type) l), - Cstr_tuple l + let flds, flds' = transl_types_gf env univars closed l in + Types.Cstr_tuple flds', + Cstr_tuple flds | Pcstr_record l -> - let lbls, lbls' = transl_labels env closed l in + let lbls, lbls' = transl_labels env univars closed l in Types.Cstr_record lbls', Cstr_record lbls -let make_constructor env type_path type_params sargs sret_type = +let make_constructor env loc type_path type_params svars sargs sret_type = match sret_type with | None -> let args, targs = - transl_constructor_arguments env true sargs + transl_constructor_arguments env None true sargs in targs, None, args, None | Some sret_type -> @@ -271,17 +298,44 @@ let make_constructor env type_path type_params sargs sret_type = then widen so as to not introduce any new constraints *) let z = narrow () in reset_type_variables (); + let univars, closed = + match svars with + | [] -> None, false + | vs -> + Ctype.begin_def(); + Some (make_poly_univars (List.map (fun v -> v.txt) vs)), true + in let args, targs = - transl_constructor_arguments env false sargs + transl_constructor_arguments env univars closed sargs in - let tret_type = transl_simple_type env false Global sret_type in + let tret_type = transl_simple_type env ?univars closed Global sret_type in let ret_type = tret_type.ctyp_type in (* TODO add back type_path as a parameter ? *) - begin match (Ctype.repr ret_type).desc with + begin match get_desc ret_type with | Tconstr (p', _, _) when Path.same type_path p' -> () | _ -> - raise (Error (sret_type.ptyp_loc, Constraint_failed - (ret_type, Ctype.newconstr type_path type_params))) + let trace = + (* Expansion is not helpful here -- the restriction on GADT return + types is purely syntactic. (In the worst case, expansion + produces gibberish.) *) + [Ctype.unexpanded_diff + ~got:ret_type + ~expected:(Ctype.newconstr type_path type_params)] + in + raise (Error(sret_type.ptyp_loc, + Constraint_failed(env, + Errortrace.unification_error ~trace))) + end; + begin match univars with + | None -> () + | Some univars -> + Ctype.end_def(); + Btype.iter_type_expr_cstr_args Ctype.generalize args; + Ctype.generalize ret_type; + let _vars = instance_poly_univars env loc univars in + let set_level t = Ctype.unify_var env (Ctype.newvar()) t in + Btype.iter_type_expr_cstr_args set_level args; + set_level ret_type; end; widen z; targs, Some tret_type, args, Some ret_type @@ -298,8 +352,10 @@ let transl_declaration env sdecl (id, uid) = transl_simple_type env false Global sty', loc) sdecl.ptype_cstrs in - let raw_status = get_unboxed_from_attributes sdecl in - if raw_status.unboxed && not raw_status.default then begin + let unboxed_attr = get_unboxed_from_attributes sdecl in + begin match unboxed_attr with + | (None | Some false) -> () + | Some true -> let bad msg = raise(Error(sdecl.ptype_loc, Bad_unboxed_attribute msg)) in match sdecl.ptype_kind with | Ptype_abstract -> bad "it is abstract" @@ -331,14 +387,15 @@ let transl_declaration env sdecl (id, uid) = end end end; - let unboxed_status = + let unbox, unboxed_default = match sdecl.ptype_kind with | Ptype_variant [{pcd_args = Pcstr_tuple [_]; _}] | Ptype_variant [{pcd_args = Pcstr_record [{pld_mutable=Immutable; _}]; _}] - | Ptype_record [{pld_mutable=Immutable; _}] -> raw_status - | _ -> unboxed_false_default_false (* Not unboxable, mark as boxed *) + | Ptype_record [{pld_mutable=Immutable; _}] -> + Option.value unboxed_attr ~default:!Clflags.unboxed_types, + Option.is_none unboxed_attr + | _ -> false, false (* Not unboxable, mark as boxed *) in - let unbox = unboxed_status.unboxed in let (tkind, kind) = match sdecl.ptype_kind with | Ptype_abstract -> Ttype_abstract, Type_abstract @@ -363,12 +420,13 @@ let transl_declaration env sdecl (id, uid) = let make_cstr scstr = let name = Ident.create_local scstr.pcd_name.txt in let targs, tret_type, args, ret_type = - make_constructor env (Path.Pident id) params - scstr.pcd_args scstr.pcd_res + make_constructor env scstr.pcd_loc (Path.Pident id) params + scstr.pcd_vars scstr.pcd_args scstr.pcd_res in let tcstr = { cd_id = name; cd_name = scstr.pcd_name; + cd_vars = scstr.pcd_vars; cd_args = targs; cd_res = tret_type; cd_loc = scstr.pcd_loc; @@ -388,10 +446,11 @@ let transl_declaration env sdecl (id, uid) = Builtin_attributes.warning_scope scstr.pcd_attributes (fun () -> make_cstr scstr) in + let rep = if unbox then Variant_unboxed else Variant_regular in let tcstrs, cstrs = List.split (List.map make_cstr scstrs) in - Ttype_variant tcstrs, Type_variant cstrs + Ttype_variant tcstrs, Type_variant (cstrs, rep) | Ptype_record lbls -> - let lbls, lbls' = transl_labels env true lbls in + let lbls, lbls' = transl_labels env None true lbls in let rep = if unbox then Record_unboxed false else if List.for_all (fun l -> is_float env l.Types.ld_type) lbls' @@ -422,7 +481,7 @@ let transl_declaration env sdecl (id, uid) = type_loc = sdecl.ptype_loc; type_attributes = sdecl.ptype_attributes; type_immediate = Unknown; - type_unboxed = unboxed_status; + type_unboxed_default = unboxed_default; type_uid = uid; } in @@ -431,8 +490,8 @@ let transl_declaration env sdecl (id, uid) = (fun (cty, cty', loc) -> let ty = cty.ctyp_type in let ty' = cty'.ctyp_type in - try Ctype.unify env ty ty' with Ctype.Unify tr -> - raise(Error(loc, Inconsistent_constraint (env, tr)))) + try Ctype.unify env ty ty' with Ctype.Unify err -> + raise(Error(loc, Inconsistent_constraint (env, err)))) cstrs; Ctype.end_def (); (* Add abstract row *) @@ -442,13 +501,7 @@ let transl_declaration env sdecl (id, uid) = (Longident.Lident(Ident.name id ^ "#row")) env with Not_found -> assert false in - set_fixed_row env sdecl.ptype_loc p decl - end; - (* Check for cyclic abbreviations *) - begin match decl.type_manifest with None -> () - | Some ty -> - if Ctype.cyclic_abbrev env id ty then - raise(Error(sdecl.ptype_loc, Recursive_abbrev sdecl.ptype_name.txt)); + set_private_row env sdecl.ptype_loc p decl end; { typ_id = id; @@ -479,19 +532,24 @@ module TypeSet = Btype.TypeSet module TypeMap = Btype.TypeMap let rec check_constraints_rec env loc visited ty = - let ty = Ctype.repr ty in if TypeSet.mem ty !visited then () else begin visited := TypeSet.add ty !visited; - match ty.desc with + match get_desc ty with | Tconstr (path, args, _) -> - let args' = List.map (fun _ -> Ctype.newvar ()) args in - let ty' = Ctype.newconstr path args' in - begin try Ctype.enforce_constraints env ty' - with Ctype.Unify _ -> assert false - | Not_found -> raise (Error(loc, Unavailable_type_constructor path)) + let decl = + try Env.find_type path env + with Not_found -> + raise (Error(loc, Unavailable_type_constructor path)) in + let ty' = Ctype.newconstr path (Ctype.instance_list decl.type_params) in + begin + (* We don't expand the error trace because that produces types that + *already* violate the constraints -- we need to report a problem with + the unexpanded types, or we get errors that talk about the same type + twice. This is generally true for constraint errors. *) + try Ctype.matches ~expand_error_trace:false env ty ty' + with Ctype.Matches_failure (env, err) -> + raise (Error(loc, Constraint_failed (env, err))) end; - if not (Ctype.matches env ty ty') then - raise (Error(loc, Constraint_failed (ty, ty'))); List.iter (check_constraints_rec env loc visited) args | Tpoly (ty, tl) -> let _, ty = Ctype.instance_poly false tl ty in @@ -519,7 +577,7 @@ let check_constraints env sdecl (_, decl) = sdecl.ptype_params decl.type_params; begin match decl.type_kind with | Type_abstract -> () - | Type_variant l -> + | Type_variant (l, _rep) -> let find_pl = function Ptype_variant pl -> pl | Ptype_record _ | Ptype_abstract | Ptype_open -> assert false @@ -539,7 +597,7 @@ let check_constraints env sdecl (_, decl) = begin match cd_args, pcd_args with | Cstr_tuple tyl, Pcstr_tuple styl -> List.iter2 - (fun sty ty -> + (fun sty (ty, _) -> check_constraints_rec env sty.ptyp_loc visited ty) styl tyl | Cstr_record tyl, Pcstr_record styl -> @@ -579,30 +637,33 @@ let check_coherence env loc dpath decl = match decl with { type_kind = (Type_variant _ | Type_record _| Type_open); type_manifest = Some ty } -> - begin match (Ctype.repr ty).desc with + begin match get_desc ty with Tconstr(path, args, _) -> begin try let decl' = Env.find_type path env in let err = if List.length args <> List.length decl.type_params then Some Includecore.Arity - else if not (Ctype.equal env false args decl.type_params) - then Some Includecore.Constraint - else - Includecore.type_declarations ~loc ~equality:true env - ~mark:true - (Path.last path) - decl' - dpath - (Subst.type_declaration - (Subst.add_type_path dpath path Subst.identity) decl) + else begin + match Ctype.equal env false args decl.type_params with + | exception Ctype.Equality err -> + Some (Includecore.Constraint err) + | () -> + Includecore.type_declarations ~loc ~equality:true env + ~mark:true + (Path.last path) + decl' + dpath + (Subst.type_declaration + (Subst.add_type_path dpath path Subst.identity) decl) + end in if err <> None then - raise(Error(loc, Definition_mismatch (ty, err))) + raise(Error(loc, Definition_mismatch (ty, env, err))) with Not_found -> raise(Error(loc, Unavailable_type_constructor path)) end - | _ -> raise(Error(loc, Definition_mismatch (ty, None))) + | _ -> raise(Error(loc, Definition_mismatch (ty, env, None))) end | _ -> () @@ -614,10 +675,9 @@ let check_abbrev env sdecl (id, decl) = let check_well_founded env loc path to_check ty = let visited = ref TypeMap.empty in let rec check ty0 parents ty = - let ty = Btype.repr ty in if TypeSet.mem ty parents then begin (*Format.eprintf "@[%a@]@." Printtyp.raw_type_expr ty;*) - if match ty0.desc with + if match get_desc ty0 with | Tconstr (p, _, _) -> Path.same p path | _ -> false then raise (Error (loc, Recursive_abbrev (Path.name path))) @@ -633,7 +693,7 @@ let check_well_founded env loc path to_check ty = in if fini then () else let rec_ok = - match ty.desc with + match get_desc ty with Tconstr(p,_,_) -> !Clflags.recursive_types && Ctype.is_contractive env p | Tobject _ | Tvariant _ -> true @@ -650,7 +710,7 @@ let check_well_founded env loc path to_check ty = with e -> visited := visited'; Some e in - match ty.desc with + match get_desc ty with | Tconstr(p, _, _) when arg_exn <> None || to_check p -> if to_check p then Option.iter raise arg_exn else Btype.iter_type_expr (check ty0 TypeSet.empty) ty; @@ -665,7 +725,7 @@ let check_well_founded env loc path to_check ty = in let snap = Btype.snapshot () in try Ctype.wrap_trace_gadt_instances env (check ty TypeSet.empty) ty - with Ctype.Unify _ -> + with Ctype.Escape _ -> (* Will be detected by check_recursion *) Btype.backtrack snap @@ -689,16 +749,15 @@ let check_recursion ~orig_env env loc path decl to_check = if decl.type_params = [] then () else - let visited = ref [] in + let visited = ref TypeSet.empty in let rec check_regular cpath args prev_exp prev_expansions ty = - let ty = Ctype.repr ty in - if not (List.memq ty !visited) then begin - visited := ty :: !visited; - match ty.desc with + if not (TypeSet.mem ty !visited) then begin + visited := TypeSet.add ty !visited; + match get_desc ty with | Tconstr(path', args', _) -> if Path.same path path' then begin - if not (Ctype.equal orig_env false args args') then + if not (Ctype.is_equal orig_env false args args') then raise (Error(loc, Non_regular { definition=path; @@ -721,9 +780,8 @@ let check_recursion ~orig_env env loc path decl to_check = Ctype.instance_parameterized_type params0 body0 in begin try List.iter2 (Ctype.unify orig_env) params args' - with Ctype.Unify _ -> - raise (Error(loc, Constraint_failed - (ty, Ctype.newconstr path' params0))); + with Ctype.Unify err -> + raise (Error(loc, Constraint_failed (orig_env, err))); end; check_regular path' args (path' :: prev_exp) ((ty,body) :: prev_expansions) @@ -790,11 +848,10 @@ let name_recursion sdecl id decl = | { type_kind = Type_abstract; type_manifest = Some ty; type_private = Private; } when is_fixed_type sdecl -> - let ty = Ctype.repr ty in - let ty' = Btype.newty2 ty.level ty.desc in + let ty' = newty2 ~level:(get_level ty) (get_desc ty) in if Ctype.deep_occur ty ty' then let td = Tconstr(Path.Pident id, decl.type_params, ref Mnil) in - Btype.link_type ty (Btype.newty2 ty.level td); + link_type ty (newty2 ~level:(get_level ty) td); {decl with type_manifest = Some ty'} else decl | _ -> decl @@ -968,16 +1025,18 @@ let transl_extension_constructor ~scope env type_path type_params let id = Ident.create_scoped ~scope sext.pext_name.txt in let args, ret_type, kind = match sext.pext_kind with - Pext_decl(sargs, sret_type) -> + Pext_decl(svars, sargs, sret_type) -> let targs, tret_type, args, ret_type = - make_constructor env type_path typext_params - sargs sret_type + make_constructor env sext.pext_loc type_path typext_params + svars sargs sret_type in - args, ret_type, Text_decl(targs, tret_type) + args, ret_type, Text_decl(svars, targs, tret_type) | Pext_rebind lid -> - let usage = if priv = Public then Env.Positive else Env.Privatize in + let usage : Env.constructor_usage = + if priv = Public then Env.Exported else Env.Exported_private + in let cdescr = Env.lookup_constructor ~loc:lid.loc usage lid.txt env in - let (args, cstr_res) = Ctype.instance_constructor cdescr in + let (args, cstr_res, _ex) = Ctype.instance_constructor cdescr in let res, ret_type = if cdescr.cstr_generalized then let params = Ctype.instance_list type_params in @@ -989,29 +1048,25 @@ let transl_extension_constructor ~scope env type_path type_params begin try Ctype.unify env cstr_res res - with Ctype.Unify trace -> + with Ctype.Unify err -> raise (Error(lid.loc, - Rebind_wrong_type(lid.txt, env, trace))) + Rebind_wrong_type(lid.txt, env, err))) end; (* Remove "_" names from parameters used in the constructor *) if not cdescr.cstr_generalized then begin let vars = - Ctype.free_variables (Btype.newgenty (Ttuple args)) + Ctype.free_variables (Btype.newgenty (Ttuple (List.map fst args))) in - List.iter - (function {desc = Tvar (Some "_")} as ty -> - if List.memq ty vars then ty.desc <- Tvar None - | _ -> ()) - typext_params + List.iter + (fun ty -> + if get_desc ty = Tvar (Some "_") + && List.exists (eq_type ty) vars + then set_type_desc ty (Tvar None)) + typext_params end; (* Ensure that constructor's type matches the type being extended *) - let cstr_type_path, cstr_type_params = - match cdescr.cstr_res.desc with - Tconstr (p, _, _) -> - let decl = Env.find_type p env in - p, decl.type_params - | _ -> assert false - in + let cstr_type_path = Btype.cstr_type_path cdescr in + let cstr_type_params = (Env.find_type cstr_type_path env).type_params in let cstr_types = (Btype.newgenty (Tconstr(cstr_type_path, cstr_type_params, ref Mnil))) @@ -1022,7 +1077,7 @@ let transl_extension_constructor ~scope env type_path type_params (Tconstr(type_path, type_params, ref Mnil))) :: type_params in - if not (Ctype.equal env true cstr_types ext_types) then + if not (Ctype.is_equal env true cstr_types ext_types) then raise (Error(lid.loc, Rebind_mismatch(lid.txt, cstr_type_path, type_path))); (* Disallow rebinding private constructors to non-private *) @@ -1043,8 +1098,8 @@ let transl_extension_constructor ~scope env type_path type_params Types.Cstr_tuple args | Some decl -> let tl = - match args with - | [ {desc=Tconstr(_, tl, _)} ] -> tl + match List.map (fun (ty, _) -> get_desc ty) args with + | [ Tconstr(_, tl, _) ] -> tl | _ -> assert false in let decl = Ctype.instance_declaration decl in @@ -1136,7 +1191,7 @@ let transl_type_extension extend env loc styext = in begin match err with | None -> () - | Some err -> raise (Error(loc, Extension_mismatch (type_path, err))) + | Some err -> raise (Error(loc, Extension_mismatch (type_path, env, err))) end; let ttype_params = make_params env styext.ptyext_params in let type_params = List.map (fun (cty, _) -> cty.ctyp_type) ttype_params in @@ -1224,7 +1279,6 @@ let transl_exception env sext = ext, newenv let transl_type_exception env t = - Builtin_attributes.check_no_alert t.ptyexn_attributes; let contructor, newenv = Builtin_attributes.warning_scope t.ptyexn_attributes (fun () -> @@ -1255,7 +1309,7 @@ let get_native_repr_attribute attrs ~global_repr = raise (Error (loc, Multiple_native_repr_attributes)) let native_repr_of_type env kind ty = - match kind, (Ctype.expand_head_opt env ty).desc with + match kind, get_desc (Ctype.expand_head_opt env ty) with | Untagged, Tconstr (path, _, _) when Path.same path Predef.path_int -> Some Untagged_int | Unboxed, Tconstr (path, _, _) when Path.same path Predef.path_float -> @@ -1301,19 +1355,20 @@ let make_native_repr env core_type ty ~global_repr = end let prim_const_mode m = - match Btype.Alloc_mode.check_const m with + match Types.Alloc_mode.check_const m with | Some Global -> Prim_global | Some Local -> Prim_local | None -> assert false let rec parse_native_repr_attributes env core_type ty rmode ~global_repr = - match core_type.ptyp_desc, (Ctype.repr ty).desc, + match core_type.ptyp_desc, get_desc ty, get_native_repr_attribute core_type.ptyp_attributes ~global_repr:None with | Ptyp_arrow _, Tarrow _, Native_repr_attr_present kind -> raise (Error (core_type.ptyp_loc, Cannot_unbox_or_untag_type kind)) | Ptyp_arrow (_, ct1, ct2), Tarrow ((_,marg,mret), t1, t2, _), _ when not (Builtin_attributes.has_curry core_type.ptyp_attributes) -> + let t1, _ = Btype.tpoly_get_poly t1 in let repr_arg = make_native_repr env ct1 t1 ~global_repr in let mode = if Builtin_attributes.has_local_opt ct1.ptyp_attributes @@ -1324,6 +1379,8 @@ let rec parse_native_repr_attributes env core_type ty rmode ~global_repr = parse_native_repr_attributes env ct2 t2 (prim_const_mode mret) ~global_repr in ((mode,repr_arg) :: repr_args, repr_res) + | (Ptyp_poly (_, t) | Ptyp_alias (t, _)), _, _ -> + parse_native_repr_attributes env t ty rmode ~global_repr | _ -> let rmode = if Builtin_attributes.has_local_opt core_type.ptyp_attributes @@ -1334,14 +1391,15 @@ let rec parse_native_repr_attributes env core_type ty rmode ~global_repr = let check_unboxable env loc ty = - let check_type acc ty : Path.Set.t = - let ty = Ctype.repr (Ctype.expand_head_opt env ty) in - try match ty.desc with + let rec check_type acc ty : Path.Set.t = + let ty = Ctype.expand_head_opt env ty in + try match get_desc ty with | Tconstr (p, _, _) -> let tydecl = Env.find_type p env in - if tydecl.type_unboxed.default then + if tydecl.type_unboxed_default then Path.Set.add p acc else acc + | Tpoly (ty, []) -> check_type acc ty | _ -> acc with Not_found -> acc in @@ -1428,7 +1486,8 @@ let transl_value_decl env loc valdecl = In particular, note that [sig_env] is an extension of [outer_env]. *) -let transl_with_constraint id row_path ~sig_env ~sig_decl ~outer_env sdecl = +let transl_with_constraint id ?fixed_row_path ~sig_env ~sig_decl ~outer_env + sdecl = Env.mark_type_used sig_decl.type_uid; reset_type_variables(); Ctype.begin_def(); @@ -1468,16 +1527,16 @@ let transl_with_constraint id row_path ~sig_env ~sig_decl ~outer_env sdecl = if arity_ok then List.iter2 (fun (cty, _) tparam -> try Ctype.unify_var env cty.ctyp_type tparam - with Ctype.Unify tr -> - raise(Error(cty.ctyp_loc, Inconsistent_constraint (env, tr))) + with Ctype.Unify err -> + raise(Error(cty.ctyp_loc, Inconsistent_constraint (env, err))) ) tparams sig_decl.type_params; List.iter (fun (cty, cty', loc) -> (* Note: constraints must also be enforced in [sig_env] because they may contain parameter variables from [tparams] that have now be unified in [sig_env]. *) try Ctype.unify env cty.ctyp_type cty'.ctyp_type - with Ctype.Unify tr -> - raise(Error(loc, Inconsistent_constraint (env, tr))) + with Ctype.Unify err -> + raise(Error(loc, Inconsistent_constraint (env, err))) ) constraints; let priv = if sdecl.ptype_private = Private then Private else @@ -1487,11 +1546,11 @@ let transl_with_constraint id row_path ~sig_env ~sig_decl ~outer_env sdecl = if arity_ok && sig_decl.type_kind <> Type_abstract && sdecl.ptype_private = Private then Location.deprecated loc "spurious use of private"; - let type_kind, type_unboxed = + let type_kind, type_unboxed_default = if arity_ok && man <> None then - sig_decl.type_kind, sig_decl.type_unboxed + sig_decl.type_kind, sig_decl.type_unboxed_default else - Type_abstract, unboxed_false_default_false + Type_abstract, false in let new_sig_decl = { type_params = params; @@ -1506,13 +1565,12 @@ let transl_with_constraint id row_path ~sig_env ~sig_decl ~outer_env sdecl = type_loc = loc; type_attributes = sdecl.ptype_attributes; type_immediate = Unknown; - type_unboxed; + type_unboxed_default; type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } in - begin match row_path with None -> () - | Some p -> set_fixed_row env loc p new_sig_decl - end; + Option.iter (fun p -> set_private_row env sdecl.ptype_loc p new_sig_decl) + fixed_row_path; begin match Ctype.closed_type_decl new_sig_decl with None -> () | Some ty -> raise(Error(loc, Unbound_type_var(ty, new_sig_decl))) end; @@ -1541,7 +1599,7 @@ let transl_with_constraint id row_path ~sig_env ~sig_decl ~outer_env sdecl = type_kind = new_sig_decl.type_kind; type_private = new_sig_decl.type_private; type_manifest = new_sig_decl.type_manifest; - type_unboxed = new_sig_decl.type_unboxed; + type_unboxed_default = new_sig_decl.type_unboxed_default; type_is_newtype = new_sig_decl.type_is_newtype; type_expansion_scope = new_sig_decl.type_expansion_scope; type_loc = new_sig_decl.type_loc; @@ -1586,7 +1644,7 @@ let abstract_type_decl ~injective arity = type_loc = Location.none; type_attributes = []; type_immediate = Unknown; - type_unboxed = unboxed_false_default_false; + type_unboxed_default = false; type_uid = Uid.internal_not_actually_unique; } in Ctype.end_def(); @@ -1625,42 +1683,41 @@ let explain_unbound_gen ppf tv tl typ kwd pr = let ti = List.find (fun ti -> Ctype.deep_occur tv (typ ti)) tl in let ty0 = (* Hack to force aliasing when needed *) Btype.newgenty (Tobject(tv, ref None)) in - Printtyp.reset_and_mark_loops_list [typ ti; ty0]; + Printtyp.prepare_for_printing [typ ti; ty0]; fprintf ppf - ".@.@[In %s@ %a@;<1 -2>the variable %a is unbound@]" - kwd pr ti Printtyp.marked_type_expr tv + ".@ @[In %s@ %a@;<1 -2>the variable %a is unbound@]" + kwd pr ti Printtyp.prepared_type_expr tv with Not_found -> () let explain_unbound ppf tv tl typ kwd lab = explain_unbound_gen ppf tv tl typ kwd (fun ppf ti -> - fprintf ppf "%s%a" (lab ti) Printtyp.marked_type_expr (typ ti) + fprintf ppf "%s%a" (lab ti) Printtyp.prepared_type_expr (typ ti) ) let explain_unbound_single ppf tv ty = let trivial ty = explain_unbound ppf tv [ty] (fun t -> t) "type" (fun _ -> "") in - match (Ctype.repr ty).desc with + match get_desc ty with Tobject(fi,_) -> let (tl, rv) = Ctype.flatten_fields fi in - if rv == tv then trivial ty else + if eq_type rv tv then trivial ty else explain_unbound ppf tv tl (fun (_,_,t) -> t) "method" (fun (lab,_,_) -> lab ^ ": ") | Tvariant row -> - let row = Btype.row_repr row in - if row.row_more == tv then trivial ty else - explain_unbound ppf tv row.row_fields - (fun (_l,f) -> match Btype.row_field_repr f with + if eq_type (row_more row) tv then trivial ty else + explain_unbound ppf tv (row_fields row) + (fun (_l,f) -> match row_field_repr f with Rpresent (Some t) -> t - | Reither (_,[t],_,_) -> t - | Reither (_,tl,_,_) -> Btype.newgenty (Ttuple tl) + | Reither (_,[t],_) -> t + | Reither (_,tl,_) -> Btype.newgenty (Ttuple tl) | _ -> Btype.newgenty (Ttuple[])) "case" (fun (lab,_) -> "`" ^ lab ^ " of ") | _ -> trivial ty let tys_of_constr_args = function - | Types.Cstr_tuple tl -> tl + | Types.Cstr_tuple tl -> List.map fst tl | Types.Cstr_record lbls -> List.map (fun l -> l.Types.ld_type) lbls let report_error ppf = function @@ -1679,24 +1736,23 @@ let report_error ppf = function | Cycle_in_def (s, ty) -> fprintf ppf "@[The definition of %s contains a cycle:@ %a@]" s Printtyp.type_expr ty - | Definition_mismatch (ty, None) -> + | Definition_mismatch (ty, _env, None) -> fprintf ppf "@[@[%s@ %s@;<1 2>%a@]@]" "This variant or record definition" "does not match that of type" Printtyp.type_expr ty - | Definition_mismatch (ty, Some err) -> + | Definition_mismatch (ty, env, Some err) -> fprintf ppf "@[@[%s@ %s@;<1 2>%a@]%a@]" "This variant or record definition" "does not match that of type" Printtyp.type_expr ty - (Includecore.report_type_mismatch "the original" "this" "definition") + (Includecore.report_type_mismatch + "the original" "this" "definition" env) err - | Constraint_failed (ty, ty') -> - Printtyp.reset_and_mark_loops ty; - Printtyp.mark_loops ty'; - Printtyp.Naming_context.reset (); - fprintf ppf "@[%s@ @[Type@ %a@ should be an instance of@ %a@]@]" - "Constraints are not satisfied in this type." - !Oprint.out_type (Printtyp.tree_of_typexp false ty) - !Oprint.out_type (Printtyp.tree_of_typexp false ty') + | Constraint_failed (env, err) -> + fprintf ppf "@[Constraints are not satisfied in this type.@ "; + Printtyp.report_unification_error ppf env err + (fun ppf -> fprintf ppf "Type") + (fun ppf -> fprintf ppf "should be an instance of"); + fprintf ppf "@]" | Non_regular { definition; used_as; defined_as; expansions } -> let pp_expansion ppf (ty,body) = Format.fprintf ppf "%a = %a" @@ -1705,8 +1761,7 @@ let report_error ppf = function let comma ppf () = Format.fprintf ppf ",@;<1 2>" in let pp_expansions ppf expansions = Format.(pp_print_list ~pp_sep:comma pp_expansion) ppf expansions in - Printtyp.reset_and_mark_loops used_as; - Printtyp.mark_loops defined_as; + Printtyp.prepare_for_printing [used_as; defined_as]; Printtyp.Naming_context.reset (); begin match expansions with | [] -> @@ -1717,8 +1772,8 @@ let report_error ppf = function All uses need to match the definition for the recursive type \ to be regular.@]" (Path.name definition) - !Oprint.out_type (Printtyp.tree_of_typexp false defined_as) - !Oprint.out_type (Printtyp.tree_of_typexp false used_as) + !Oprint.out_type (Printtyp.tree_of_typexp Type defined_as) + !Oprint.out_type (Printtyp.tree_of_typexp Type used_as) | _ :: _ -> fprintf ppf "@[This recursive type is not regular.@ \ @@ -1728,17 +1783,18 @@ let report_error ppf = function All uses need to match the definition for the recursive type \ to be regular.@]" (Path.name definition) - !Oprint.out_type (Printtyp.tree_of_typexp false defined_as) - !Oprint.out_type (Printtyp.tree_of_typexp false used_as) + !Oprint.out_type (Printtyp.tree_of_typexp Type defined_as) + !Oprint.out_type (Printtyp.tree_of_typexp Type used_as) pp_expansions expansions end - | Inconsistent_constraint (env, trace) -> - fprintf ppf "The type constraints are not consistent.@."; - Printtyp.report_unification_error ppf env trace + | Inconsistent_constraint (env, err) -> + fprintf ppf "@[The type constraints are not consistent.@ "; + Printtyp.report_unification_error ppf env err (fun ppf -> fprintf ppf "Type") - (fun ppf -> fprintf ppf "is not compatible with type") - | Type_clash (env, trace) -> - Printtyp.report_unification_error ppf env trace + (fun ppf -> fprintf ppf "is not compatible with type"); + fprintf ppf "@]" + | Type_clash (env, err) -> + Printtyp.report_unification_error ppf env err (function ppf -> fprintf ppf "This type constructor expands to type") (function ppf -> @@ -1750,10 +1806,9 @@ let report_error ppf = function requires a second stub function@ \ for native-code compilation@]" | Unbound_type_var (ty, decl) -> - fprintf ppf "A type variable is unbound in this type declaration"; - let ty = Ctype.repr ty in + fprintf ppf "@[A type variable is unbound in this type declaration"; begin match decl.type_kind, decl.type_manifest with - | Type_variant tl, _ -> + | Type_variant (tl, _rep), _ -> explain_unbound_gen ppf ty tl (fun c -> let tl = tys_of_constr_args c.Types.cd_args in Btype.newgenty (Ttuple tl) @@ -1768,11 +1823,13 @@ let report_error ppf = function | Type_abstract, Some ty' -> explain_unbound_single ppf ty ty' | _ -> () - end + end; + fprintf ppf "@]" | Unbound_type_var_ext (ty, ext) -> - fprintf ppf "A type variable is unbound in this extension constructor"; + fprintf ppf "@[A type variable is unbound in this extension constructor"; let args = tys_of_constr_args ext.ext_args in - explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> "") + explain_unbound ppf ty args (fun c -> c) "type" (fun _ -> ""); + fprintf ppf "@]" | Cannot_extend_private_type path -> fprintf ppf "@[%s@ %a@]" "Cannot extend private type definition" @@ -1782,15 +1839,15 @@ let report_error ppf = function "Type definition" Printtyp.path path "is not extensible" - | Extension_mismatch (path, err) -> + | Extension_mismatch (path, env, err) -> fprintf ppf "@[@[%s@ %s@;<1 2>%s@]%a@]" "This extension" "does not match the definition of type" (Path.name path) (Includecore.report_type_mismatch - "the type" "this extension" "definition") + "the type" "this extension" "definition" env) err - | Rebind_wrong_type (lid, env, trace) -> - Printtyp.report_unification_error ppf env trace + | Rebind_wrong_type (lid, env, err) -> + Printtyp.report_unification_error ppf env err (function ppf -> fprintf ppf "The constructor %a@ has type" Printtyp.longident lid) @@ -1817,14 +1874,6 @@ let report_error ppf = function | false, true -> inj ^ "contravariant" | false, false -> if inj = "" then "unrestricted" else inj in - let suffix n = - let teen = (n mod 100)/10 = 1 in - match n mod 10 with - | 1 when not teen -> "st" - | 2 when not teen -> "nd" - | 3 when not teen -> "rd" - | _ -> "th" - in (match n with | Variance_not_reflected -> fprintf ppf "@[%s@ %s@ It" @@ -1842,7 +1891,7 @@ let report_error ppf = function fprintf ppf "@[%s@ %s@ The %d%s type parameter" "In this definition, expected parameter" "variances are not satisfied." - n (suffix n)); + n (Misc.ordinal_suffix n)); (match n with | No_variable -> () | _ -> @@ -1850,8 +1899,6 @@ let report_error ppf = function (variance v2) (variance v1)) | Unavailable_type_constructor p -> fprintf ppf "The definition of type %a@ is unavailable" Printtyp.path p - | Bad_fixed_type r -> - fprintf ppf "This fixed type %s" r | Variance Typedecl_variance.Varying_anonymous -> fprintf ppf "@[%s@ %s@ %s@]" "In this GADT definition," "the variance of some parameter" @@ -1900,6 +1947,19 @@ let report_error ppf = function | Nonrec_gadt -> fprintf ppf "@[GADT case syntax cannot be used in a 'nonrec' block.@]" + | Invalid_private_row_declaration ty -> + Format.fprintf ppf + "@[This private row type declaration is invalid.@ \ + The type expression on the right-hand side reduces to@;<1 2>%a@ \ + which does not have a free row type variable.@]@,\ + @[@[Hint: If you intended to define a private type abbreviation,@ \ + write explicitly@]@;<1 2>private %a@]" + Printtyp.type_expr ty Printtyp.type_expr ty + | Local_not_enabled -> + fprintf ppf "@[The local extension is disabled@ \ + To enable it, pass the '-extension local' flag@]" + | Global_and_nonlocal -> + fprintf ppf "@[A type cannot be both global and nonlocal@]" let () = Location.register_error_of_exn diff --git a/ocaml/typing/typedecl.mli b/ocaml/typing/typedecl.mli index fec0bd65b5a..9c3ea0ea53c 100644 --- a/ocaml/typing/typedecl.mli +++ b/ocaml/typing/typedecl.mli @@ -38,8 +38,10 @@ val transl_value_decl: Env.t -> Location.t -> Parsetree.value_description -> Typedtree.value_description * Env.t +(* If the [fixed_row_path] optional argument is provided, + the [Parsetree.type_declaration] argument should satisfy [is_fixed_type] *) val transl_with_constraint: - Ident.t -> Path.t option -> + Ident.t -> ?fixed_row_path:Path.t -> sig_env:Env.t -> sig_decl:Types.type_declaration -> outer_env:Env.t -> Parsetree.type_declaration -> Typedtree.type_declaration @@ -56,9 +58,6 @@ val check_coherence: (* for fixed types *) val is_fixed_type : Parsetree.type_declaration -> bool -(* for typeopt.ml *) -val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option - type native_repr_kind = Unboxed | Untagged type error = @@ -68,10 +67,10 @@ type error = | Duplicate_label of string | Recursive_abbrev of string | Cycle_in_def of string * type_expr - | Definition_mismatch of type_expr * Includecore.type_mismatch option - | Constraint_failed of type_expr * type_expr - | Inconsistent_constraint of Env.t * Ctype.Unification_trace.t - | Type_clash of Env.t * Ctype.Unification_trace.t + | Definition_mismatch of type_expr * Env.t * Includecore.type_mismatch option + | Constraint_failed of Env.t * Errortrace.unification_error + | Inconsistent_constraint of Env.t * Errortrace.unification_error + | Type_clash of Env.t * Errortrace.unification_error | Non_regular of { definition: Path.t; used_as: type_expr; @@ -83,13 +82,13 @@ type error = | Unbound_type_var of type_expr * type_declaration | Cannot_extend_private_type of Path.t | Not_extensible_type of Path.t - | Extension_mismatch of Path.t * Includecore.type_mismatch - | Rebind_wrong_type of Longident.t * Env.t * Ctype.Unification_trace.t + | Extension_mismatch of Path.t * Env.t * Includecore.type_mismatch + | Rebind_wrong_type of + Longident.t * Env.t * Errortrace.unification_error | Rebind_mismatch of Longident.t * Path.t * Path.t | Rebind_private of Longident.t | Variance of Typedecl_variance.error | Unavailable_type_constructor of Path.t - | Bad_fixed_type of string | Unbound_type_var_ext of type_expr * extension_constructor | Val_in_structure | Multiple_native_repr_attributes @@ -100,6 +99,9 @@ type error = | Bad_unboxed_attribute of string | Boxed_and_unboxed | Nonrec_gadt + | Invalid_private_row_declaration of type_expr + | Local_not_enabled + | Global_and_nonlocal exception Error of Location.t * error diff --git a/ocaml/typing/typedecl_immediacy.ml b/ocaml/typing/typedecl_immediacy.ml index feaf8faf870..7d54f48cd14 100644 --- a/ocaml/typing/typedecl_immediacy.ml +++ b/ocaml/typing/typedecl_immediacy.ml @@ -21,19 +21,15 @@ exception Error of Location.t * error let compute_decl env tdecl = match (tdecl.type_kind, tdecl.type_manifest) with - | (Type_variant [{cd_args = Cstr_tuple [arg]; _}], _) - | (Type_variant [{cd_args = Cstr_record [{ld_type = arg; _}]; _}], _) - | (Type_record ([{ld_type = arg; _}], _), _) - when tdecl.type_unboxed.unboxed -> + | (Type_variant ([{cd_args = Cstr_tuple [arg, _] + | Cstr_record [{ld_type = arg; _}]; _}], + Variant_unboxed) + | Type_record ([{ld_type = arg; _}], Record_unboxed _)), _ -> begin match Typedecl_unboxed.get_unboxed_type_representation env arg with - | Typedecl_unboxed.Unavailable -> Type_immediacy.Unknown - | Typedecl_unboxed.This argrepr -> Ctype.immediacy env argrepr - | Typedecl_unboxed.Only_on_64_bits argrepr -> - match Ctype.immediacy env argrepr with - | Type_immediacy.Always -> Type_immediacy.Always_on_64bits - | Type_immediacy.Always_on_64bits | Type_immediacy.Unknown as x -> x + | None -> Type_immediacy.Unknown + | Some argrepr -> Ctype.immediacy env argrepr end - | (Type_variant cstrs, _) -> + | (Type_variant (cstrs, _), _) -> if not (List.exists (fun c -> c.Types.cd_args <> Types.Cstr_tuple []) cstrs) then Type_immediacy.Always diff --git a/ocaml/typing/typedecl_separability.ml b/ocaml/typing/typedecl_separability.ml index 32e34228a36..df5c9baf8c2 100644 --- a/ocaml/typing/typedecl_separability.ml +++ b/ocaml/typing/typedecl_separability.ml @@ -26,8 +26,6 @@ type type_definition = type_declaration a single argument, [argument_to_unbox] represents the information we need to check the argument for separability. *) type argument_to_unbox = { - kind: parameter_kind; (* for error messages *) - mutability: Asttypes.mutable_flag; argument_type: type_expr; result_type_parameter_instances: type_expr list; (** result_type_parameter_instances represents the domain of the @@ -38,23 +36,7 @@ type argument_to_unbox = { For example, [type 'a t = 'b constraint 'a = 'b * int] has [['b * int]] as [result_type_parameter_instances], and so does [type _ t = T : 'b -> ('b * int) t]. *) - location : Location.t; } -and parameter_kind = - | Record_field - | Constructor_parameter - | Constructor_field (** inlined records *) - -(** ['a multiplicity] counts the number of ['a] in - a structure in which expect to see only one ['a]. *) -type 'a multiplicity = - | Zero - | One of 'a - | Several - -type arity = argument_to_unbox multiplicity (**how many parameters?*) - -type branching = arity multiplicity (**how many constructors?*) (** Summarize the right-hand-side of a type declaration, for separability-checking purposes. See {!structure} below. *) @@ -62,14 +44,8 @@ type type_structure = | Synonym of type_expr | Abstract | Open - | Algebraic of branching - -let demultiply_list - : type a b. a list -> (a -> b) -> b multiplicity - = fun li f -> match li with - | [] -> Zero - | [v] -> One (f v) - | _::_::_ -> Several + | Algebraic + | Unboxed of argument_to_unbox let structure : type_definition -> type_structure = fun def -> match def.type_kind with @@ -79,51 +55,23 @@ let structure : type_definition -> type_structure = fun def -> | None -> Abstract | Some type_expr -> Synonym type_expr end - | Type_record (labels, _) -> - Algebraic (One ( - demultiply_list labels @@ fun ld -> { - location = ld.ld_loc; - kind = Record_field; - mutability = ld.ld_mutable; - argument_type = ld.ld_type; - result_type_parameter_instances = def.type_params; - } - )) - | Type_variant constructors -> - Algebraic (demultiply_list constructors @@ fun cd -> - let result_type_parameter_instances = - match cd.cd_res with - (* cd_res is the optional return type (in a GADT); - if None, just use the type parameters *) - | None -> def.type_params - | Some ret_type -> - begin match Ctype.repr ret_type with - | {desc=Tconstr (_, tyl, _)} -> - List.map Ctype.repr tyl - | _ -> assert false - end - in - begin match cd.cd_args with - | Cstr_tuple tys -> - demultiply_list tys @@ fun argument_type -> { - location = cd.cd_loc; - kind = Constructor_parameter; - mutability = Asttypes.Immutable; - argument_type; - result_type_parameter_instances; - } - | Cstr_record labels -> - demultiply_list labels @@ fun ld -> - let argument_type = ld.ld_type in - { - location = ld.ld_loc; - kind = Constructor_field; - mutability = ld.ld_mutable; - argument_type; - result_type_parameter_instances; - } - end) + | ( Type_record ([{ld_type = ty; _}], Record_unboxed _) + | Type_variant ([{cd_args = Cstr_tuple [ty, _]; _}], Variant_unboxed) + | Type_variant ([{cd_args = Cstr_record [{ld_type = ty; _}]; _}], + Variant_unboxed)) -> + let params = + match def.type_kind with + | Type_variant ([{cd_res = Some ret_type}], _) -> + begin match get_desc ret_type with + | Tconstr (_, tyl, _) -> tyl + | _ -> assert false + end + | _ -> def.type_params + in + Unboxed { argument_type = ty; result_type_parameter_instances = params } + + | Type_record _ | Type_variant _ -> Algebraic type error = | Non_separable_evar of string option @@ -179,14 +127,13 @@ let rec immediate_subtypes : type_expr -> type_expr list = fun ty -> parameters as well as the subtype - it performs a shallow traversal of object types, while our implementation collects all method types *) - match (Ctype.repr ty).desc with + match get_desc ty with (* these are the important cases, on which immediate_subtypes is called from [check_type] *) | Tarrow(_,ty1,ty2,_) -> [ty1; ty2] - | Ttuple(tys) - | Tpackage(_,_,tys) -> - tys + | Ttuple(tys) -> tys + | Tpackage(_, fl) -> (snd (List.split fl)) | Tobject(row,class_ty) -> let class_subtys = match !class_ty with @@ -208,7 +155,7 @@ let rec immediate_subtypes : type_expr -> type_expr list = fun ty -> | Tpoly (pty, _) -> [pty] | Tconstr (_path, tys, _) -> tys -and immediate_subtypes_object_row acc ty = match (Ctype.repr ty).desc with +and immediate_subtypes_object_row acc ty = match get_desc ty with | Tnil -> acc | Tfield (_label, _kind, ty, rest) -> let acc = ty :: acc in @@ -219,31 +166,28 @@ and immediate_subtypes_variant_row acc desc = let add_subtypes acc = let add_subtype acc (_l, rf) = immediate_subtypes_variant_row_field acc rf in - List.fold_left add_subtype acc desc.row_fields in + List.fold_left add_subtype acc (row_fields desc) in let add_row acc = - let row = Ctype.repr desc.row_more in - match row.desc with + let row = row_more desc in + match get_desc row with | Tvariant more -> immediate_subtypes_variant_row acc more | _ -> row :: acc in add_row (add_subtypes acc) -and immediate_subtypes_variant_row_field acc = function +and immediate_subtypes_variant_row_field acc f = + match row_field_repr f with | Rpresent(None) | Rabsent -> acc | Rpresent(Some(ty)) -> ty :: acc - | Reither(_,field_types,_,r) -> - let acc = List.rev_append field_types acc in - begin match !r with - | None -> acc - | Some rf -> immediate_subtypes_variant_row_field acc rf - end + | Reither(_,field_types,_) -> + List.rev_append field_types acc let free_variables ty = - Ctype.free_variables (Ctype.repr ty) - |> List.map (fun {desc; id; _} -> - match desc with - | Tvar text -> {text; id} + Ctype.free_variables ty + |> List.map (fun ty -> + match get_desc ty with + Tvar text -> {text; id = get_id ty} | _ -> (* Ctype.free_variables only returns Tvar nodes *) assert false) @@ -445,12 +389,11 @@ let check_type : Env.t -> type_expr -> mode -> context = fun env ty m -> let rec check_type hyps ty m = - let ty = Ctype.repr ty in if Hyps.safe ty m hyps then empty else if Hyps.unsafe ty m hyps then worst_case ty else let hyps = Hyps.add ty m hyps in - match (ty.desc, m) with + match (get_desc ty, m) with (* Impossible case due to the call to [Ctype.repr]. *) | (Tlink _ , _ ) -> assert false (* Impossible case (according to comment in [typing/types.mli]. *) @@ -459,21 +402,21 @@ let check_type | (_ , Ind ) -> empty (* Variable case, add constraint. *) | (Tvar(alpha) , m ) -> - TVarMap.singleton {text = alpha; id = ty.Types.id} m + TVarMap.singleton {text = alpha; id = get_id ty} m (* "Separable" case for constructors with known memory representation. *) | (Tarrow _ , Sep ) | (Ttuple _ , Sep ) | (Tvariant(_) , Sep ) | (Tobject(_,_) , Sep ) | ((Tnil | Tfield _) , Sep ) - | (Tpackage(_,_,_) , Sep ) -> empty + | (Tpackage(_,_) , Sep ) -> empty (* "Deeply separable" case for these same constructors. *) | (Tarrow _ , Deepsep) | (Ttuple _ , Deepsep) | (Tvariant(_) , Deepsep) | (Tobject(_,_) , Deepsep) | ((Tnil | Tfield _) , Deepsep) - | (Tpackage(_,_,_) , Deepsep) -> + | (Tpackage(_,_) , Deepsep) -> let tys = immediate_subtypes ty in let on_subtype context ty = context ++ check_type (Hyps.guard hyps) ty Deepsep in @@ -587,7 +530,6 @@ let msig_of_context : decl_loc:Location.t -> parameters:type_expr list we build a list of modes by repeated consing into an accumulator variable [acc], setting existential variables to Ind as we go. *) - let param_instance = Ctype.repr param_instance in let get context var = try TVarMap.find var context with Not_found -> Ind in let set_ind context var = @@ -595,9 +537,9 @@ let msig_of_context : decl_loc:Location.t -> parameters:type_expr list let is_ind context var = match get context var with | Ind -> true | Sep | Deepsep -> false in - match param_instance.desc with + match get_desc param_instance with | Tvar text -> - let var = {text; id = param_instance.Types.id} in + let var = {text; id = get_id param_instance} in (get context var) :: acc, (set_ind context var) | _ -> let instance_exis = free_variables param_instance in @@ -665,20 +607,15 @@ let msig_of_context : decl_loc:Location.t -> parameters:type_expr list let check_def : Env.t -> type_definition -> Sep.signature = fun env def -> - let boxed = not def.type_unboxed.unboxed in match structure def with | Abstract -> - assert boxed; msig_of_external_type def | Synonym type_expr -> check_type env type_expr Sep |> msig_of_context ~decl_loc:def.type_loc ~parameters:def.type_params - | Open | Algebraic (Zero | Several | One (Zero | Several)) -> - assert boxed; + | Open | Algebraic -> best_msig def - | Algebraic (One (One constructor)) -> - if boxed then best_msig def - else + | Unboxed constructor -> check_type env constructor.argument_type Sep |> msig_of_context ~decl_loc:def.type_loc ~parameters:constructor.result_type_parameter_instances diff --git a/ocaml/typing/typedecl_unboxed.ml b/ocaml/typing/typedecl_unboxed.ml index e2d29a8631a..5622530e415 100644 --- a/ocaml/typing/typedecl_unboxed.ml +++ b/ocaml/typing/typedecl_unboxed.ml @@ -16,40 +16,27 @@ open Types -type t = - | Unavailable - | This of type_expr - | Only_on_64_bits of type_expr - (* We use the Ctype.expand_head_opt version of expand_head to get access to the manifest type of private abbreviations. *) let rec get_unboxed_type_representation env ty fuel = - if fuel < 0 then Unavailable else - let ty = Ctype.repr (Ctype.expand_head_opt env ty) in - match ty.desc with + if fuel < 0 then None else + let ty = Ctype.expand_head_opt env ty in + match get_desc ty with | Tconstr (p, args, _) -> begin match Env.find_type p env with - | exception Not_found -> This ty - | {type_immediate = Always; _} -> - This Predef.type_int - | {type_immediate = Always_on_64bits; _} -> - Only_on_64_bits Predef.type_int - | {type_unboxed = {unboxed = false}} -> This ty + | exception Not_found -> Some ty | {type_params; type_kind = - Type_record ([{ld_type = ty2; _}], _) - | Type_variant [{cd_args = Cstr_tuple [ty2]; _}] - | Type_variant [{cd_args = Cstr_record [{ld_type = ty2; _}]; _}]} - + Type_record ([{ld_type = ty2; _}], Record_unboxed _) + | Type_variant ([{cd_args = Cstr_tuple [ty2, _]; _}], Variant_unboxed) + | Type_variant ([{cd_args = Cstr_record [{ld_type = ty2; _}]; _}], + Variant_unboxed)} -> - let ty2 = match ty2.desc with Tpoly (t, _) -> t | _ -> ty2 in + let ty2 = match get_desc ty2 with Tpoly (t, _) -> t | _ -> ty2 in get_unboxed_type_representation env (Ctype.apply env type_params ty2 args) (fuel - 1) - | {type_kind=Type_abstract} -> Unavailable - (* This case can occur when checking a recursive unboxed type - declaration. *) - | _ -> assert false (* only the above can be unboxed *) + | _ -> Some ty end - | _ -> This ty + | _ -> Some ty let get_unboxed_type_representation env ty = (* Do not give too much fuel: PR#7424 *) diff --git a/ocaml/typing/typedecl_unboxed.mli b/ocaml/typing/typedecl_unboxed.mli index 9afd38e8797..9e860dc1288 100644 --- a/ocaml/typing/typedecl_unboxed.mli +++ b/ocaml/typing/typedecl_unboxed.mli @@ -16,10 +16,5 @@ open Types -type t = - | Unavailable - | This of type_expr - | Only_on_64_bits of type_expr - (* for typeopt.ml *) -val get_unboxed_type_representation: Env.t -> type_expr -> t +val get_unboxed_type_representation: Env.t -> type_expr -> type_expr option diff --git a/ocaml/typing/typedecl_variance.ml b/ocaml/typing/typedecl_variance.ml index 26f5e0e733d..f3f0426471d 100644 --- a/ocaml/typing/typedecl_variance.ml +++ b/ocaml/typing/typedecl_variance.ml @@ -43,13 +43,12 @@ let get_variance ty visited = let compute_variance env visited vari ty = let rec compute_variance_rec vari ty = (* Format.eprintf "%a: %x@." Printtyp.type_expr ty (Obj.magic vari); *) - let ty = Ctype.repr ty in let vari' = get_variance ty visited in if Variance.subset vari vari' then () else let vari = Variance.union vari vari' in visited := TypeMap.add ty vari !visited; let compute_same = compute_variance_rec vari in - match ty.desc with + match get_desc ty with Tarrow (_, ty1, ty2, _) -> let open Variance in let v = conjugate vari in @@ -94,16 +93,15 @@ let compute_variance env visited vari ty = | Tfield (_, _, ty1, ty2) -> compute_same ty1; compute_same ty2 - | Tsubst ty -> - compute_same ty + | Tsubst _ -> + assert false | Tvariant row -> - let row = Btype.row_repr row in List.iter (fun (_,f) -> - match Btype.row_field_repr f with + match row_field_repr f with Rpresent (Some ty) -> compute_same ty - | Reither (_, tyl, _, _) -> + | Reither (_, tyl, _) -> let open Variance in let upper = List.fold_left (fun s f -> set f true s) @@ -114,16 +112,16 @@ let compute_variance env visited vari ty = if List.length tyl > 1 then upper else inter vari upper *) List.iter (compute_variance_rec v) tyl | _ -> ()) - row.row_fields; - compute_same row.row_more + (row_fields row); + compute_same (row_more row) | Tpoly (ty, _) -> compute_same ty | Tvar _ | Tnil | Tlink _ | Tunivar _ -> () - | Tpackage (_, _, tyl) -> + | Tpackage (_, fl) -> let v = Variance.(if mem Pos vari || mem Neg vari then full else unknown) in - List.iter (compute_variance_rec v) tyl + List.iter (fun (_, ty) -> compute_variance_rec v ty) fl in compute_variance_rec vari ty @@ -144,7 +142,7 @@ let compute_variance_type env ~check (required, loc) decl tyl = required in (* Prepare *) - let params = List.map Btype.repr decl.type_params in + let params = decl.type_params in let tvl = ref TypeMap.empty in (* Compute occurrences in the body *) let open Variance in @@ -159,11 +157,10 @@ let compute_variance_type env ~check (required, loc) decl tyl = if Btype.is_Tvar ty || mem Inj (get_variance ty tvl) then () else let visited = ref TypeSet.empty in let rec check ty = - let ty = Ctype.repr ty in if TypeSet.mem ty !visited then () else begin visited := TypeSet.add ty !visited; if mem Inj (get_variance ty tvl) then () else - match ty.desc with + match get_desc ty with | Tvar _ -> raise Exit | Tconstr _ -> let old = !visited in @@ -172,7 +169,7 @@ let compute_variance_type env ~check (required, loc) decl tyl = with Exit -> visited := old; let ty' = Ctype.expand_head_opt env ty in - if ty == ty' then raise Exit else check ty' + if eq_type ty ty' then raise Exit else check ty' end | _ -> Btype.iter_type_expr check ty end @@ -197,7 +194,8 @@ let compute_variance_type env ~check (required, loc) decl tyl = (* Check propagation from constrained parameters *) let args = Btype.newgenty (Ttuple params) in let fvl = Ctype.free_variables args in - let fvl = List.filter (fun v -> not (List.memq v params)) fvl in + let fvl = + List.filter (fun v -> not (List.exists (eq_type v) params)) fvl in (* If there are no extra variables there is nothing to do *) if fvl = [] then () else let tvl2 = ref TypeMap.empty in @@ -210,7 +208,6 @@ let compute_variance_type env ~check (required, loc) decl tyl = params required; let visited = ref TypeSet.empty in let rec check ty = - let ty = Ctype.repr ty in if TypeSet.mem ty !visited then () else let visited' = TypeSet.add ty !visited in visited := visited'; @@ -219,12 +216,12 @@ let compute_variance_type env ~check (required, loc) decl tyl = let v2 = TypeMap.fold (fun t vt v -> - if Ctype.equal env false [ty] [t] then union vt v else v) + if Ctype.is_equal env false [ty] [t] then union vt v else v) !tvl2 null in Btype.backtrack snap; let (c1,n1) = get_upper v1 and (c2,n2,_,i2) = get_lower v2 in if c1 && not c2 || n1 && not n2 then - if List.memq ty fvl then + if List.exists (eq_type ty) fvl then let code = if not i2 then No_variable else if c2 || n2 then Variance_not_reflected else Variance_not_deducible in @@ -256,17 +253,15 @@ let compute_variance_type env ~check (required, loc) decl tyl = set May_weak (mem May_neg v) v) params required -let add_false = List.map (fun ty -> false, ty) - (* A parameter is constrained if it is either instantiated, or it is a variable appearing in another parameter *) let constrained vars ty = - match ty.desc with - | Tvar _ -> List.exists (fun tl -> List.memq ty tl) vars + match get_desc ty with + | Tvar _ -> List.exists (List.exists (eq_type ty)) vars | _ -> true let for_constr = function - | Types.Cstr_tuple l -> add_false l + | Types.Cstr_tuple l -> List.map (fun (ty,_) -> false, ty) l | Types.Cstr_record l -> List.map (fun {Types.ld_mutable; ld_type} -> (ld_mutable = Mutable, ld_type)) @@ -279,10 +274,9 @@ let compute_variance_gadt env ~check (required, loc as rloc) decl compute_variance_type env ~check rloc {decl with type_private = Private} (for_constr tl) | Some ret_type -> - match Ctype.repr ret_type with - | {desc=Tconstr (_, tyl, _)} -> + match get_desc ret_type with + | Tconstr (_, tyl, _) -> (* let tyl = List.map (Ctype.expand_head env) tyl in *) - let tyl = List.map Ctype.repr tyl in let fvl = List.map (Ctype.free_variables ?env:None) tyl in let _ = List.fold_left2 @@ -321,14 +315,14 @@ let compute_variance_decl env ~check decl (required, _ as rloc) = match decl.type_kind with Type_abstract | Type_open -> compute_variance_type env ~check rloc decl mn - | Type_variant tll -> + | Type_variant (tll,_rep) -> if List.for_all (fun c -> c.Types.cd_res = None) tll then compute_variance_type env ~check rloc decl (mn @ List.flatten (List.map (fun c -> for_constr c.Types.cd_args) tll)) else begin let mn = - List.map (fun (_,ty) -> (Types.Cstr_tuple [ty],None)) mn in + List.map (fun (_,ty) -> (Types.Cstr_tuple [ty, Unrestricted],None)) mn in let tll = mn @ List.map (fun c -> c.Types.cd_args, c.Types.cd_res) tll in match List.map (compute_variance_gadt env ~check rloc decl) tll with diff --git a/ocaml/typing/typedtree.ml b/ocaml/typing/typedtree.ml index db618f3b6aa..0ffc9101624 100644 --- a/ocaml/typing/typedtree.ml +++ b/ocaml/typing/typedtree.ml @@ -60,7 +60,8 @@ and 'k pattern_desc = | Tpat_constant : constant -> value pattern_desc | Tpat_tuple : value general_pattern list -> value pattern_desc | Tpat_construct : - Longident.t loc * constructor_description * value general_pattern list -> + Longident.t loc * constructor_description * value general_pattern list + * (Ident.t loc list * core_type) option -> value pattern_desc | Tpat_variant : label * value general_pattern option * row_desc ref -> @@ -148,12 +149,12 @@ and expression_desc = for_body : expression; for_region : bool; } - | Texp_send of expression * meth * expression option * apply_position + | Texp_send of expression * meth * apply_position | Texp_new of Path.t * Longident.t loc * Types.class_declaration * apply_position | Texp_instvar of Path.t * Path.t * string loc | Texp_setinstvar of Path.t * Path.t * string loc * expression - | Texp_override of Path.t * (Path.t * string loc * expression) list + | Texp_override of Path.t * (Ident.t * string loc * expression) list | Texp_letmodule of Ident.t option * string option loc * Types.module_presence * module_expr * expression @@ -179,8 +180,9 @@ and expression_desc = and ident_kind = Id_value | Id_prim of Types.alloc_mode option and meth = - Tmeth_name of string + | Tmeth_name of string | Tmeth_val of Ident.t + | Tmeth_ancestor of Ident.t * Path.t and comprehension = { @@ -251,7 +253,7 @@ and class_expr_desc = | Tcl_let of rec_flag * value_binding list * (Ident.t * expression) list * class_expr | Tcl_constraint of - class_expr * class_type option * string list * string list * Concr.t + class_expr * class_type option * string list * string list * MethSet.t (* Visible instance variables, methods and concrete methods *) | Tcl_open of open_description * class_expr @@ -413,6 +415,7 @@ and signature_item_desc = | Tsig_modsubst of module_substitution | Tsig_recmodule of module_declaration list | Tsig_modtype of module_type_declaration + | Tsig_modtypesubst of module_type_declaration | Tsig_open of open_description | Tsig_include of include_description | Tsig_class of class_description list @@ -483,8 +486,11 @@ and include_declaration = module_expr include_infos and with_constraint = Twith_type of type_declaration | Twith_module of Path.t * Longident.t loc + | Twith_modtype of module_type | Twith_typesubst of type_declaration | Twith_modsubst of Path.t * Longident.t loc + | Twith_modtypesubst of module_type + and core_type = (* mutable because of [Typeclass.declare_method] *) @@ -569,6 +575,7 @@ and label_declaration = ld_id: Ident.t; ld_name: string loc; ld_mutable: mutable_flag; + ld_global: global_flag; ld_type: core_type; ld_loc: Location.t; ld_attributes: attribute list; @@ -578,6 +585,7 @@ and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; + cd_vars: string loc list; cd_args: constructor_arguments; cd_res: core_type option; cd_loc: Location.t; @@ -585,7 +593,7 @@ and constructor_declaration = } and constructor_arguments = - | Cstr_tuple of core_type list + | Cstr_tuple of (core_type * global_flag) list | Cstr_record of label_declaration list and type_extension = @@ -617,7 +625,7 @@ and extension_constructor = } and extension_constructor_kind = - Text_decl of constructor_arguments * core_type option + Text_decl of string loc list * constructor_arguments * core_type option | Text_rebind of Path.t * Longident.t loc and class_type = @@ -678,6 +686,14 @@ and 'a class_infos = ci_attributes: attribute list; } +type implementation = { + structure: structure; + coercion: module_coercion; + signature: Types.signature; + shape: Shape.t; +} + + (* Auxiliary functions over the a.s.t. *) let as_computation_pattern (p : pattern) : computation general_pattern = @@ -725,7 +741,7 @@ let shallow_iter_pattern_desc = fun f -> function | Tpat_alias(p, _, _) -> f.f p | Tpat_tuple patl -> List.iter f.f patl - | Tpat_construct(_, _, patl) -> List.iter f.f patl + | Tpat_construct(_, _, patl, _) -> List.iter f.f patl | Tpat_variant(_, pat, _) -> Option.iter f.f pat | Tpat_record (lbl_pat_list, _) -> List.iter (fun (_, _, pat) -> f.f pat) lbl_pat_list @@ -749,8 +765,8 @@ let shallow_map_pattern_desc Tpat_tuple (List.map f.f pats) | Tpat_record (lpats, closed) -> Tpat_record (List.map (fun (lid, l,p) -> lid, l, f.f p) lpats, closed) - | Tpat_construct (lid, c,pats) -> - Tpat_construct (lid, c, List.map f.f pats) + | Tpat_construct (lid, c, pats, ty) -> + Tpat_construct (lid, c, List.map f.f pats, ty) | Tpat_array pats -> Tpat_array (List.map f.f pats) | Tpat_lazy p1 -> Tpat_lazy (f.f p1) diff --git a/ocaml/typing/typedtree.mli b/ocaml/typing/typedtree.mli index 00234cca94e..4750fcbd80c 100644 --- a/ocaml/typing/typedtree.mli +++ b/ocaml/typing/typedtree.mli @@ -90,11 +90,15 @@ and 'k pattern_desc = *) | Tpat_construct : Longident.t loc * Types.constructor_description * - value general_pattern list -> + value general_pattern list * (Ident.t loc list * core_type) option -> value pattern_desc - (** C [] - C P [P] - C (P1, ..., Pn) [P1; ...; Pn] + (** C ([], None) + C P ([P], None) + C (P1, ..., Pn) ([P1; ...; Pn], None) + C (P : t) ([P], Some ([], t)) + C (P1, ..., Pn : t) ([P1; ...; Pn], Some ([], t)) + C (type a) (P : t) ([P], Some ([a], t)) + C (type a) (P1, ..., Pn : t) ([P1; ...; Pn], Some ([a], t)) *) | Tpat_variant : label * value general_pattern option * Types.row_desc ref -> @@ -286,12 +290,12 @@ and expression_desc = (* for_region = true means we create a region for the body. false means it may allocated in the containing region *) } - | Texp_send of expression * meth * expression option * apply_position + | Texp_send of expression * meth * apply_position | Texp_new of Path.t * Longident.t loc * Types.class_declaration * apply_position | Texp_instvar of Path.t * Path.t * string loc | Texp_setinstvar of Path.t * Path.t * string loc * expression - | Texp_override of Path.t * (Path.t * string loc * expression) list + | Texp_override of Path.t * (Ident.t * string loc * expression) list | Texp_letmodule of Ident.t option * string option loc * Types.module_presence * module_expr * expression @@ -320,6 +324,7 @@ and ident_kind = Id_value | Id_prim of Types.alloc_mode option and meth = Tmeth_name of string | Tmeth_val of Ident.t + | Tmeth_ancestor of Ident.t * Path.t and comprehension = { @@ -392,7 +397,8 @@ and class_expr_desc = | Tcl_let of rec_flag * value_binding list * (Ident.t * expression) list * class_expr | Tcl_constraint of - class_expr * class_type option * string list * string list * Types.Concr.t + class_expr * class_type option * string list * string list + * Types.MethSet.t (* Visible instance variables, methods and concrete methods *) | Tcl_open of open_description * class_expr @@ -559,6 +565,7 @@ and signature_item_desc = | Tsig_modsubst of module_substitution | Tsig_recmodule of module_declaration list | Tsig_modtype of module_type_declaration + | Tsig_modtypesubst of module_type_declaration | Tsig_open of open_description | Tsig_include of include_description | Tsig_class of class_description list @@ -631,8 +638,10 @@ and include_declaration = module_expr include_infos and with_constraint = Twith_type of type_declaration | Twith_module of Path.t * Longident.t loc + | Twith_modtype of module_type | Twith_typesubst of type_declaration | Twith_modsubst of Path.t * Longident.t loc + | Twith_modtypesubst of module_type and core_type = { mutable ctyp_desc : core_type_desc; @@ -719,6 +728,7 @@ and label_declaration = ld_id: Ident.t; ld_name: string loc; ld_mutable: mutable_flag; + ld_global: Types.global_flag; ld_type: core_type; ld_loc: Location.t; ld_attributes: attributes; @@ -728,6 +738,7 @@ and constructor_declaration = { cd_id: Ident.t; cd_name: string loc; + cd_vars: string loc list; cd_args: constructor_arguments; cd_res: core_type option; cd_loc: Location.t; @@ -735,7 +746,7 @@ and constructor_declaration = } and constructor_arguments = - | Cstr_tuple of core_type list + | Cstr_tuple of (core_type * Types.global_flag) list | Cstr_record of label_declaration list and type_extension = @@ -767,7 +778,7 @@ and extension_constructor = } and extension_constructor_kind = - Text_decl of constructor_arguments * core_type option + Text_decl of string loc list * constructor_arguments * core_type option | Text_rebind of Path.t * Longident.t loc and class_type = @@ -828,6 +839,22 @@ and 'a class_infos = ci_attributes: attributes; } +type implementation = { + structure: structure; + coercion: module_coercion; + signature: Types.signature; + shape: Shape.t; +} +(** A typechecked implementation including its module structure, its exported + signature, and a coercion of the module against that signature. + + If an .mli file is present, the signature will come from that file and be + the exported signature of the module. + + If there isn't one, the signature will be inferred from the module + structure. +*) + (* Auxiliary functions over the a.s.t. *) (** [as_computation_pattern p] is a computation pattern with description diff --git a/ocaml/typing/typemod.ml b/ocaml/typing/typemod.ml index e5a8c646b83..d6d0e4136e5 100644 --- a/ocaml/typing/typemod.ml +++ b/ocaml/typing/typemod.ml @@ -20,40 +20,11 @@ open Asttypes open Parsetree open Types open Format -module Value_mode = Btype.Value_mode -module String = Misc.Stdlib.String -module Sig_component_kind = struct - type t = - | Value - | Type - | Module - | Module_type - | Extension_constructor - | Class - | Class_type - - let to_string = function - | Value -> "value" - | Type -> "type" - | Module -> "module" - | Module_type -> "module type" - | Extension_constructor -> "extension constructor" - | Class -> "class" - | Class_type -> "class type" - - (** Whether the name of a component of that kind can appear in a type. *) - let can_appear_in_types = function - | Value - | Extension_constructor -> - false - | Type - | Module - | Module_type - | Class - | Class_type -> - true -end +let () = Includemod_errorprinter.register () + +module Sig_component_kind = Shape.Sig_component_kind +module String = Misc.Stdlib.String type hiding_error = | Illegal_shadowing of { @@ -79,8 +50,8 @@ type functor_dependency_error = type error = Cannot_apply of module_type - | Not_included of Includemod.error list - | Not_included_functor of Includemod.error list + | Not_included of Includemod.explanation + | Not_included_functor of Includemod.explanation | Cannot_eliminate_dependency of functor_dependency_error * module_type | Signature_expected | Structure_expected of module_type @@ -89,14 +60,13 @@ type error = | Signature_result_expected of module_type | Recursive_include_functor | With_no_component of Longident.t - | With_mismatch of Longident.t * Includemod.error list + | With_mismatch of Longident.t * Includemod.explanation | With_makes_applicative_functor_ill_typed of - Longident.t * Path.t * Includemod.error list + Longident.t * Path.t * Includemod.explanation | With_changes_module_alias of Longident.t * Ident.t * Path.t | With_cannot_remove_constrained_type | Repeated_name of Sig_component_kind.t * string | Non_generalizable of type_expr - | Non_generalizable_class of Ident.t * class_declaration | Non_generalizable_module of module_type | Implementation_is_required of string | Interface_not_compiled of string @@ -112,7 +82,8 @@ type error = | Badly_formed_signature of string * Typedecl.error | Cannot_hide_id of hiding_error | Invalid_type_subst_rhs - | Unsupported_extension of Clflags.Extension.t + | Unpackable_local_modtype_subst of Path.t + | With_cannot_remove_packed_modtype of Path.t * module_type exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -159,38 +130,42 @@ let extract_sig_functor_open funct_body env loc mty sig_acc = with Includemod.Error msg -> raise (Error(loc, env, Not_included_functor msg)) in + (* We must scrape the result type in an environment expanded with the + parameter type (to avoid `Not_found` exceptions when it is referenced). + Because we don't have an actual parameter, we create definitions for + the parameter's types with [sig_make_manifest]. References to this + fake parameter are eliminated later. *) + let extended_env = + match param with + | None -> env + | Some id -> + let sg_param = Mtype.sig_make_manifest sig_acc in + Env.add_module ~arg:true id Mp_present (Mty_signature sg_param) env + in let incl_kind, sg_result = (* Accept functor types of the forms: sig..end -> sig..end and sig..end -> () -> sig..end *) - match Mtype.scrape env mty_result with + match Mtype.scrape extended_env mty_result with | Mty_signature sg_result -> Tincl_functor coercion, sg_result | Mty_functor (Unit,_) when funct_body && Mtype.contains_type env mty -> raise (Error (loc, env, Not_includable_in_functor_body)) | Mty_functor (Unit,mty_result) -> begin - match Mtype.scrape env mty_result with + match Mtype.scrape extended_env mty_result with | Mty_signature sg_result -> Tincl_gen_functor coercion, sg_result | sg -> raise (Error (loc,env,Signature_result_expected (Mty_functor (Unit,sg)))) end | sg -> raise (Error (loc,env,Signature_result_expected sg)) in - (* Like the [Pmod_apply] case, we want to use [nondep_supertype] to - eliminate references to the functor's parameter in its result type. - Unlike that case, we don't have an actual parameter, just the previous - contents of the module currently being checked. So we create - definitions for the parameter's types with [sig_make_manifest] before - the call to [nondep_sig]. *) + (* Here we eliminate references to the non-existent parameter module using + [nondep_sig]. *) let sg = match param with | None -> sg_result | Some id -> - let sg_param = Mtype.sig_make_manifest sig_acc in - let env = - Env.add_module ~arg:true id Mp_present (Mty_signature sg_param) env - in - try Mtype.nondep_sig env [id] sg_result + try Mtype.nondep_sig extended_env [id] sg_result with Ctype.Nondep_cannot_erase _ -> raise(Error(loc, env, Cannot_eliminate_dependency (Functor_included, mty_func))) @@ -205,8 +180,8 @@ let extract_sig_functor_open funct_body env loc mty sig_acc = let has_include_functor env loc attrs = match Builtin_attributes.has_include_functor attrs with | Error () -> - raise(Error (loc, env, - Unsupported_extension Clflags.Extension.Include_functor)) + raise(Typetexp.Error (loc, env, + Unsupported_extension Include_functor)) | Ok b -> b (* Compute the environment after opening a module *) @@ -316,32 +291,30 @@ let check_recmod_typedecls env decls = (* Merge one "with" constraint in a signature *) -let rec add_rec_types env = function - Sig_type(id, decl, Trec_next, _) :: rem -> - add_rec_types (Env.add_type ~check:true id decl env) rem - | _ -> env - -let check_type_decl env loc id row_id newdecl decl rs rem = - let env = Env.add_type ~check:true id newdecl env in - let env = +let check_type_decl env sg loc id row_id newdecl decl = + let fresh_id = Ident.rename id in + let path = Pident fresh_id in + let sub = Subst.add_type id path Subst.identity in + let fresh_row_id, sub = match row_id with + | None -> None, sub + | Some id -> + let fresh_row_id = Some (Ident.rename id) in + let sub = Subst.add_type id (Pident fresh_id) sub in + fresh_row_id, sub + in + let newdecl = Subst.type_declaration sub newdecl in + let decl = Subst.type_declaration sub decl in + let sg = List.map (Subst.signature_item Keep sub) sg in + let env = Env.add_type ~check:false fresh_id newdecl env in + let env = + match fresh_row_id with | None -> env - | Some id -> Env.add_type ~check:false id newdecl env + | Some fresh_row_id -> Env.add_type ~check:false fresh_row_id newdecl env in - let env = if rs = Trec_not then env else add_rec_types env rem in - Includemod.type_declarations ~mark:Mark_both ~loc env id newdecl decl; - Typedecl.check_coherence env loc (Path.Pident id) newdecl - -let update_rec_next rs rem = - match rs with - Trec_next -> rem - | Trec_first | Trec_not -> - match rem with - Sig_type (id, decl, Trec_next, priv) :: rem -> - Sig_type (id, decl, rs, priv) :: rem - | Sig_module (id, pres, mty, Trec_next, priv) :: rem -> - Sig_module (id, pres, mty, rs, priv) :: rem - | _ -> rem + let env = Env.add_signature sg env in + Includemod.type_declarations ~mark:Mark_both ~loc env fresh_id newdecl decl; + Typedecl.check_coherence env loc path newdecl let make_variance p n i = let open Variance in @@ -422,9 +395,7 @@ let retype_applicative_functor_type ~loc env funct arg = - aliases: module A = M still makes sense but it doesn't mean the same thing anymore, so it's forbidden until it's clear what we should do with it. This function would be called with M.N.t and N.t to check for these uses. *) -let check_usage_of_path_of_substituted_item paths env signature ~loc ~lid = - let iterator = - let env, super = iterator_with_env env in +let check_usage_of_path_of_substituted_item paths ~loc ~lid env super = { super with Btype.it_signature_item = (fun self -> function | Sig_module (id, _, { md_type = Mty_alias aliased_path; _ }, _, _) @@ -444,17 +415,57 @@ let check_usage_of_path_of_substituted_item paths env signature ~loc ~lid = paths then let env = Lazy.force !env in - try retype_applicative_functor_type ~loc env funct arg - with Includemod.Error explanation -> - raise(Error(loc, env, - With_makes_applicative_functor_ill_typed + match retype_applicative_functor_type ~loc env funct arg with + | None -> () + | Some explanation -> + raise(Error(loc, env, + With_makes_applicative_functor_ill_typed (lid.txt, referenced_path, explanation))) ) ); } + +(* When doing a module type destructive substitution [with module type T = RHS] + where RHS is not a module type path, we need to check that the module type + T was not used as a path for a packed module +*) +let check_usage_of_module_types ~error ~paths ~loc env super = + let it_do_type_expr it ty = match get_desc ty with + | Tpackage (p, _) -> + begin match List.find_opt (Path.same p) paths with + | Some p -> raise (Error(loc,Lazy.force !env,error p)) + | _ -> super.Btype.it_do_type_expr it ty + end + | _ -> super.Btype.it_do_type_expr it ty in + { super with Btype.it_do_type_expr } + +let do_check_after_substitution env ~loc ~lid paths unpackable_modtype sg = + let env, iterator = iterator_with_env env in + let last, rest = match List.rev paths with + | [] -> assert false + | last :: rest -> last, rest + in + (* The last item is the one that's removed. We don't need to check how + it's used since it's replaced by a more specific type/module. *) + assert (match last with Pident _ -> true | _ -> false); + let iterator = match rest with + | [] -> iterator + | _ :: _ -> + check_usage_of_path_of_substituted_item rest ~loc ~lid env iterator + in + let iterator = match unpackable_modtype with + | None -> iterator + | Some mty -> + let error p = With_cannot_remove_packed_modtype(p,mty) in + check_usage_of_module_types ~error ~paths ~loc env iterator in - iterator.Btype.it_signature iterator signature; - Btype.unmark_iterators.Btype.it_signature Btype.unmark_iterators signature + iterator.Btype.it_signature iterator sg; + Btype.(unmark_iterators.it_signature unmark_iterators) sg + +let check_usage_after_substitution env ~loc ~lid paths unpackable_modtype sg = + match paths, unpackable_modtype with + | [_], None -> () + | _ -> do_check_after_substitution env ~loc ~lid paths unpackable_modtype sg (* After substitution one also needs to re-check the well-foundedness of type declarations in recursive modules *) @@ -520,31 +531,51 @@ let params_are_constrained = let rec loop = function | [] -> false | hd :: tl -> - match (Btype.repr hd).desc with + match get_desc hd with | Tvar _ -> List.memq hd tl || loop tl | _ -> true in loop ;; -let merge_constraint initial_env remove_aliases loc sg constr = - let lid = - match constr with - | Pwith_type (lid, _) | Pwith_module (lid, _) - | Pwith_typesubst (lid, _) | Pwith_modsubst (lid, _) -> lid - in +type with_info = + | With_type of Parsetree.type_declaration + | With_typesubst of Parsetree.type_declaration + | With_module of { + lid:Longident.t loc; + path:Path.t; + md:Types.module_declaration; + remove_aliases:bool + } + | With_modsubst of Longident.t loc * Path.t * Types.module_declaration + | With_modtype of Typedtree.module_type + | With_modtypesubst of Typedtree.module_type + +let merge_constraint initial_env loc sg lid constr = let destructive_substitution = match constr with - | Pwith_type _ | Pwith_module _ -> false - | Pwith_typesubst _ | Pwith_modsubst _ -> true + | With_type _ | With_module _ | With_modtype _ -> false + | With_typesubst _ | With_modsubst _ | With_modtypesubst _ -> true in let real_ids = ref [] in - let rec merge sig_env sg namelist row_id = - match (sg, namelist, constr) with - ([], _, _) -> - raise(Error(loc, sig_env, With_no_component lid.txt)) - | (Sig_type(id, decl, rs, priv) :: rem, [s], - Pwith_type (_, ({ptype_kind = Ptype_abstract} as sdecl))) + let unpackable_modtype = ref None in + let split_row_id s ghosts = + let srow = s ^ "#row" in + let rec split before = function + | Sig_type(id,_,_,_) :: rest when Ident.name id = srow -> + before, Some id, rest + | a :: rest -> split (a::before) rest + | [] -> before, None, [] + in + split [] ghosts + in + let rec patch_item constr namelist outer_sig_env sg_for_env ~ghosts item = + let return ?(ghosts=ghosts) ~replace_by info = + Some (info, {Signature_group.ghosts; replace_by}) + in + match item, namelist, constr with + | Sig_type(id, decl, rs, priv), [s], + With_type ({ptype_kind = Ptype_abstract} as sdecl) when Ident.name id = s && Typedecl.is_fixed_type sdecl -> let decl_row = let arity = List.length sdecl.ptype_params in @@ -574,74 +605,115 @@ let merge_constraint initial_env remove_aliases loc sg constr = type_expansion_scope = Btype.lowest_level; type_attributes = []; type_immediate = Unknown; - type_unboxed = unboxed_false_default_false; + type_unboxed_default = false; type_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); } and id_row = Ident.create_local (s^"#row") in let initial_env = Env.add_type ~check:false id_row decl_row initial_env in + let sig_env = Env.add_signature sg_for_env outer_sig_env in let tdecl = - Typedecl.transl_with_constraint id (Some(Pident id_row)) + Typedecl.transl_with_constraint id ~fixed_row_path:(Pident id_row) ~sig_env ~sig_decl:decl ~outer_env:initial_env sdecl in let newdecl = tdecl.typ_type in - check_type_decl sig_env sdecl.ptype_loc id row_id newdecl decl rs rem; + let before_ghosts, row_id, after_ghosts = split_row_id s ghosts in + check_type_decl outer_sig_env sg_for_env sdecl.ptype_loc + id row_id newdecl decl; let decl_row = {decl_row with type_params = newdecl.type_params} in let rs' = if rs = Trec_first then Trec_not else rs in - (Pident id, lid, Twith_type tdecl), - Sig_type(id_row, decl_row, rs', priv) - :: Sig_type(id, newdecl, rs, priv) - :: rem - | (Sig_type(id, sig_decl, rs, priv) :: rem , [s], - (Pwith_type (_, sdecl) | Pwith_typesubst (_, sdecl) as constr)) + let ghosts = + List.rev_append before_ghosts + (Sig_type(id_row, decl_row, rs', priv)::after_ghosts) + in + return ~ghosts + ~replace_by:(Some (Sig_type(id, newdecl, rs, priv))) + (Pident id, lid, Twith_type tdecl) + | Sig_type(id, sig_decl, rs, priv) , [s], + (With_type sdecl | With_typesubst sdecl as constr) when Ident.name id = s -> + let sig_env = Env.add_signature sg_for_env outer_sig_env in let tdecl = - Typedecl.transl_with_constraint id None + Typedecl.transl_with_constraint id ~sig_env ~sig_decl ~outer_env:initial_env sdecl in let newdecl = tdecl.typ_type and loc = sdecl.ptype_loc in - check_type_decl sig_env loc id row_id newdecl sig_decl rs rem; + let before_ghosts, row_id, after_ghosts = split_row_id s ghosts in + let ghosts = List.rev_append before_ghosts after_ghosts in + check_type_decl outer_sig_env sg_for_env loc + id row_id newdecl sig_decl; begin match constr with - Pwith_type _ -> - (Pident id, lid, Twith_type tdecl), - Sig_type(id, newdecl, rs, priv) :: rem - | (* Pwith_typesubst *) _ -> + With_type _ -> + return ~ghosts + ~replace_by:(Some(Sig_type(id, newdecl, rs, priv))) + (Pident id, lid, Twith_type tdecl) + | (* With_typesubst *) _ -> real_ids := [Pident id]; - (Pident id, lid, Twith_typesubst tdecl), - update_rec_next rs rem + return ~ghosts ~replace_by:None + (Pident id, lid, Twith_typesubst tdecl) + end + | Sig_modtype(id, mtd, priv), [s], + (With_modtype mty | With_modtypesubst mty) + when Ident.name id = s -> + let sig_env = Env.add_signature sg_for_env outer_sig_env in + let () = match mtd.mtd_type with + | None -> () + | Some previous_mty -> + Includemod.check_modtype_equiv ~loc sig_env + id previous_mty mty.mty_type + in + if not destructive_substitution then + let mtd': modtype_declaration = + { + mtd_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + mtd_type = Some mty.mty_type; + mtd_attributes = []; + mtd_loc = loc; + } + in + return + ~replace_by:(Some(Sig_modtype(id, mtd', priv))) + (Pident id, lid, Twith_modtype mty) + else begin + let path = Pident id in + real_ids := [path]; + begin match mty.mty_type with + | Mty_ident _ -> () + | mty -> unpackable_modtype := Some mty + end; + return ~replace_by:None (Pident id, lid, Twith_modtypesubst mty) end - | (Sig_type(id, _, _, _) :: rem, [s], (Pwith_type _ | Pwith_typesubst _)) - when Ident.name id = s ^ "#row" -> - merge sig_env rem namelist (Some id) - | (Sig_module(id, pres, md, rs, priv) :: rem, [s], Pwith_module (_, lid')) + | Sig_module(id, pres, md, rs, priv), [s], + With_module {lid=lid'; md=md'; path; remove_aliases} when Ident.name id = s -> - let path, md' = Env.lookup_module ~loc lid'.txt initial_env in + let sig_env = Env.add_signature sg_for_env outer_sig_env in let mty = md'.md_type in let mty = Mtype.scrape_for_type_of ~remove_aliases sig_env mty in let md'' = { md' with md_type = mty } in let newmd = Mtype.strengthen_decl ~aliasable:false sig_env md'' path in ignore(Includemod.modtypes ~mark:Mark_both ~loc sig_env newmd.md_type md.md_type); - (Pident id, lid, Twith_module (path, lid')), - Sig_module(id, pres, newmd, rs, priv) :: rem - | (Sig_module(id, _, md, rs, _) :: rem, [s], Pwith_modsubst (_, lid')) + return + ~replace_by:(Some(Sig_module(id, pres, newmd, rs, priv))) + (Pident id, lid, Twith_module (path, lid')) + | Sig_module(id, _, md, _rs, _), [s], With_modsubst (lid',path,md') when Ident.name id = s -> - let path, md' = Env.lookup_module ~loc lid'.txt initial_env in + let sig_env = Env.add_signature sg_for_env outer_sig_env in let aliasable = not (Env.is_functor_arg path sig_env) in ignore (Includemod.strengthened_module_decl ~loc ~mark:Mark_both ~aliasable sig_env md' path md); real_ids := [Pident id]; - (Pident id, lid, Twith_modsubst (path, lid')), - update_rec_next rs rem - | (Sig_module(id, _, md, rs, priv) as item :: rem, s :: namelist, constr) + return ~replace_by:None (Pident id, lid, Twith_modsubst (path, lid')) + | Sig_module(id, _, md, rs, priv) as item, s :: namelist, constr when Ident.name id = s -> + let sig_env = Env.add_signature sg_for_env outer_sig_env in let sg = extract_sig sig_env loc md.md_type in let ((path, _, tcstr), newsg) = merge_signature sig_env sg namelist in let path = path_concat id path in real_ids := path :: !real_ids; let item = match md.md_type, constr with - Mty_alias _, (Pwith_module _ | Pwith_type _) -> + Mty_alias _, (With_module _ | With_type _) -> (* A module alias cannot be refined, so keep it and just check that the constraint is correct *) item @@ -649,39 +721,28 @@ let merge_constraint initial_env remove_aliases loc sg constr = let newmd = {md with md_type = Mty_signature newsg} in Sig_module(id, Mp_present, newmd, rs, priv) in - (path, lid, tcstr), - item :: rem - | (item :: rem, _, _) -> - let (cstr, items) = merge sig_env rem namelist row_id - in - cstr, item :: items + return ~replace_by:(Some item) (path, lid, tcstr) + | _ -> None and merge_signature env sg namelist = - let sig_env = Env.add_signature sg env in - merge sig_env sg namelist None + match + Signature_group.replace_in_place (patch_item constr namelist env sg) sg + with + | Some (x,sg) -> x, sg + | None -> raise(Error(loc, env, With_no_component lid.txt)) in try let names = Longident.flatten lid.txt in let (tcstr, sg) = merge_signature initial_env sg names in - if destructive_substitution then ( - match List.rev !real_ids with - | [] -> assert false - | last :: rest -> - (* The last item is the one that's removed. We don't need to check how - it's used since it's replaced by a more specific type/module. *) - assert (match last with Pident _ -> true | _ -> false); - match rest with - | [] -> () - | _ :: _ -> - check_usage_of_path_of_substituted_item - rest initial_env sg ~loc ~lid; - ); + if destructive_substitution then + check_usage_after_substitution ~loc ~lid initial_env !real_ids + !unpackable_modtype sg; let sg = match tcstr with | (_, _, Twith_typesubst tdecl) -> let how_to_extend_subst = let sdecl = match constr with - | Pwith_typesubst (_, sdecl) -> sdecl + | With_typesubst sdecl -> sdecl | _ -> assert false in match type_decl_is_alias sdecl with @@ -699,21 +760,28 @@ let merge_constraint initial_env remove_aliases loc sg constr = With_cannot_remove_constrained_type)); fun s path -> Subst.add_type_function path ~params ~body s in - let sub = List.fold_left how_to_extend_subst Subst.identity !real_ids in + let sub = Subst.change_locs Subst.identity loc in + let sub = List.fold_left how_to_extend_subst sub !real_ids in (* This signature will not be used directly, it will always be freshened by the caller. So what we do with the scope doesn't really matter. But making it local makes it unlikely that we will ever use the result of this function unfreshened without issue. *) Subst.signature Make_local sub sg | (_, _, Twith_modsubst (real_path, _)) -> + let sub = Subst.change_locs Subst.identity loc in let sub = List.fold_left (fun s path -> Subst.add_module_path path real_path s) - Subst.identity + sub !real_ids in (* See explanation in the [Twith_typesubst] case above. *) Subst.signature Make_local sub sg + | (_, _, Twith_modtypesubst tmty) -> + let add s p = Subst.add_modtype_path p tmty.mty_type s in + let sub = Subst.change_locs Subst.identity loc in + let sub = List.fold_left add sub !real_ids in + Subst.signature Make_local sub sg | _ -> sg in @@ -801,8 +869,10 @@ let rec approx_modtype env smty = List.iter (fun sdecl -> match sdecl with - | Pwith_type _ -> () - | Pwith_typesubst _ -> () + | Pwith_type _ + | Pwith_typesubst _ + | Pwith_modtype _ + | Pwith_modtypesubst _ -> () | Pwith_module (_, lid') -> (* Lookup the module to make sure that it is not recursive. (GPR#1626) *) @@ -897,6 +967,13 @@ and approx_sig env ssg = Env.enter_modtype ~scope d.pmtd_name.txt info env in Sig_modtype(id, info, Exported) :: approx_sig newenv srem + | Psig_modtypesubst d -> + let info = approx_modtype_info env d in + let scope = Ctype.create_scope () in + let (_id, newenv) = + Env.enter_modtype ~scope d.pmtd_name.txt info env + in + approx_sig newenv srem | Psig_open sod -> let _, env = type_open_descr env sod in approx_sig env srem @@ -944,11 +1021,22 @@ let approx_modtype env smty = module Signature_names : sig type t + type shadowable = + { + self: Ident.t; + group: Ident.t list; + (** group includes the element itself and all elements + that should be removed at the same time + *) + loc:Location.t; + } + type info = [ | `Exported | `From_open - | `Shadowable of Ident.t * Location.t + | `Shadowable of shadowable | `Substituted_away of Subst.t + | `Unpackable_modtype_substituted_away of Ident.t * Subst.t ] val create : unit -> t @@ -962,19 +1050,30 @@ module Signature_names : sig val check_class_type: ?info:info -> t -> Location.t -> Ident.t -> unit val check_sig_item: - ?info:info -> t -> Location.t -> Types.signature_item -> unit + ?info:info -> t -> Location.t -> Signature_group.rec_group -> unit val simplify: Env.t -> t -> Types.signature -> Types.signature end = struct + type shadowable = + { + self: Ident.t; + group: Ident.t list; + (** group includes the element itself and all elements + that should be removed at the same time + *) + loc:Location.t; + } + type bound_info = [ | `Exported - | `Shadowable of Ident.t * Location.t + | `Shadowable of shadowable ] type info = [ | `From_open | `Substituted_away of Subst.t + | `Unpackable_modtype_substituted_away of Ident.t * Subst.t | bound_info ] @@ -985,6 +1084,7 @@ end = struct type to_be_removed = { mutable subst: Subst.t; mutable hide: (Sig_component_kind.t * Location.t * hide_reason) Ident.Map.t; + mutable unpackable_modtypes: Ident.Set.t; } type names_infos = (string, bound_info) Hashtbl.t @@ -1019,26 +1119,46 @@ end = struct to_be_removed = { subst = Subst.identity; hide = Ident.Map.empty; + unpackable_modtypes = Ident.Set.empty; }; } - let check cl loc (tbl : names_infos) id (info : info) to_be_removed = + let table_for component names = + let open Sig_component_kind in + match component with + | Value -> names.values + | Type -> names.types + | Module -> names.modules + | Module_type -> names.modtypes + | Extension_constructor -> names.typexts + | Class -> names.classes + | Class_type -> names.class_types + + let check cl t loc id (info : info) = + let to_be_removed = t.to_be_removed in match info with | `Substituted_away s -> - to_be_removed.subst <- Subst.compose s to_be_removed.subst + to_be_removed.subst <- Subst.compose s to_be_removed.subst; + | `Unpackable_modtype_substituted_away (id,s) -> + to_be_removed.subst <- Subst.compose s to_be_removed.subst; + to_be_removed.unpackable_modtypes <- + Ident.Set.add id to_be_removed.unpackable_modtypes | `From_open -> to_be_removed.hide <- Ident.Map.add id (cl, loc, From_open) to_be_removed.hide | #bound_info as bound_info -> + let tbl = table_for cl t.bound in let name = Ident.name id in match Hashtbl.find_opt tbl name with | None -> Hashtbl.add tbl name bound_info - | Some (`Shadowable (shadowed_id, shadowed_loc)) -> + | Some (`Shadowable s) -> Hashtbl.replace tbl name bound_info; let reason = Shadowed_by (id, loc) in + List.iter (fun shadowed_id -> to_be_removed.hide <- - Ident.Map.add shadowed_id (cl, shadowed_loc, reason) + Ident.Map.add shadowed_id (cl, s.loc, reason) to_be_removed.hide + ) s.group | Some `Exported -> raise(Error(loc, Env.empty, Repeated_name(cl, name))) @@ -1046,46 +1166,76 @@ end = struct let info = match info with | Some i -> i - | None -> `Shadowable (id, loc) + | None -> `Shadowable {self=id; group=[id]; loc} in - check Sig_component_kind.Value loc t.bound.values id info t.to_be_removed + check Sig_component_kind.Value t loc id info let check_type ?(info=`Exported) t loc id = - check Sig_component_kind.Type loc t.bound.types id info t.to_be_removed + check Sig_component_kind.Type t loc id info let check_module ?(info=`Exported) t loc id = - check Sig_component_kind.Module loc t.bound.modules id info t.to_be_removed + check Sig_component_kind.Module t loc id info let check_modtype ?(info=`Exported) t loc id = - check Sig_component_kind.Module_type loc t.bound.modtypes id info - t.to_be_removed + check Sig_component_kind.Module_type t loc id info let check_typext ?(info=`Exported) t loc id = - check Sig_component_kind.Extension_constructor loc t.bound.typexts id info - t.to_be_removed + check Sig_component_kind.Extension_constructor t loc id info let check_class ?(info=`Exported) t loc id = - check Sig_component_kind.Class loc t.bound.classes id info t.to_be_removed + check Sig_component_kind.Class t loc id info let check_class_type ?(info=`Exported) t loc id = - check Sig_component_kind.Class_type loc t.bound.class_types id info - t.to_be_removed - - let check_sig_item ?info names loc component = - let info id loc = + check Sig_component_kind.Class_type t loc id info + + let classify = + let open Sig_component_kind in + function + | Sig_type(id, _, _, _) -> Type, id + | Sig_module(id, _, _, _, _) -> Module, id + | Sig_modtype(id, _, _) -> Module_type, id + | Sig_typext(id, _, _, _) -> Extension_constructor, id + | Sig_value (id, _, _) -> Value, id + | Sig_class (id, _, _, _) -> Class, id + | Sig_class_type (id, _, _, _) -> Class_type, id + + let check_item ?info names loc kind id ids = + let info = match info with - | None -> `Shadowable (id, loc) + | None -> `Shadowable {self=id; group=ids; loc} | Some i -> i in - match component with - | Sig_type(id, _, _, _) -> - check_type names loc id ~info:(info id loc) - | Sig_module(id, _, _, _, _) -> - check_module names loc id ~info:(info id loc) - | Sig_modtype(id, _, _) -> - check_modtype names loc id ~info:(info id loc) - | Sig_typext(id, _, _, _) -> - check_typext names loc id ~info:(info id loc) - | Sig_value (id, _, _) -> - check_value names loc id ~info:(info id loc) - | Sig_class (id, _, _, _) -> - check_class names loc id ~info:(info id loc) - | Sig_class_type (id, _, _, _) -> - check_class_type names loc id ~info:(info id loc) + check kind names loc id info + + let check_sig_item ?info names loc (item:Signature_group.rec_group) = + let check ?info names loc item = + let all = List.map classify (Signature_group.flatten item) in + let group = List.map snd all in + List.iter (fun (kind,id) -> check_item ?info names loc kind id group) + all + in + (* we can ignore x.pre_ghosts: they are eliminated by strengthening, and + thus never appear in includes *) + List.iter (check ?info names loc) (Signature_group.rec_items item.group) + + (* + Before applying local module type substitutions where the + right-hand side is not a path, we need to check that those module types + where never used to pack modules. For instance + {[ + module type T := sig end + val x: (module T) + ]} + should raise an error. + *) + let check_unpackable_modtypes ~loc ~env to_remove component = + if not (Ident.Set.is_empty to_remove.unpackable_modtypes) then begin + let iterator = + let error p = Unpackable_local_modtype_subst p in + let paths = + List.map (fun id -> Pident id) + (Ident.Set.elements to_remove.unpackable_modtypes) + in + check_usage_of_module_types ~loc ~error ~paths + (ref (lazy env)) Btype.type_iterators + in + iterator.Btype.it_signature_item iterator component; + Btype.(unmark_iterators.it_signature_item unmark_iterators) component + end (* We usually require name uniqueness of signature components (e.g. types, modules, etc), however in some situation reusing the name is allowed: if @@ -1108,7 +1258,7 @@ end = struct lst ) to_remove.hide [] in - let aux component sg = + let simplify_item (component: Types.signature_item) = let user_kind, user_id, user_loc = let open Sig_component_kind in match component with @@ -1121,13 +1271,16 @@ end = struct | Sig_class_type (id, ct, _, _) -> Class_type, id, ct.clty_loc in if Ident.Map.mem user_id to_remove.hide then - sg + None else begin let component = if to_remove.subst == Subst.identity then component else - Subst.signature_item Keep to_remove.subst component + begin + check_unpackable_modtypes ~loc:user_loc ~env to_remove component; + Subst.signature_item Keep to_remove.subst component + end in let component = match ids_to_remove with @@ -1163,10 +1316,10 @@ end = struct in raise (Error(err_loc, env, Cannot_hide_id hiding_error)) in - component :: sg + Some component end in - List.fold_right aux sg [] + List.filter_map simplify_item sg end let has_remove_aliases_attribute attr = @@ -1262,13 +1415,7 @@ and transl_modtype_aux env smty = let init_sg = extract_sig env sbody.pmty_loc body.mty_type in let remove_aliases = has_remove_aliases_attribute smty.pmty_attributes in let (rev_tcstrs, final_sg) = - List.fold_left - (fun (rev_tcstrs,sg) sdecl -> - let (tcstr, sg) = - merge_constraint env remove_aliases smty.pmty_loc sg sdecl - in - (tcstr :: rev_tcstrs, sg) - ) + List.fold_left (transl_with ~loc:smty.pmty_loc env remove_aliases) ([],init_sg) constraints in let scope = Ctype.create_scope () in mkmty (Tmty_with ( body, List.rev rev_tcstrs)) @@ -1281,7 +1428,29 @@ and transl_modtype_aux env smty = | Pmty_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) -and transl_signature env sg = +and transl_with ~loc env remove_aliases (rev_tcstrs,sg) constr = + let lid, with_info = match constr with + | Pwith_type (l,decl) ->l , With_type decl + | Pwith_typesubst (l,decl) ->l , With_typesubst decl + | Pwith_module (l,l') -> + let path, md = Env.lookup_module ~loc l'.txt env in + l , With_module {lid=l';path;md; remove_aliases} + | Pwith_modsubst (l,l') -> + let path, md' = Env.lookup_module ~loc l'.txt env in + l , With_modsubst (l',path,md') + | Pwith_modtype (l,smty) -> + let mty = transl_modtype env smty in + l, With_modtype mty + | Pwith_modtypesubst (l,smty) -> + let mty = transl_modtype env smty in + l, With_modtypesubst mty + in + let (tcstr, sg) = merge_constraint env loc sg lid with_info in + (tcstr :: rev_tcstrs, sg) + + + +and transl_signature env (sg : Parsetree.signature) = let names = Signature_names.create () in let transl_sig_item env sig_acc item = let loc = item.psig_loc in @@ -1291,6 +1460,7 @@ and transl_signature env sg = Typedecl.transl_value_decl env item.psig_loc sdesc in Signature_names.check_value names tdesc.val_loc tdesc.val_id; + Env.register_uid tdesc.val_val.val_uid tdesc.val_loc; mksig (Tsig_value tdesc) env loc, [Sig_value(tdesc.val_id, tdesc.val_val, Exported)], newenv @@ -1299,7 +1469,9 @@ and transl_signature env sg = Typedecl.transl_type_decl env rec_flag sdecls in List.iter (fun td -> - Signature_names.check_type names td.typ_loc td.typ_id + Signature_names.check_type names td.typ_loc td.typ_id; + if not (Btype.is_row_name (Ident.name td.typ_id)) then + Env.register_uid td.typ_type.type_uid td.typ_loc ) decls; let sig_items = map_rec_type_with_row_types ~rec_flag @@ -1328,7 +1500,8 @@ and transl_signature env sg = in Some (`Substituted_away subst) in - Signature_names.check_type ?info names td.typ_loc td.typ_id + Signature_names.check_type ?info names td.typ_loc td.typ_id; + Env.register_uid td.typ_type.type_uid td.typ_loc ) decls; mksig (Tsig_typesubst decls) env loc, [], newenv | Psig_typext styext -> @@ -1337,7 +1510,8 @@ and transl_signature env sg = in let constructors = tyext.tyext_constructors in List.iter (fun ext -> - Signature_names.check_typext names ext.ext_loc ext.ext_id + Signature_names.check_typext names ext.ext_loc ext.ext_id; + Env.register_uid ext.ext_type.ext_uid ext.ext_loc ) constructors; let tsg = map_ext (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es, Exported) @@ -1351,6 +1525,9 @@ and transl_signature env sg = let constructor = ext.tyexn_constructor in Signature_names.check_typext names constructor.ext_loc constructor.ext_id; + Env.register_uid + constructor.ext_type.ext_uid + constructor.ext_loc; let tsg = Sig_typext(constructor.ext_id, constructor.ext_type, Text_exception, Exported) @@ -1382,6 +1559,7 @@ and transl_signature env sg = Env.enter_module_declaration ~scope name pres md env in Signature_names.check_module names pmd.pmd_name.loc id; + Env.register_uid md.md_uid md.md_loc; Some id, newenv in let sig_item = @@ -1426,6 +1604,7 @@ and transl_signature env sg = `Substituted_away (Subst.add_module id path Subst.identity) in Signature_names.check_module ~info names pms.pms_name.loc id; + Env.register_uid md.md_uid md.md_loc; let sig_item = mksig (Tsig_modsubst {ms_id=id; ms_name=pms.pms_name; ms_manifest=path; ms_txt=pms.pms_manifest; @@ -1438,14 +1617,15 @@ and transl_signature env sg = let (tdecls, newenv) = transl_recmodule_modtypes env sdecls in let decls = - List.filter_map (fun (md, uid) -> + List.filter_map (fun (md, uid, _) -> match md.md_id with | None -> None | Some id -> Some (id, md, uid) ) tdecls in - List.iter (fun (id, md, _) -> - Signature_names.check_module names md.md_loc id + List.iter (fun (id, md, uid) -> + Signature_names.check_module names md.md_loc id; + Env.register_uid uid md.md_loc ) decls; let sig_items = map_rec (fun rs (id, md, uid) -> @@ -1457,10 +1637,35 @@ and transl_signature env sg = Sig_module(id, Mp_present, d, rs, Exported)) decls [] in - mksig (Tsig_recmodule (List.map fst tdecls)) env loc, sig_items, newenv + mksig (Tsig_recmodule (List.map (fun (md, _, _) -> md) tdecls)) env loc, + sig_items, + newenv | Psig_modtype pmtd -> - let newenv, mtd, sg = transl_modtype_decl names env pmtd in - mksig (Tsig_modtype mtd) env loc, [sg], newenv + let newenv, mtd, decl = transl_modtype_decl env pmtd in + Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id; + Env.register_uid decl.mtd_uid mtd.mtd_loc; + mksig (Tsig_modtype mtd) env loc, + [Sig_modtype (mtd.mtd_id, decl, Exported)], + newenv + | Psig_modtypesubst pmtd -> + let newenv, mtd, decl = transl_modtype_decl env pmtd in + let info = + let mty = match mtd.mtd_type with + | Some tmty -> tmty.mty_type + | None -> + (* parsetree invariant, see Ast_invariants *) + assert false + in + let subst = Subst.add_modtype mtd.mtd_id mty Subst.identity in + match mty with + | Mty_ident _ -> `Substituted_away subst + | _ -> `Unpackable_modtype_substituted_away (mtd.mtd_id,subst) + in + Signature_names.check_modtype ~info names pmtd.pmtd_loc mtd.mtd_id; + Env.register_uid decl.mtd_uid mtd.mtd_loc; + mksig (Tsig_modtypesubst mtd) env loc, + [], + newenv | Psig_open sod -> let (od, newenv) = type_open_descr env sod in mksig (Tsig_open od) env loc, [], newenv @@ -1483,7 +1688,9 @@ and transl_signature env sg = Tincl_structure, extract_sig env smty.pmty_loc mty in let sg, newenv = Env.enter_signature ~scope sg env in - List.iter (Signature_names.check_sig_item names item.psig_loc) sg; + Signature_group.iter + (Signature_names.check_sig_item names item.psig_loc) + sg; let incl = { incl_mod = tmty; incl_type = sg; @@ -1502,6 +1709,7 @@ and transl_signature env sg = Signature_names.check_class names loc cls.cls_id; Signature_names.check_class_type names loc cls.cls_ty_id; Signature_names.check_type names loc cls.cls_typesharp_id; + Env.register_uid cls.cls_decl.cty_uid cls.cls_decl.cty_loc; ) classes; let tsg = map_rec (fun rs cls -> @@ -1526,6 +1734,9 @@ and transl_signature env sg = Signature_names.check_class_type names loc decl.clsty_ty_id; Signature_names.check_type names loc decl.clsty_obj_id; Signature_names.check_type names loc decl.clsty_typesharp_id; + Env.register_uid + decl.clsty_ty_decl.clty_uid + decl.clsty_ty_decl.clty_loc; ) classes; let tsg = map_rec (fun rs decl -> @@ -1548,6 +1759,7 @@ and transl_signature env sg = typedtree, tsg, newenv | Psig_attribute attr -> Builtin_attributes.parse_standard_interface_attributes attr; + Builtin_attributes.mark_alert_used attr; mksig (Tsig_attribute attr) env loc, [], env | Psig_extension (ext, _attrs) -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) @@ -1576,11 +1788,11 @@ and transl_signature env sg = sg ) -and transl_modtype_decl names env pmtd = +and transl_modtype_decl env pmtd = Builtin_attributes.warning_scope pmtd.pmtd_attributes - (fun () -> transl_modtype_decl_aux names env pmtd) + (fun () -> transl_modtype_decl_aux env pmtd) -and transl_modtype_decl_aux names env +and transl_modtype_decl_aux env {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} = let tmty = Option.map (transl_modtype (Env.in_signature true env)) pmtd_type @@ -1595,7 +1807,6 @@ and transl_modtype_decl_aux names env in let scope = Ctype.create_scope () in let (id, newenv) = Env.enter_modtype ~scope pmtd_name.txt decl env in - Signature_names.check_modtype names pmtd_loc id; let mtd = { mtd_id=id; @@ -1605,29 +1816,31 @@ and transl_modtype_decl_aux names env mtd_loc=pmtd_loc; } in - newenv, mtd, Sig_modtype(id, decl, Exported) + newenv, mtd, decl and transl_recmodule_modtypes env sdecls = let make_env curr = - List.fold_left - (fun env (id, _, md, _) -> - Option.fold ~none:env - ~some:(fun id -> Env.add_module_declaration ~check:true ~arg:true - id Mp_present md env) id) - env curr in + List.fold_left (fun env (id_shape, _, md, _) -> + Option.fold ~none:env ~some:(fun (id, shape) -> + Env.add_module_declaration ~check:true ~shape ~arg:true + id Mp_present md env + ) id_shape + ) env curr + in let transition env_c curr = List.map2 - (fun pmd (id, id_loc, md, _) -> + (fun pmd (id_shape, id_loc, md, _) -> let tmty = Builtin_attributes.warning_scope pmd.pmd_attributes (fun () -> transl_modtype env_c pmd.pmd_type) in let md = { md with Types.md_type = tmty.mty_type } in - (id, id_loc, md, tmty)) + (id_shape, id_loc, md, tmty)) sdecls curr in let map_mtys curr = List.filter_map - (fun (id, _, md, _) -> Option.map (fun id -> (id, md)) id) + (fun (id_shape, _, md, _) -> + Option.map (fun (id, _) -> (id, md)) id_shape) curr in let scope = Ctype.create_scope () in @@ -1647,13 +1860,17 @@ and transl_recmodule_modtypes env sdecls = let init = List.map2 (fun id pmd -> + let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in let md = { md_type = approx_modtype approx_env pmd.pmd_type; md_loc = pmd.pmd_loc; md_attributes = pmd.pmd_attributes; - md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) } + md_uid } + in + let id_shape = + Option.map (fun id -> id, Shape.var md_uid id) id in - (id, pmd.pmd_name, md, ())) + (id_shape, pmd.pmd_name, md, ())) ids sdecls in let env0 = make_env init in @@ -1673,14 +1890,14 @@ and transl_recmodule_modtypes env sdecls = let env2 = make_env dcl2 in check_recmod_typedecls env2 (map_mtys dcl2); let dcl2 = - List.map2 (fun pmd (id, id_loc, md, mty) -> + List.map2 (fun pmd (id_shape, id_loc, md, mty) -> let tmd = - {md_id=id; md_name=id_loc; md_type=mty; + {md_id=Option.map fst id_shape; md_name=id_loc; md_type=mty; md_presence=Mp_present; md_loc=pmd.pmd_loc; md_attributes=pmd.pmd_attributes} in - tmd, md.md_uid + tmd, md.md_uid, Option.map snd id_shape ) sdecls dcl2 in (dcl2, env2) @@ -1701,14 +1918,15 @@ let rec path_of_module mexp = let path_of_module mexp = try Some (path_of_module mexp) with Not_a_path -> None -(* Check that all core type schemes in a structure are closed *) +(* Check that all core type schemes in a structure + do not contain non-generalized type variable *) -let rec check_modtype env f = function - Mty_ident _ -> true - | Mty_alias _ -> true +let rec nongen_modtype env f = function + Mty_ident _ -> false + | Mty_alias _ -> false | Mty_signature sg -> let env = Env.add_signature sg env in - List.for_all (check_signature_item env f) sg + List.exists (nongen_signature_item env f) sg | Mty_functor(arg_opt, body) -> let env = match arg_opt with @@ -1717,36 +1935,29 @@ let rec check_modtype env f = function | Named (Some id, param) -> Env.add_module ~arg:true id Mp_present param env in - check_modtype env f body + nongen_modtype env f body -and check_signature_item env f = function - Sig_value(_id, desc, _) -> f desc.val_type - | Sig_module(_id, _, md, _, _) -> check_modtype env f md.md_type - | _ -> true +and nongen_signature_item env f = function + Sig_value(_id, desc, _) -> f env desc.val_type + | Sig_module(_id, _, md, _, _) -> nongen_modtype env f md.md_type + | _ -> false -let check_nongen_scheme env sig_item = - let check ty = - Ctype.remove_mode_variables ty; Ctype.closed_schema env ty - in - let ok = check_signature_item env check sig_item in +let check_nongen_signature_item env sig_item = match sig_item with - Sig_value(_id, vd, _) when not ok -> - raise (Error (vd.val_loc, env, Non_generalizable vd.val_type)) - | Sig_module (_id, _, md, _, _) when not ok -> - raise(Error(md.md_loc, env, Non_generalizable_module md.md_type)) + Sig_value(_id, vd, _) -> + if Ctype.nongen_schema env vd.val_type then + raise (Error (vd.val_loc, env, Non_generalizable vd.val_type)) + | Sig_module (_id, _, md, _, _) -> + if nongen_modtype env Ctype.nongen_schema md.md_type then + raise(Error(md.md_loc, env, Non_generalizable_module md.md_type)) | _ -> () -let check_nongen_schemes env sg = - List.iter (check_nongen_scheme env) sg - -let closed_modtype env mty = - let check ty = - Ctype.remove_mode_variables ty; Ctype.closed_schema env ty - in check_modtype env check mty +let check_nongen_signature env sg = + List.iter (check_nongen_signature_item env) sg let remove_mode_variables env sg = - let rm ty = Ctype.remove_mode_variables ty; true in - List.for_all (check_signature_item env rm) sg |> ignore + let rm _env ty = Ctype.remove_mode_variables ty; false in + List.exists (nongen_signature_item env rm) sg |> ignore (* Helpers for typing recursive modules *) @@ -1818,18 +2029,19 @@ let check_recmodule_inclusion env bindings = (* Generate fresh names Y_i for the rec. bound module idents X_i *) let bindings1 = List.map - (fun (id, _name, _mty_decl, _modl, mty_actual, _attrs, _loc, _uid) -> + (fun (id, _name, _mty_decl, _modl, + mty_actual, _attrs, _loc, shape, _uid) -> let ids = Option.map (fun id -> (id, Ident.create_scoped ~scope (Ident.name id))) id in - (ids, mty_actual)) + (ids, mty_actual, shape)) bindings in (* Enter the Y_i in the environment with their actual types substituted by the input substitution s *) let env' = List.fold_left - (fun env (ids, mty_actual) -> + (fun env (ids, mty_actual, shape) -> match ids with | None -> env | Some (id, id') -> @@ -1838,12 +2050,12 @@ let check_recmodule_inclusion env bindings = then mty_actual else subst_and_strengthen env scope s (Some id) mty_actual in - Env.add_module ~arg:false id' Mp_present mty_actual' env) + Env.add_module ~arg:false ~shape id' Mp_present mty_actual' env) env bindings1 in (* Build the output substitution Y_i <- X_i *) let s' = List.fold_left - (fun s (ids, _mty_actual) -> + (fun s (ids, _mty_actual, _shape) -> match ids with | None -> s | Some (id, id') -> Subst.add_module id (Pident id') s) @@ -1854,13 +2066,14 @@ let check_recmodule_inclusion env bindings = (* Base case: check inclusion of s(mty_actual) in s(mty_decl) and insert coercion if needed *) let check_inclusion - (id, name, mty_decl, modl, mty_actual, attrs, loc, uid) = + (id, name, mty_decl, modl, mty_actual, attrs, loc, shape, uid) = let mty_decl' = Subst.modtype (Rescope scope) s mty_decl.mty_type and mty_actual' = subst_and_strengthen env scope s id mty_actual in - let coercion = + let coercion, shape = try - Includemod.modtypes ~loc:modl.mod_loc ~mark:Mark_both env - mty_actual' mty_decl' + Includemod.modtypes_with_shape ~shape + ~loc:modl.mod_loc ~mark:Mark_both + env mty_actual' mty_decl' with Includemod.Error msg -> raise(Error(modl.mod_loc, env, Not_included msg)) in let modl' = @@ -1881,7 +2094,7 @@ let check_recmodule_inclusion env bindings = mb_loc = loc; } in - mb, uid + mb, shape, uid in List.map check_inclusion bindings end @@ -1923,19 +2136,22 @@ and package_constraints env loc mty constrs = | Mty_ident p -> raise(Error(loc, env, Cannot_scrape_package_type p)) end -let modtype_of_package env loc p nl tl = - package_constraints env loc (Mty_ident p) - (List.combine (List.map Longident.flatten nl) tl) - -let package_subtype env p1 nl1 tl1 p2 nl2 tl2 = - let mkmty p nl tl = - let ntl = - List.filter (fun (_n,t) -> Ctype.free_variables t = []) - (List.combine nl tl) in - let (nl, tl) = List.split ntl in - modtype_of_package env Location.none p nl tl +let modtype_of_package env loc p fl = + (* We call Ctype.correct_levels to ensure that the types being added to the + module type are at generic_level. *) + let mty = + package_constraints env loc (Mty_ident p) + (List.map (fun (n, t) -> Longident.flatten n, Ctype.correct_levels t) fl) + in + Subst.modtype Keep Subst.identity mty + +let package_subtype env p1 fl1 p2 fl2 = + let mkmty p fl = + let fl = + List.filter (fun (_n,t) -> Ctype.free_variables t = []) fl in + modtype_of_package env Location.none p fl in - match mkmty p1 nl1 tl1, mkmty p2 nl2 tl2 with + match mkmty p1 fl1, mkmty p2 fl2 with | exception Error(_, _, Cannot_scrape_package_type _) -> false | mty1, mty2 -> let loc = Location.none in @@ -1947,9 +2163,11 @@ let () = Ctype.package_subtype := package_subtype let wrap_constraint env mark arg mty explicit = let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in + let mty1 = Subst.modtype Keep Subst.identity arg.mod_type in + let mty2 = Subst.modtype Keep Subst.identity mty in let coercion = try - Includemod.modtypes ~loc:arg.mod_loc env ~mark arg.mod_type mty + Includemod.modtypes ~loc:arg.mod_loc env ~mark mty1 mty2 with Includemod.Error msg -> raise(Error(arg.mod_loc, env, Not_included msg)) in { mod_desc = Tmod_constraint(arg, mty, explicit, coercion); @@ -1958,8 +2176,42 @@ let wrap_constraint env mark arg mty explicit = mod_attributes = []; mod_loc = arg.mod_loc } +let wrap_constraint_with_shape env mark arg mty + shape explicit = + let mark = if mark then Includemod.Mark_both else Includemod.Mark_neither in + let coercion, shape = + try + Includemod.modtypes_with_shape ~shape ~loc:arg.mod_loc env ~mark + arg.mod_type mty + with Includemod.Error msg -> + raise(Error(arg.mod_loc, env, Not_included msg)) in + { mod_desc = Tmod_constraint(arg, mty, explicit, coercion); + mod_type = mty; + mod_env = env; + mod_attributes = []; + mod_loc = arg.mod_loc }, shape + (* Type a module value expression *) + +(* Summary for F(X) *) +type application_summary = { + loc: Location.t; + attributes: attributes; + f_loc: Location.t; (* loc for F *) + arg_is_syntactic_unit: bool; + arg: Typedtree.module_expr; + arg_path: Path.t option; + shape: Shape.t +} + +let simplify_app_summary app_view = + let mty = app_view.arg.mod_type in + match app_view.arg_is_syntactic_unit , app_view.arg_path with + | true, _ -> Includemod.Error.Unit, mty + | false, Some p -> Includemod.Error.Named p, mty + | false, None -> Includemod.Error.Anonymous, mty + let rec type_module ?(alias=false) sttn funct_body anchor env smod = Builtin_attributes.warning_scope smod.pmod_attributes (fun () -> type_module_aux ~alias sttn funct_body anchor env smod) @@ -1976,30 +2228,36 @@ and type_module_aux ~alias sttn funct_body anchor env smod = mod_attributes = smod.pmod_attributes; mod_loc = smod.pmod_loc } in let aliasable = not (Env.is_functor_arg path env) in - if alias && aliasable then - (Env.add_required_global (Path.head path); md) - else begin - let mty = - if sttn then - Env.find_strengthened_module ~aliasable path env - else - (Env.find_module path env).md_type - in - match mty with - | Mty_alias p1 when not alias -> - let p1 = Env.normalize_module_path (Some smod.pmod_loc) env p1 in - let mty = Includemod.expand_module_alias - ~strengthen:sttn env [] p1 in - { md with - mod_desc = - Tmod_constraint (md, mty, Tmodtype_implicit, - Tcoerce_alias (env, path, Tcoerce_none)); - mod_type = mty } - | mty -> - { md with mod_type = mty } - end + let shape = + Env.shape_of_path ~namespace:Shape.Sig_component_kind.Module env path + in + let md = + if alias && aliasable then + (Env.add_required_global path env; md) + else begin + let mty = + if sttn then + Env.find_strengthened_module ~aliasable path env + else + (Env.find_module path env).md_type + in + match mty with + | Mty_alias p1 when not alias -> + let p1 = Env.normalize_module_path (Some smod.pmod_loc) env p1 in + let mty = Includemod.expand_module_alias + ~strengthen:sttn env p1 in + { md with + mod_desc = + Tmod_constraint (md, mty, Tmodtype_implicit, + Tcoerce_alias (env, path, Tcoerce_none)); + mod_type = mty } + | mty -> + { md with mod_type = mty } + end + in + md, shape | Pmod_structure sstr -> - let (str, sg, names, _finalenv) = + let (str, sg, names, shape, _finalenv) = type_structure funct_body anchor env sstr in let md = { mod_desc = Tmod_structure str; @@ -2009,130 +2267,61 @@ and type_module_aux ~alias sttn funct_body anchor env smod = mod_loc = smod.pmod_loc } in let sg' = Signature_names.simplify _finalenv names sg in - if List.length sg' = List.length sg then md else - wrap_constraint env false md (Mty_signature sg') - Tmodtype_implicit + if List.length sg' = List.length sg then md, shape else + wrap_constraint_with_shape env false md + (Mty_signature sg') shape Tmodtype_implicit | Pmod_functor(arg_opt, sbody) -> - let t_arg, ty_arg, newenv, funct_body = + let t_arg, ty_arg, newenv, funct_shape_param, funct_body = match arg_opt with - | Unit -> Unit, Types.Unit, env, false + | Unit -> + Unit, Types.Unit, env, Shape.for_unnamed_functor_param, false | Named (param, smty) -> let mty = transl_modtype_functor_arg env smty in let scope = Ctype.create_scope () in - let (id, newenv) = + let (id, newenv, var) = match param.txt with - | None -> None, env + | None -> None, env, Shape.for_unnamed_functor_param | Some name -> + let md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()) in let arg_md = { md_type = mty.mty_type; md_attributes = []; md_loc = param.loc; - md_uid = Uid.mk ~current_unit:(Env.get_unit_name ()); + md_uid; } in - let id, newenv = - Env.enter_module_declaration ~scope ~arg:true name Mp_present - arg_md env + let id = Ident.create_scoped ~scope name in + let shape = Shape.var md_uid id in + let newenv = Env.add_module_declaration + ~shape ~arg:true ~check:true id Mp_present arg_md env in - Some id, newenv + Some id, newenv, id in - Named (id, param, mty), Types.Named (id, mty.mty_type), newenv, true + Named (id, param, mty), Types.Named (id, mty.mty_type), newenv, + var, true in let newenv = Env.add_lock Value_mode.global newenv in - let body = type_module sttn funct_body None newenv sbody in + let body, body_shape = type_module true funct_body None newenv sbody in { mod_desc = Tmod_functor(t_arg, body); mod_type = Mty_functor(ty_arg, body.mod_type); mod_env = env; mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } - | Pmod_apply(sfunct, sarg) -> - let arg = type_module true funct_body None env sarg in - let path = path_of_module arg in - let funct = - type_module (sttn && path <> None) funct_body None env sfunct in - begin match Env.scrape_alias env funct.mod_type with - | Mty_functor (Unit, mty_res) -> - if sarg.pmod_desc <> Pmod_structure [] then - raise (Error (sfunct.pmod_loc, env, Apply_generative)); - if funct_body && Mtype.contains_type env funct.mod_type then - raise (Error (smod.pmod_loc, env, Not_allowed_in_functor_body)); - { mod_desc = Tmod_apply(funct, arg, Tcoerce_none); - mod_type = mty_res; - mod_env = env; - mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } - | Mty_functor (Named (param, mty_param), mty_res) as mty_functor -> - let coercion = - try - Includemod.modtypes ~loc:sarg.pmod_loc ~mark:Mark_both env - arg.mod_type mty_param - with Includemod.Error msg -> - raise(Error(sarg.pmod_loc, env, Not_included msg)) in - let mty_appl = - match path with - | Some path -> - let scope = Ctype.create_scope () in - let subst = - match param with - | None -> Subst.identity - | Some p -> Subst.add_module p path Subst.identity - in - Subst.modtype (Rescope scope) subst mty_res - | None -> - let env, nondep_mty = - match param with - | None -> env, mty_res - | Some param -> - let env = - Env.add_module ~arg:true param Mp_present arg.mod_type - env - in - check_well_formed_module env smod.pmod_loc - "the signature of this functor application" mty_res; - try env, Mtype.nondep_supertype env [param] mty_res - with Ctype.Nondep_cannot_erase _ -> - raise(Error(smod.pmod_loc, env, - Cannot_eliminate_dependency - (Functor_applied, mty_functor))) - in - begin match - Includemod.modtypes ~mark:Mark_neither - ~loc:smod.pmod_loc env mty_res nondep_mty - with - | Tcoerce_none -> () - | _ -> - fatal_error - "unexpected coercion from original module type to \ - nondep_supertype one" - | exception Includemod.Error _ -> - fatal_error - "nondep_supertype not included in original module type" - end; - nondep_mty - in - check_well_formed_module env smod.pmod_loc - "the signature of this functor application" mty_appl; - { mod_desc = Tmod_apply(funct, arg, coercion); - mod_type = mty_appl; - mod_env = env; - mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } - | Mty_alias path -> - raise(Error(sfunct.pmod_loc, env, Cannot_scrape_alias path)) - | _ -> - raise(Error(sfunct.pmod_loc, env, Cannot_apply funct.mod_type)) - end + mod_loc = smod.pmod_loc }, + Shape.abs funct_shape_param body_shape + | Pmod_apply _ -> + type_application smod.pmod_loc sttn funct_body env smod | Pmod_constraint(sarg, smty) -> - let arg = type_module ~alias true funct_body anchor env sarg in + let arg, arg_shape = type_module ~alias true funct_body anchor env sarg in let mty = transl_modtype env smty in - let md = - wrap_constraint env true arg mty.mty_type (Tmodtype_explicit mty) + let md, final_shape = + wrap_constraint_with_shape env true arg mty.mty_type arg_shape + (Tmodtype_explicit mty) in { md with mod_loc = smod.pmod_loc; mod_attributes = smod.pmod_attributes; - } - + }, + final_shape | Pmod_unpack sexp -> if !Clflags.principal then Ctype.begin_def (); let exp = Typecore.type_exp env sexp in @@ -2141,9 +2330,9 @@ and type_module_aux ~alias sttn funct_body anchor env smod = Ctype.generalize_structure exp.exp_type end; let mty = - match Ctype.expand_head env exp.exp_type with - {desc = Tpackage (p, nl, tl)} -> - if List.exists (fun t -> Ctype.free_variables t <> []) tl then + match get_desc (Ctype.expand_head env exp.exp_type) with + Tpackage (p, fl) -> + if List.exists (fun (_n, t) -> Ctype.free_variables t <> []) fl then raise (Error (smod.pmod_loc, env, Incomplete_packed_module exp.exp_type)); if !Clflags.principal && @@ -2151,8 +2340,8 @@ and type_module_aux ~alias sttn funct_body anchor env smod = then Location.prerr_warning smod.pmod_loc (Warnings.Not_principal "this module unpacking"); - modtype_of_package env smod.pmod_loc p nl tl - | {desc = Tvar _} -> + modtype_of_package env smod.pmod_loc p fl + | Tvar _ -> raise (Typecore.Error (smod.pmod_loc, env, Typecore.Cannot_infer_signature)) | _ -> @@ -2164,10 +2353,123 @@ and type_module_aux ~alias sttn funct_body anchor env smod = mod_type = mty; mod_env = env; mod_attributes = smod.pmod_attributes; - mod_loc = smod.pmod_loc } + mod_loc = smod.pmod_loc }, + Shape.leaf_for_unpack | Pmod_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) +and type_application loc strengthen funct_body env smod = + let rec extract_application funct_body env sargs smod = + match smod.pmod_desc with + | Pmod_apply(f, sarg) -> + let arg, shape = type_module true funct_body None env sarg in + let summary = + { loc=smod.pmod_loc; + attributes=smod.pmod_attributes; + f_loc = f.pmod_loc; + arg_is_syntactic_unit = sarg.pmod_desc = Pmod_structure []; + arg; + arg_path = path_of_module arg; + shape + } + in + extract_application funct_body env (summary::sargs) f + | _ -> smod, sargs + in + let sfunct, args = extract_application funct_body env [] smod in + let funct, funct_shape = + let strengthen = + strengthen && List.for_all (fun {arg_path;_} -> arg_path <> None) args + in + type_module strengthen funct_body None env sfunct + in + List.fold_left (type_one_application ~ctx:(loc, funct, args) funct_body env) + (funct, funct_shape) args + +and type_one_application ~ctx:(apply_loc,md_f,args) + funct_body env (funct, funct_shape) app_view = + match Env.scrape_alias env funct.mod_type with + | Mty_functor (Unit, mty_res) -> + if not app_view.arg_is_syntactic_unit then + raise (Error (app_view.f_loc, env, Apply_generative)); + if funct_body && Mtype.contains_type env funct.mod_type then + raise (Error (apply_loc, env, Not_allowed_in_functor_body)); + { mod_desc = Tmod_apply(funct, app_view.arg, Tcoerce_none); + mod_type = mty_res; + mod_env = env; + mod_attributes = app_view.attributes; + mod_loc = funct.mod_loc }, + Shape.app funct_shape ~arg:app_view.shape + | Mty_functor (Named (param, mty_param), mty_res) as mty_functor -> + let coercion = + try + Includemod.modtypes + ~loc:app_view.arg.mod_loc ~mark:Mark_both env + app_view.arg.mod_type mty_param + with Includemod.Error _ -> + let args = List.map simplify_app_summary args in + let mty_f = md_f.mod_type in + let lid_app = None in + raise(Includemod.Apply_error {loc=apply_loc;env;lid_app;mty_f;args}) + in + let mty_appl = + match app_view.arg_path with + | Some path -> + let scope = Ctype.create_scope () in + let subst = + match param with + | None -> Subst.identity + | Some p -> Subst.add_module p path Subst.identity + in + Subst.modtype (Rescope scope) subst mty_res + | None -> + let env, nondep_mty = + match param with + | None -> env, mty_res + | Some param -> + let env = + Env.add_module ~arg:true param Mp_present + app_view.arg.mod_type env + in + check_well_formed_module env app_view.loc + "the signature of this functor application" mty_res; + try env, Mtype.nondep_supertype env [param] mty_res + with Ctype.Nondep_cannot_erase _ -> + let error = Cannot_eliminate_dependency + (Functor_applied, mty_functor) in + raise (Error(app_view.loc, env, error)) + in + begin match + Includemod.modtypes + ~loc:app_view.loc ~mark:Mark_neither env mty_res nondep_mty + with + | Tcoerce_none -> () + | _ -> + fatal_error + "unexpected coercion from original module type to \ + nondep_supertype one" + | exception Includemod.Error _ -> + fatal_error + "nondep_supertype not included in original module type" + end; + nondep_mty + in + check_well_formed_module env apply_loc + "the signature of this functor application" mty_appl; + { mod_desc = Tmod_apply(funct, app_view.arg, coercion); + mod_type = mty_appl; + mod_env = env; + mod_attributes = app_view.attributes; + mod_loc = app_view.loc }, + Shape.app ~arg:app_view.shape funct_shape + | Mty_alias path -> + raise(Error(app_view.f_loc, env, Cannot_scrape_alias path)) + | _ -> + let args = List.map simplify_app_summary args in + let mty_f = md_f.mod_type in + let lid_app = None in + raise(Includemod.Apply_error {loc=apply_loc;env;lid_app;mty_f;args}) + and type_open_decl ?used_slot ?toplevel funct_body names env sod = Builtin_attributes.warning_scope sod.popen_attributes (fun () -> @@ -2197,18 +2499,18 @@ and type_open_decl_aux ?used_slot ?toplevel funct_body names env od = } in open_descr, [], newenv | _ -> - let md = type_module true funct_body None env od.popen_expr in + let md, mod_shape = type_module true funct_body None env od.popen_expr in let scope = Ctype.create_scope () in let sg, newenv = - Env.enter_signature ~scope (extract_sig_open env md.mod_loc md.mod_type) - env + Env.enter_signature ~scope ~mod_shape + (extract_sig_open env md.mod_loc md.mod_type) env in let info, visibility = match toplevel with | Some false | None -> Some `From_open, Hidden | Some true -> None, Exported in - List.iter (Signature_names.check_sig_item ?info names loc) sg; + Signature_group.iter (Signature_names.check_sig_item ?info names loc) sg; let sg = List.map (function | Sig_value(id, vd, _) -> Sig_value(id, vd, visibility) @@ -2235,14 +2537,14 @@ and type_open_decl_aux ?used_slot ?toplevel funct_body names env od = and type_structure ?(toplevel = None) funct_body anchor env sstr = let names = Signature_names.create () in - let type_str_item env {pstr_loc = loc; pstr_desc = desc} sig_acc = + let type_str_item env shape_map {pstr_loc = loc; pstr_desc = desc} sig_acc = match desc with | Pstr_eval (sexpr, attrs) -> let expr = Builtin_attributes.warning_scope attrs (fun () -> Typecore.type_expression env sexpr) in - Tstr_eval (expr, attrs), [], env + Tstr_eval (expr, attrs), [], shape_map, env | Pstr_value(rec_flag, sdefs) -> let (defs, newenv) = Typecore.type_binding env rec_flag sdefs in @@ -2257,62 +2559,99 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = end; (* Note: Env.find_value does not trigger the value_used event. Values will be marked as being used during the signature inclusion test. *) + let items, shape_map = + List.fold_left + (fun (acc, shape_map) (id, modes) -> + List.iter + (fun (loc, mode) -> Typecore.escape ~loc ~env:newenv mode) + modes; + let (first_loc, _) = List.hd modes in + Signature_names.check_value names first_loc id; + let vd = Env.find_value (Pident id) newenv in + Env.register_uid vd.val_uid vd.val_loc; + Sig_value(id, vd, Exported) :: acc, + Shape.Map.add_value shape_map id vd.val_uid + ) + ([], shape_map) + (let_bound_idents_with_modes defs) + in Tstr_value(rec_flag, defs), - List.map (fun (id, modes) -> - List.iter - (fun (loc, mode) -> Typecore.escape ~loc ~env:newenv mode) - modes; - let (first_loc, _) = List.hd modes in - Signature_names.check_value names first_loc id; - Sig_value(id, Env.find_value (Pident id) newenv, Exported) - ) (let_bound_idents_with_modes defs), + List.rev items, + shape_map, newenv | Pstr_primitive sdesc -> let (desc, newenv) = Typedecl.transl_value_decl env loc sdesc in Signature_names.check_value names desc.val_loc desc.val_id; + Env.register_uid desc.val_val.val_uid desc.val_val.val_loc; Tstr_primitive desc, [Sig_value(desc.val_id, desc.val_val, Exported)], + Shape.Map.add_value shape_map desc.val_id desc.val_val.val_uid, newenv | Pstr_type (rec_flag, sdecls) -> let (decls, newenv) = Typedecl.transl_type_decl env rec_flag sdecls in List.iter Signature_names.(fun td -> check_type names td.typ_loc td.typ_id) decls; - Tstr_type (rec_flag, decls), - map_rec_type_with_row_types ~rec_flag + let items = map_rec_type_with_row_types ~rec_flag (fun rs info -> Sig_type(info.typ_id, info.typ_type, rs, Exported)) - decls, + decls + in + let shape_map = List.fold_left + (fun shape_map -> function + | Sig_type (id, vd, _, _) -> + if not (Btype.is_row_name (Ident.name id)) then begin + Env.register_uid vd.type_uid vd.type_loc; + Shape.Map.add_type shape_map id vd.type_uid + end else shape_map + | _ -> assert false + ) + shape_map + items + in + Tstr_type (rec_flag, decls), + items, + shape_map, enrich_type_decls anchor decls env newenv | Pstr_typext styext -> let (tyext, newenv) = Typedecl.transl_type_extension true env loc styext in let constructors = tyext.tyext_constructors in - List.iter - Signature_names.(fun ext -> check_typext names ext.ext_loc ext.ext_id) - constructors; + let shape_map = List.fold_left (fun shape_map ext -> + Signature_names.check_typext names ext.ext_loc ext.ext_id; + Env.register_uid ext.ext_type.ext_uid ext.ext_loc; + Shape.Map.add_extcons shape_map ext.ext_id ext.ext_type.ext_uid + ) shape_map constructors + in (Tstr_typext tyext, map_ext (fun es ext -> Sig_typext(ext.ext_id, ext.ext_type, es, Exported)) constructors, + shape_map, newenv) | Pstr_exception sext -> let (ext, newenv) = Typedecl.transl_type_exception env sext in let constructor = ext.tyexn_constructor in Signature_names.check_typext names constructor.ext_loc constructor.ext_id; + Env.register_uid + constructor.ext_type.ext_uid + constructor.ext_loc; Tstr_exception ext, [Sig_typext(constructor.ext_id, constructor.ext_type, Text_exception, Exported)], + Shape.Map.add_extcons shape_map + constructor.ext_id + constructor.ext_type.ext_uid, newenv | Pstr_module {pmb_name = name; pmb_expr = smodl; pmb_attributes = attrs; pmb_loc; } -> let outer_scope = Ctype.get_current_level () in let scope = Ctype.create_scope () in - let modl = + let modl, md_shape = Builtin_attributes.warning_scope attrs (fun () -> type_module ~alias:true true funct_body @@ -2332,13 +2671,17 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = md_uid; } in + let md_shape = Shape.set_uid_if_none md_shape md_uid in + Env.register_uid md_uid pmb_loc; (*prerr_endline (Ident.unique_toplevel_name id);*) Mtype.lower_nongen outer_scope md.md_type; let id, newenv, sg = match name.txt with | None -> None, env, [] | Some name -> - let id, e = Env.enter_module_declaration ~scope name pres md env in + let id, e = Env.enter_module_declaration + ~scope ~shape:md_shape name pres md env + in Signature_names.check_module names pmb_loc id; Some id, e, [Sig_module(id, pres, @@ -2348,9 +2691,14 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = md_uid; }, Trec_not, Exported)] in + let shape_map = match id with + | Some id -> Shape.Map.add_module shape_map id md_shape + | None -> shape_map + in Tstr_module {mb_id=id; mb_name=name; mb_expr=modl; mb_presence=pres; mb_attributes=attrs; mb_loc=pmb_loc; }, sg, + shape_map, newenv | Pstr_recmodule sbind -> let sbind = @@ -2375,13 +2723,14 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = pmd_attributes=attrs; pmd_loc=loc}) sbind ) in List.iter - (fun (md, _) -> - Option.iter Signature_names.(check_module names md.md_loc) md.md_id) - decls; + (fun (md, _, _) -> + Option.iter Signature_names.(check_module names md.md_loc) md.md_id + ) decls; let bindings1 = List.map2 - (fun ({md_id=id; md_type=mty}, uid) (name, _, smodl, attrs, loc) -> - let modl = + (fun ({md_id=id; md_type=mty}, uid, _prev_shape) + (name, _, smodl, attrs, loc) -> + let modl, shape = Builtin_attributes.warning_scope attrs (fun () -> type_module true funct_body (anchor_recmodule id) @@ -2391,36 +2740,42 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = let mty' = enrich_module_type anchor name.txt modl.mod_type newenv in - (id, name, mty, modl, mty', attrs, loc, uid)) + (id, name, mty, modl, mty', attrs, loc, shape, uid)) decls sbind in let newenv = (* allow aliasing recursive modules from outside *) List.fold_left - (fun env (md, uid) -> - match md.md_id with + (fun env (id_opt, _, mty, _, _, attrs, loc, shape, uid) -> + match id_opt with | None -> env | Some id -> let mdecl = { - md_type = md.md_type.mty_type; - md_attributes = md.md_attributes; - md_loc = md.md_loc; + md_type = mty.mty_type; + md_attributes = attrs; + md_loc = loc; md_uid = uid; } in - Env.add_module_declaration ~check:true + Env.add_module_declaration ~check:true ~shape id Mp_present mdecl env ) - env decls + env bindings1 in let bindings2 = check_recmodule_inclusion newenv bindings1 in let mbs = - List.filter_map (fun (mb, uid) -> - Option.map (fun id -> id, mb, uid) mb.mb_id + List.filter_map (fun (mb, shape, uid) -> + Option.map (fun id -> id, mb, uid, shape) mb.mb_id ) bindings2 in - Tstr_recmodule (List.map fst bindings2), - map_rec (fun rs (id, mb, uid) -> + let shape_map = + List.fold_left (fun map (id, mb, uid, shape) -> + Env.register_uid uid mb.mb_loc; + Shape.Map.add_module map id shape + ) shape_map mbs + in + Tstr_recmodule (List.map (fun (mb, _, _) -> mb) bindings2), + map_rec (fun rs (id, mb, uid, _shape) -> Sig_module(id, Mp_present, { md_type=mb.mb_expr.mod_type; md_attributes=mb.mb_attributes; @@ -2428,39 +2783,43 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = md_uid = uid; }, rs, Exported)) mbs [], + shape_map, newenv | Pstr_modtype pmtd -> (* check that it is non-abstract *) - let newenv, mtd, sg = transl_modtype_decl names env pmtd in - Tstr_modtype mtd, [sg], newenv + let newenv, mtd, decl = transl_modtype_decl env pmtd in + Signature_names.check_modtype names pmtd.pmtd_loc mtd.mtd_id; + Env.register_uid decl.mtd_uid decl.mtd_loc; + let id = mtd.mtd_id in + let map = Shape.Map.add_module_type shape_map id decl.mtd_uid in + Tstr_modtype mtd, [Sig_modtype (id, decl, Exported)], map, newenv | Pstr_open sod -> let toplevel = Option.is_some toplevel in let (od, sg, newenv) = type_open_decl ~toplevel funct_body names env sod in - Tstr_open od, sg, newenv + Tstr_open od, sg, shape_map, newenv | Pstr_class cl -> let (classes, new_env) = Typeclass.class_declarations env cl in - List.iter (fun cls -> - let open Typeclass in - let loc = cls.cls_id_loc.Location.loc in - Signature_names.check_class names loc cls.cls_id; - Signature_names.check_class_type names loc cls.cls_ty_id; - Signature_names.check_type names loc cls.cls_obj_id; - Signature_names.check_type names loc cls.cls_typesharp_id; - ) classes; + let shape_map = List.fold_left (fun acc cls -> + let open Typeclass in + let loc = cls.cls_id_loc.Location.loc in + Signature_names.check_class names loc cls.cls_id; + Signature_names.check_class_type names loc cls.cls_ty_id; + Signature_names.check_type names loc cls.cls_obj_id; + Signature_names.check_type names loc cls.cls_typesharp_id; + Env.register_uid cls.cls_decl.cty_uid loc; + let map f id acc = f acc id cls.cls_decl.cty_uid in + map Shape.Map.add_class cls.cls_id acc + |> map Shape.Map.add_class_type cls.cls_ty_id + |> map Shape.Map.add_type cls.cls_obj_id + |> map Shape.Map.add_type cls.cls_typesharp_id + ) shape_map classes + in Tstr_class (List.map (fun cls -> (cls.Typeclass.cls_info, cls.Typeclass.cls_pub_methods)) classes), -(* TODO: check with Jacques why this is here - Tstr_class_type - (List.map (fun (_,_, i, d, _,_,_,_,_,_,c) -> (i, c)) classes) :: - Tstr_type - (List.map (fun (_,_,_,_, i, d, _,_,_,_,_) -> (i, d)) classes) :: - Tstr_type - (List.map (fun (_,_,_,_,_,_, i, d, _,_,_) -> (i, d)) classes) :: -*) List.flatten (map_rec (fun rs cls -> @@ -2470,26 +2829,28 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = Sig_type(cls.cls_obj_id, cls.cls_obj_abbr, rs, Exported); Sig_type(cls.cls_typesharp_id, cls.cls_abbr, rs, Exported)]) classes []), + shape_map, new_env | Pstr_class_type cl -> let (classes, new_env) = Typeclass.class_type_declarations env cl in - List.iter (fun decl -> - let open Typeclass in - let loc = decl.clsty_id_loc.Location.loc in - Signature_names.check_class_type names loc decl.clsty_ty_id; - Signature_names.check_type names loc decl.clsty_obj_id; - Signature_names.check_type names loc decl.clsty_typesharp_id; - ) classes; + let shape_map = List.fold_left (fun acc decl -> + let open Typeclass in + let loc = decl.clsty_id_loc.Location.loc in + Signature_names.check_class_type names loc decl.clsty_ty_id; + Signature_names.check_type names loc decl.clsty_obj_id; + Signature_names.check_type names loc decl.clsty_typesharp_id; + Env.register_uid decl.clsty_ty_decl.clty_uid loc; + let map f id acc = f acc id decl.clsty_ty_decl.clty_uid in + map Shape.Map.add_class_type decl.clsty_ty_id acc + |> map Shape.Map.add_type decl.clsty_obj_id + |> map Shape.Map.add_type decl.clsty_typesharp_id + ) shape_map classes + in Tstr_class_type (List.map (fun cl -> (cl.Typeclass.clsty_ty_id, cl.Typeclass.clsty_id_loc, cl.Typeclass.clsty_info)) classes), -(* TODO: check with Jacques why this is here - Tstr_type - (List.map (fun (_, _, i, d, _, _) -> (i, d)) classes) :: - Tstr_type - (List.map (fun (_, _, _, _, i, d) -> (i, d)) classes) :: *) List.flatten (map_rec (fun rs decl -> @@ -2501,11 +2862,12 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = Exported) ]) classes []), + shape_map, new_env | Pstr_include sincl -> let smodl = sincl.pincl_mod in let sloc = sincl.pincl_loc in - let modl = + let modl, modl_shape = Builtin_attributes.warning_scope sincl.pincl_attributes (fun () -> type_module true funct_body None env smodl) in @@ -2521,8 +2883,11 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = in let scope = Ctype.create_scope () in (* Rename all identifiers bound by this signature to avoid clashes *) - let sg, new_env = Env.enter_signature ~scope sg env in - List.iter (Signature_names.check_sig_item names loc) sg; + let sg, shape, new_env = + Env.enter_signature_and_shape ~scope ~parent_shape:shape_map + modl_shape sg env + in + Signature_group.iter (Signature_names.check_sig_item names loc) sg; let incl = { incl_mod = modl; incl_type = sg; @@ -2531,34 +2896,35 @@ and type_structure ?(toplevel = None) funct_body anchor env sstr = incl_loc = sloc; } in - Tstr_include incl, sg, new_env + Tstr_include incl, sg, shape, new_env | Pstr_extension (ext, _attrs) -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) | Pstr_attribute attr -> Builtin_attributes.parse_standard_implementation_attributes attr; - Tstr_attribute attr, [], env + Builtin_attributes.mark_alert_used attr; + Tstr_attribute attr, [], shape_map, env in let toplevel_sig = Option.value toplevel ~default:[] in - let rec type_struct env sstr str_acc sig_acc sig_acc_include_functor = + let rec type_struct env shape_map sstr str_acc sig_acc sig_acc_include_functor = match sstr with | [] -> - (List.rev str_acc, List.rev sig_acc, env) + (List.rev str_acc, List.rev sig_acc, shape_map, env) | pstr :: srem -> let previous_saved_types = Cmt_format.get_saved_types () in - let desc, sg, new_env = type_str_item env pstr sig_acc_include_functor in + let desc, sg, shape_map, new_env = type_str_item env shape_map pstr sig_acc_include_functor in let str = { str_desc = desc; str_loc = pstr.pstr_loc; str_env = env } in Cmt_format.set_saved_types (Cmt_format.Partial_structure_item str :: previous_saved_types); - type_struct new_env srem (str :: str_acc) (List.rev_append sg sig_acc) + type_struct new_env shape_map srem (str :: str_acc) (List.rev_append sg sig_acc) (List.rev_append sg sig_acc_include_functor) in let previous_saved_types = Cmt_format.get_saved_types () in let run () = - let (items, sg, final_env) = type_struct env sstr [] [] toplevel_sig in + let (items, sg, shape_map, final_env) = type_struct env Shape.Map.empty sstr [] [] toplevel_sig in let str = { str_items = items; str_type = sg; str_final_env = final_env } in Cmt_format.set_saved_types (Cmt_format.Partial_structure str :: previous_saved_types); - str, sg, names, final_env + str, sg, names, Shape.str shape_map, final_env in if Option.is_some toplevel then run () else Builtin_attributes.warning_scope [] run @@ -2580,12 +2946,12 @@ let type_toplevel_phrase env sig_acc s = Env.reset_required_globals (); Env.reset_probes (); Typecore.reset_allocations (); - let (str, sg, to_remove_from_sg, env) = + let (str, sg, to_remove_from_sg, shape, env) = type_structure ~toplevel:(Some sig_acc) false None env s in remove_mode_variables env sg; remove_mode_variables_for_toplevel str; Typecore.optimise_allocations (); - (str, sg, to_remove_from_sg, env) + (str, sg, to_remove_from_sg, shape, env) let type_module_alias = type_module ~alias:true true false None let type_module = type_module true false None @@ -2619,11 +2985,13 @@ let type_module_type_of env smod = mod_env = env; mod_attributes = smod.pmod_attributes; mod_loc = smod.pmod_loc } - | _ -> type_module env smod + | _ -> + let me, _shape = type_module env smod in + me in let mty = Mtype.scrape_for_type_of ~remove_aliases env tmty.mod_type in (* PR#5036: must not contain non-generalized type variables *) - if not (closed_modtype env mty) then + if nongen_modtype env Ctype.nongen_schema mty then raise(Error(smod.pmod_loc, env, Non_generalizable_module mty)); tmty, mty @@ -2665,18 +3033,18 @@ let lookup_type_in_sig sg = | Ldot(m, name) -> Pdot(module_path m, name) | Lapply _ -> assert false -let type_package env m p nl = +let type_package env m p fl = (* Same as Pexp_letmodule *) (* remember original level *) Ctype.begin_def (); let context = Typetexp.narrow () in - let modl = type_module env m in + let modl, _mod_shape = type_module env m in let scope = Ctype.create_scope () in Typetexp.widen context; - let nl', tl', env = - match nl with - | [] -> [], [], env - | nl -> + let fl', env = + match fl with + | [] -> [], env + | fl -> let type_path, env = match modl.mod_desc with | Tmod_ident (mp,_) @@ -2693,42 +3061,40 @@ let type_package env m p nl = let sg, env = Env.enter_signature ~scope sg env in lookup_type_in_sig sg, env in - let nl', tl' = + let fl' = List.fold_right - (fun lid (nl, tl) -> + (fun (lid, _t) fl -> match type_path lid with - | exception Not_found -> (nl, tl) + | exception Not_found -> fl | path -> begin match Env.find_type path env with - | exception Not_found -> (nl, tl) + | exception Not_found -> fl | decl -> if decl.type_arity > 0 then begin - (nl, tl) + fl end else begin let t = Btype.newgenty (Tconstr (path,[],ref Mnil)) in - (lid :: nl, t :: tl) + (lid, t) :: fl end end) - nl ([], []) + fl [] in - nl', tl', env + fl', env in (* go back to original level *) Ctype.end_def (); let mty = - if nl = [] then (Mty_ident p) - else modtype_of_package env modl.mod_loc p nl' tl' + if fl = [] then (Mty_ident p) + else modtype_of_package env modl.mod_loc p fl' in - List.iter2 - (fun n ty -> + List.iter + (fun (n, ty) -> try Ctype.unify env ty (Ctype.newvar ()) with Ctype.Unify _ -> raise (Error(modl.mod_loc, env, Scoping_pack (n,ty)))) - nl' tl'; + fl'; let modl = wrap_constraint env true modl mty Tmodtype_implicit in - (* Dropped exports should have produced an error above *) - assert (List.length nl = List.length tl'); - modl, tl' + modl, fl' (* Fill in the forward declarations *) @@ -2764,51 +3130,68 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = Env.reset_required_globals (); Env.reset_probes (); if !Clflags.print_types then (* #7656 *) - Warnings.parse_options false "-32-34-37-38-60"; - let (str, sg, names, finalenv) = + ignore @@ Warnings.parse_options false "-32-34-37-38-60"; + let (str, sg, names, shape, finalenv) = type_structure initial_env ast in + let shape = + Shape.set_uid_if_none shape + (Uid.of_compilation_unit_id modulename) + in let simple_sg = Signature_names.simplify finalenv names sg in if !Clflags.print_types then begin remove_mode_variables finalenv sg; Typecore.force_delayed_checks (); Typecore.optimise_allocations (); + let shape = Shape.local_reduce shape in Printtyp.wrap_printing_env ~error:false initial_env (fun () -> fprintf std_formatter "%a@." (Printtyp.printed_signature sourcefile) simple_sg ); gen_annot outputprefix sourcefile (Cmt_format.Implementation str); - (str, Tcoerce_none) (* result is ignored by Compile.implementation *) + { structure = str; + coercion = Tcoerce_none; + shape; + signature = simple_sg + } (* result is ignored by Compile.implementation *) end else begin let sourceintf = Filename.remove_extension sourcefile ^ !Config.interface_suffix in if Sys.file_exists sourceintf then begin + let basename = modulename |> Compilation_unit.name_as_string in let intf_file = try - Load_path.find_uncap (modulename ^ ".cmi") + Load_path.find_uncap (basename ^ ".cmi") with Not_found -> raise(Error(Location.in_file sourcefile, Env.empty, Interface_not_compiled sourceintf)) in let dclsig = Env.read_signature modulename intf_file in - let coercion = + let coercion, shape = Includemod.compunit initial_env ~mark:Mark_positive - sourcefile sg intf_file dclsig + sourcefile sg intf_file dclsig shape in Typecore.force_delayed_checks (); Typecore.optimise_allocations (); (* It is important to run these checks after the inclusion test above, so that value declarations which are not used internally but exported are not reported as being unused. *) + let shape = Shape.local_reduce shape in let annots = Cmt_format.Implementation str in Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - annots (Some sourcefile) initial_env None; + annots (Some sourcefile) initial_env None (Some shape); gen_annot outputprefix sourcefile annots; - (str, coercion) + { structure = str; + coercion; + shape; + signature = dclsig + } end else begin - let coercion = + Location.prerr_warning (Location.in_file sourcefile) + Warnings.Missing_mli; + let coercion, shape = Includemod.compunit initial_env ~mark:Mark_positive - sourcefile sg "(inferred signature)" simple_sg + sourcefile sg "(inferred signature)" simple_sg shape in - check_nongen_schemes finalenv simple_sg; + check_nongen_signature finalenv simple_sg; normalize_signature simple_sg; Typecore.force_delayed_checks (); Typecore.optimise_allocations (); @@ -2816,6 +3199,7 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = the value being exported. We can still capture unused declarations like "let x = true;; let x = 1;;", because in this case, the inferred signature contains only the last declaration. *) + let shape = Shape.local_reduce shape in if not !Clflags.dont_write_files then begin let alerts = Builtin_attributes.alerts_of_str ast in let cmi = @@ -2824,10 +3208,14 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = in let annots = Cmt_format.Implementation str in Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - annots (Some sourcefile) initial_env (Some cmi); + annots (Some sourcefile) initial_env (Some cmi) (Some shape); gen_annot outputprefix sourcefile annots end; - (str, coercion) + { structure = str; + coercion; + shape; + signature = simple_sg + } end end ) @@ -2837,13 +3225,13 @@ let type_implementation sourcefile outputprefix modulename initial_env ast = (Array.of_list (Cmt_format.get_saved_types ())) in Cmt_format.save_cmt (outputprefix ^ ".cmt") modulename - annots (Some sourcefile) initial_env None; + annots (Some sourcefile) initial_env None None; gen_annot outputprefix sourcefile annots ) let save_signature modname tsg outputprefix source_file initial_env cmi = Cmt_format.save_cmt (outputprefix ^ ".cmti") modname - (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi) + (Cmt_format.Interface tsg) (Some source_file) initial_env (Some cmi) None let type_interface env ast = transl_signature env ast @@ -2855,6 +3243,7 @@ let package_signatures units = let units_with_ids = List.map (fun (name, sg) -> + let name = name |> Compilation_unit.Name.to_string in let oldid = Ident.create_persistent name in let newid = Ident.create_local name in (oldid, newid, sg)) @@ -2887,19 +3276,36 @@ let package_units initial_env objfiles cmifile modulename = List.map (fun f -> let pref = chop_extensions f in - let modname = String.capitalize_ascii(Filename.basename pref) in + let unit = + pref + |> Filename.basename + |> String.capitalize_ascii + |> Compilation_unit.Name.of_string + in + let modname = Compilation_unit.create_child modulename unit in let sg = Env.read_signature modname (pref ^ ".cmi") in if Filename.check_suffix f ".cmi" && not(Mtype.no_code_needed_sig Env.initial_safe_string sg) then raise(Error(Location.none, Env.empty, Implementation_is_required f)); - (modname, Env.read_signature modname (pref ^ ".cmi"))) + Compilation_unit.name modname, + Env.read_signature modname (pref ^ ".cmi")) objfiles in (* Compute signature of packaged unit *) Ident.reinit(); let sg = package_signatures units in - (* See if explicit interface is provided *) + (* Compute the shape of the package *) let prefix = Filename.remove_extension cmifile in + let pack_uid = Uid.of_compilation_unit_id modulename in + let shape = + List.fold_left (fun map (name, _sg) -> + let name = Compilation_unit.Name.to_string name in + let id = Ident.create_persistent name in + Shape.Map.add_module map id (Shape.for_persistent_unit name) + ) Shape.Map.empty units + |> Shape.str ~uid:pack_uid + in + (* See if explicit interface is provided *) let mlifile = prefix ^ !Config.interface_suffix in if Sys.file_exists mlifile then begin if not (Sys.file_exists cmifile) then begin @@ -2907,46 +3313,52 @@ let package_units initial_env objfiles cmifile modulename = Interface_not_compiled mlifile)) end; let dclsig = Env.read_signature modulename cmifile in + let cc, _shape = + Includemod.compunit initial_env ~mark:Mark_both + "(obtained by packing)" sg mlifile dclsig shape + in Cmt_format.save_cmt (prefix ^ ".cmt") modulename - (Cmt_format.Packed (sg, objfiles)) None initial_env None ; - Includemod.compunit initial_env ~mark:Mark_both - "(obtained by packing)" sg mlifile dclsig + (Cmt_format.Packed (sg, objfiles)) None initial_env None (Some shape); + cc end else begin (* Determine imports *) let unit_names = List.map fst units in let imports = - List.filter - (fun (name, _crc) -> not (List.mem name unit_names)) + List.filter (fun import -> + let name = Import_info.name import in + not (List.mem name unit_names)) (Env.imports()) in (* Write packaged signature *) if not !Clflags.dont_write_files then begin let cmi = Env.save_signature_with_imports ~alerts:Misc.Stdlib.String.Map.empty sg modulename - (prefix ^ ".cmi") imports + (prefix ^ ".cmi") (Array.of_list imports) in Cmt_format.save_cmt (prefix ^ ".cmt") modulename (Cmt_format.Packed (cmi.Cmi_format.cmi_sign, objfiles)) None initial_env - (Some cmi) + (Some cmi) (Some shape); end; Tcoerce_none end + (* Error report *) + open Printtyp -let report_error ppf = function +let report_error ~loc _env = function Cannot_apply mty -> - fprintf ppf + Location.errorf ~loc "@[This module is not a functor; it has type@ %a@]" modtype mty | Not_included errs -> - fprintf ppf - "@[Signature mismatch:@ %a@]" Includemod.report_error errs + let main = Includemod_errorprinter.err_msgs errs in + Location.errorf ~loc "@[Signature mismatch:@ %t@]" main | Not_included_functor errs -> - fprintf ppf - "@[Signature mismatch in included functor's parameter:@ %a@]" - Includemod.report_error errs + let main = Includemod_errorprinter.err_msgs errs in + Location.errorf ~loc + "@[Signature mismatch in included functor's parameter:@ %t@]" main | Cannot_eliminate_dependency (dep_type, mty) -> let hint = match dep_type with @@ -2954,125 +3366,127 @@ let report_error ppf = function | Functor_included -> "This functor can't be included directly; please \ apply it to an explicit argument" in - fprintf ppf + Location.errorf ~loc "@[This functor has type@ %a@ \ The parameter cannot be eliminated in the result type.@ \ %s.@]" modtype mty hint - | Signature_expected -> fprintf ppf "This module type is not a signature" + | Signature_expected -> + Location.errorf ~loc "This module type is not a signature" | Structure_expected mty -> - fprintf ppf + Location.errorf ~loc "@[This module is not a structure; it has type@ %a" modtype mty | Functor_expected mty -> - fprintf ppf + Location.errorf ~loc "@[This module is not a functor; it has type@ %a" modtype mty | Signature_parameter_expected mty -> - fprintf ppf + Location.errorf ~loc "@[The type of this functor is:@ %a. @ Its parameter is not a signature." modtype mty | Signature_result_expected mty -> - fprintf ppf + Location.errorf ~loc "@[The type of this functor's result is not includable; it is@ %a" modtype mty | Recursive_include_functor -> - fprintf ppf + Location.errorf ~loc "@[Including a functor is not supported in recursive module signatures @]" | With_no_component lid -> - fprintf ppf + Location.errorf ~loc "@[The signature constrained by `with' has no component named %a@]" longident lid | With_mismatch(lid, explanation) -> - fprintf ppf + let main = Includemod_errorprinter.err_msgs explanation in + Location.errorf ~loc "@[\ @[In this `with' constraint, the new definition of %a@ \ does not match its original definition@ \ in the constrained signature:@]@ \ - %a@]" - longident lid Includemod.report_error explanation + %t@]" + longident lid main | With_makes_applicative_functor_ill_typed(lid, path, explanation) -> - fprintf ppf + let main = Includemod_errorprinter.err_msgs explanation in + Location.errorf ~loc "@[\ @[This `with' constraint on %a makes the applicative functor @ \ type %s ill-typed in the constrained signature:@]@ \ - %a@]" - longident lid (Path.name path) Includemod.report_error explanation + %t@]" + longident lid (Path.name path) main | With_changes_module_alias(lid, id, path) -> - fprintf ppf + Location.errorf ~loc "@[\ @[This `with' constraint on %a changes %s, which is aliased @ \ in the constrained signature (as %s)@].@]" longident lid (Path.name path) (Ident.name id) | With_cannot_remove_constrained_type -> - fprintf ppf + Location.errorf ~loc "@[Destructive substitutions are not supported for constrained @ \ types (other than when replacing a type constructor with @ \ a type constructor with the same arguments).@]" + | With_cannot_remove_packed_modtype (p,mty) -> + Location.errorf ~loc + "This `with' constraint@ %s := %a@ makes a packed module ill-formed." + (Path.name p) Printtyp.modtype mty | Repeated_name(kind, name) -> - fprintf ppf + Location.errorf ~loc "@[Multiple definition of the %s name %s.@ \ Names must be unique in a given structure or signature.@]" (Sig_component_kind.to_string kind) name | Non_generalizable typ -> - fprintf ppf + Location.errorf ~loc "@[The type of this expression,@ %a,@ \ contains type variables that cannot be generalized@]" type_scheme typ - | Non_generalizable_class (id, desc) -> - fprintf ppf - "@[The type of this class,@ %a,@ \ - contains type variables that cannot be generalized@]" - (class_declaration id) desc | Non_generalizable_module mty -> - fprintf ppf + Location.errorf ~loc "@[The type of this module,@ %a,@ \ contains type variables that cannot be generalized@]" modtype mty | Implementation_is_required intf_name -> - fprintf ppf + Location.errorf ~loc "@[The interface %a@ declares values, not just types.@ \ An implementation must be provided.@]" Location.print_filename intf_name | Interface_not_compiled intf_name -> - fprintf ppf + Location.errorf ~loc "@[Could not find the .cmi file for interface@ %a.@]" Location.print_filename intf_name | Not_allowed_in_functor_body -> - fprintf ppf + Location.errorf ~loc "@[This expression creates fresh types.@ %s@]" "It is not allowed inside applicative functors." | Not_includable_in_functor_body -> - fprintf ppf + Location.errorf ~loc "@[This functor creates fresh types when applied.@ %s@]" "Including it is not allowed inside applicative functors." | Not_a_packed_module ty -> - fprintf ppf + Location.errorf ~loc "This expression is not a packed module. It has type@ %a" type_expr ty | Incomplete_packed_module ty -> - fprintf ppf + Location.errorf ~loc "The type of this packed module contains variables:@ %a" type_expr ty | Scoping_pack (lid, ty) -> - fprintf ppf - "The type %a in this module cannot be exported.@ " longident lid; - fprintf ppf - "Its type contains local dependencies:@ %a" type_expr ty + Location.errorf ~loc + "The type %a in this module cannot be exported.@ \ + Its type contains local dependencies:@ %a" longident lid type_expr ty | Recursive_module_require_explicit_type -> - fprintf ppf "Recursive modules require an explicit module type." + Location.errorf ~loc "Recursive modules require an explicit module type." | Apply_generative -> - fprintf ppf "This is a generative functor. It can only be applied to ()" + Location.errorf ~loc + "This is a generative functor. It can only be applied to ()" | Cannot_scrape_alias p -> - fprintf ppf + Location.errorf ~loc "This is an alias for module %a, which is missing" path p | Cannot_scrape_package_type p -> - fprintf ppf + Location.errorf ~loc "The type of this packed module refers to %a, which is missing" path p | Badly_formed_signature (context, err) -> - fprintf ppf "@[In %s:@ %a@]" context Typedecl.report_error err + Location.errorf ~loc "@[In %s:@ %a@]" context Typedecl.report_error err | Cannot_hide_id Illegal_shadowing { shadowed_item_kind; shadowed_item_id; shadowed_item_loc; shadower_id; user_id; user_kind; user_loc } -> let shadowed_item_kind= Sig_component_kind.to_string shadowed_item_kind in - fprintf ppf + Location.errorf ~loc "@[Illegal shadowing of included %s %a by %a@ \ %a:@;<1 2>%s %a came from this include@ \ %a:@;<1 2>The %s %s has no valid type if %a is shadowed@]" @@ -3086,7 +3500,7 @@ let report_error ppf = function | Cannot_hide_id Appears_in_signature { opened_item_kind; opened_item_id; user_id; user_kind; user_loc } -> let opened_item_kind= Sig_component_kind.to_string opened_item_kind in - fprintf ppf + Location.errorf ~loc "@[The %s %a introduced by this open appears in the signature@ \ %a:@;<1 2>The %s %s has no valid type if %a is hidden@]" opened_item_kind Ident.print opened_item_id @@ -3094,21 +3508,22 @@ let report_error ppf = function (Sig_component_kind.to_string user_kind) (Ident.name user_id) Ident.print opened_item_id | Invalid_type_subst_rhs -> - fprintf ppf "Only type synonyms are allowed on the right of :=" - | Unsupported_extension ext -> - let ext = Clflags.Extension.to_string ext in - fprintf ppf "@[The %s extension is disabled@ \ - To enable it, pass the '-extension %s' flag@]" ext ext - + Location.errorf ~loc "Only type synonyms are allowed on the right of :=" + | Unpackable_local_modtype_subst p -> + Location.errorf ~loc + "The module type@ %s@ is not a valid type for a packed module:@ \ + it is defined as a local substitution for a non-path module type." + (Path.name p) -let report_error env ppf err = - Printtyp.wrap_printing_env ~error:true env (fun () -> report_error ppf err) +let report_error env ~loc err = + Printtyp.wrap_printing_env ~error:true env + (fun () -> report_error env ~loc err) let () = Location.register_error_of_exn (function | Error (loc, env, err) -> - Some (Location.error_of_printer ~loc (report_error env) err) + Some (report_error ~loc env err) | Error_forward err -> Some err | _ -> diff --git a/ocaml/typing/typemod.mli b/ocaml/typing/typemod.mli index 45dab7a1e29..26d4c8f14d1 100644 --- a/ocaml/typing/typemod.mli +++ b/ocaml/typing/typemod.mli @@ -21,7 +21,6 @@ *) open Types -open Format module Signature_names : sig type t @@ -30,21 +29,23 @@ module Signature_names : sig end val type_module: - Env.t -> Parsetree.module_expr -> Typedtree.module_expr + Env.t -> Parsetree.module_expr -> Typedtree.module_expr * Shape.t val type_structure: Env.t -> Parsetree.structure -> - Typedtree.structure * Types.signature * Signature_names.t * Env.t + Typedtree.structure * Types.signature * Signature_names.t * Shape.t * + Env.t val type_toplevel_phrase: Env.t -> Types.signature -> Parsetree.structure -> - Typedtree.structure * Types.signature * Signature_names.t * Env.t + Typedtree.structure * Types.signature * Signature_names.t * Shape.t * + Env.t val type_implementation: - string -> string -> string -> Env.t -> Parsetree.structure -> - Typedtree.structure * Typedtree.module_coercion + string -> string -> Compilation_unit.t -> Env.t -> + Parsetree.structure -> Typedtree.implementation val type_interface: Env.t -> Parsetree.signature -> Typedtree.signature val transl_signature: Env.t -> Parsetree.signature -> Typedtree.signature -val check_nongen_schemes: +val check_nongen_signature: Env.t -> Types.signature -> unit (* val type_open_: @@ -54,16 +55,16 @@ val type_open_: *) val modtype_of_package: Env.t -> Location.t -> - Path.t -> Longident.t list -> type_expr list -> module_type + Path.t -> (Longident.t * type_expr) list -> module_type val path_of_module : Typedtree.module_expr -> Path.t option val save_signature: - string -> Typedtree.signature -> string -> string -> + Compilation_unit.t -> Typedtree.signature -> string -> string -> Env.t -> Cmi_format.cmi_infos -> unit val package_units: - Env.t -> string list -> string -> string -> Typedtree.module_coercion + Env.t -> string list -> string -> Compilation_unit.t -> Typedtree.module_coercion (* Should be in Envaux, but it breaks the build of the debugger *) val initial_env: @@ -108,8 +109,8 @@ type functor_dependency_error = type error = Cannot_apply of module_type - | Not_included of Includemod.error list - | Not_included_functor of Includemod.error list + | Not_included of Includemod.explanation + | Not_included_functor of Includemod.explanation | Cannot_eliminate_dependency of functor_dependency_error * module_type | Signature_expected | Structure_expected of module_type @@ -118,14 +119,13 @@ type error = | Signature_result_expected of module_type | Recursive_include_functor | With_no_component of Longident.t - | With_mismatch of Longident.t * Includemod.error list + | With_mismatch of Longident.t * Includemod.explanation | With_makes_applicative_functor_ill_typed of - Longident.t * Path.t * Includemod.error list + Longident.t * Path.t * Includemod.explanation | With_changes_module_alias of Longident.t * Ident.t * Path.t | With_cannot_remove_constrained_type | Repeated_name of Sig_component_kind.t * string | Non_generalizable of type_expr - | Non_generalizable_class of Ident.t * class_declaration | Non_generalizable_module of module_type | Implementation_is_required of string | Interface_not_compiled of string @@ -141,12 +141,13 @@ type error = | Badly_formed_signature of string * Typedecl.error | Cannot_hide_id of hiding_error | Invalid_type_subst_rhs - | Unsupported_extension of Clflags.Extension.t + | Unpackable_local_modtype_subst of Path.t + | With_cannot_remove_packed_modtype of Path.t * module_type exception Error of Location.t * Env.t * error exception Error_forward of Location.error -val report_error: Env.t -> formatter -> error -> unit +val report_error: Env.t -> loc:Location.t -> error -> Location.error (** Clear several bits of global state that may retain large amounts of memory after typechecking is finished. *) diff --git a/ocaml/typing/typeopt.ml b/ocaml/typing/typeopt.ml index 09b8c6c5d38..775f083c000 100644 --- a/ocaml/typing/typeopt.ml +++ b/ocaml/typing/typeopt.ml @@ -21,23 +21,44 @@ open Asttypes open Typedtree open Lambda +(* Expand a type, looking through ordinary synonyms, private synonyms, + links, and [@@unboxed] types. The returned type will be therefore be none + of these cases. *) let scrape_ty env ty = - let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in - match ty.desc with - | Tconstr (p, _, _) -> - begin match Env.find_type p env with - | {type_unboxed = {unboxed = true; _}; _} -> - begin match Typedecl.get_unboxed_type_representation env ty with - | None -> ty - | Some ty2 -> ty2 - end - | _ -> ty - | exception Not_found -> ty + let ty = + match get_desc ty with + | Tpoly(ty, _) -> ty + | _ -> ty + in + match get_desc ty with + | Tconstr _ -> + let ty = Ctype.expand_head_opt env (Ctype.correct_levels ty) in + begin match get_desc ty with + | Tconstr (p, _, _) -> + begin match Env.find_type p env with + | {type_kind = ( Type_variant (_, Variant_unboxed) + | Type_record (_, Record_unboxed _) ); _} -> begin + match Typedecl_unboxed.get_unboxed_type_representation env ty with + | None -> ty + | Some ty2 -> ty2 + end + | _ -> ty + | exception Not_found -> ty + end + | _ -> + ty end | _ -> ty +(* See [scrape_ty]; this returns the [type_desc] of a scraped [type_expr]. *) let scrape env ty = - (scrape_ty env ty).desc + get_desc (scrape_ty env ty) + +let scrape_poly env ty = + let ty = scrape_ty env ty in + match get_desc ty with + | Tpoly (ty, _) -> get_desc ty + | d -> d let is_function_type env ty = match scrape env ty with @@ -49,26 +70,34 @@ let is_base_type env ty base_ty_path = | Tconstr(p, _, _) -> Path.same p base_ty_path | _ -> false +let is_immediate = function + | Type_immediacy.Unknown -> false + | Type_immediacy.Always -> true + | Type_immediacy.Always_on_64bits -> + (* In bytecode, we don't know at compile time whether we are + targeting 32 or 64 bits. *) + !Clflags.native_code && Sys.word_size = 64 + let maybe_pointer_type env ty = let ty = scrape_ty env ty in - if Ctype.maybe_pointer_type env ty then - Pointer - else - Immediate + if is_immediate (Ctype.immediacy env ty) then Immediate + else Pointer let maybe_pointer exp = maybe_pointer_type exp.exp_env exp.exp_type type classification = - | Int + | Int (* any immediate type *) | Float | Lazy | Addr (* anything except a float or a lazy *) | Any -let classify env ty = +(* Classify a ty into a [classification]. Looks through synonyms, using [scrape_ty]. + Returning [Any] is safe, though may skip some optimizations. *) +let classify env ty : classification = let ty = scrape_ty env ty in if maybe_pointer_type env ty = Immediate then Int - else match ty.desc with + else match get_desc ty with | Tvar _ | Tunivar _ -> Any | Tconstr (p, _args, _abbrev) -> @@ -99,17 +128,15 @@ let classify env ty = assert false let array_type_kind env ty = - match scrape env ty with - | Tconstr(p, [elt_ty], _) | Tpoly({desc = Tconstr(p, [elt_ty], _)}, _) - when Path.same p Predef.path_array -> + match scrape_poly env ty with + | Tconstr(p, [elt_ty], _) when Path.same p Predef.path_array -> begin match classify env elt_ty with | Any -> if Config.flat_float_array then Pgenarray else Paddrarray | Float -> if Config.flat_float_array then Pfloatarray else Paddrarray | Addr | Lazy -> Paddrarray | Int -> Pintarray end - | Tconstr(p, [], _) | Tpoly({desc = Tconstr(p, [], _)}, _) - when Path.same p Predef.path_floatarray -> + | Tconstr(p, [], _) when Path.same p Predef.path_floatarray -> Pfloatarray | _ -> (* This can happen with e.g. Obj.field *) @@ -158,11 +185,14 @@ let value_kind env ty = let rec loop env ~visited ~depth ~num_nodes_visited ty : int * Lambda.value_kind = let[@inline] cannot_proceed () = - Numbers.Int.Set.mem ty.id visited + Numbers.Int.Set.mem (get_id ty) visited || depth >= 2 || num_nodes_visited >= 30 in - match scrape env ty with + let scty = scrape_ty env ty in + match get_desc scty with + | _ when is_immediate (Ctype.immediacy env scty) -> + num_nodes_visited, Pintval | Tconstr(p, _, _) when Path.same p Predef.path_int -> num_nodes_visited, Pintval | Tconstr(p, _, _) when Path.same p Predef.path_char -> @@ -183,11 +213,11 @@ let value_kind env ty = if cannot_proceed () then num_nodes_visited, Pgenval else begin - let visited = Numbers.Int.Set.add ty.id visited in + let visited = Numbers.Int.Set.add (get_id ty) visited in match (Env.find_type p env).type_kind with | exception Not_found -> num_nodes_visited, Pgenval - | Type_variant constructors -> + | Type_variant (constructors, _rep) -> let is_constant (constructor : Types.constructor_declaration) = match constructor.cd_args with | Cstr_tuple [] -> true @@ -205,9 +235,9 @@ let value_kind env ty = | Cstr_tuple fields -> let num_nodes_visited, fields = List.fold_left_map - (fun num_nodes_visited field -> + (fun num_nodes_visited (ty, _) -> let num_nodes_visited = num_nodes_visited + 1 in - loop env ~visited ~depth ~num_nodes_visited field) + loop env ~visited ~depth ~num_nodes_visited ty) num_nodes_visited fields in (false, num_nodes_visited), fields @@ -308,7 +338,7 @@ let value_kind env ty = if cannot_proceed () then num_nodes_visited, Pgenval else begin - let visited = Numbers.Int.Set.add ty.id visited in + let visited = Numbers.Int.Set.add (get_id ty) visited in let depth = depth + 1 in let num_nodes_visited, fields = List.fold_left_map (fun num_nodes_visited field -> diff --git a/ocaml/typing/types.ml b/ocaml/typing/types.ml index 2d1afd786a6..1b0738a4c0a 100644 --- a/ocaml/typing/types.ml +++ b/ocaml/typing/types.ml @@ -19,12 +19,14 @@ open Asttypes (* Type expressions for the core language *) -type type_expr = +type transient_expr = { mutable desc: type_desc; mutable level: int; mutable scope: int; id: int } +and type_expr = transient_expr + and type_desc = Tvar of string option | Tarrow of arrow_desc * type_expr * type_expr * commutable @@ -34,11 +36,11 @@ and type_desc = | Tfield of string * field_kind * type_expr * type_expr | Tnil | Tlink of type_expr - | Tsubst of type_expr (* for copying *) + | Tsubst of type_expr * type_expr option | Tvariant of row_desc | Tunivar of string option | Tpoly of type_expr * type_expr list - | Tpackage of Path.t * Longident.t list * type_expr list + | Tpackage of Path.t * (Longident.t * type_expr) list and arrow_desc = arg_label * alloc_mode * alloc_mode @@ -60,36 +62,42 @@ and alloc_mode = and row_desc = { row_fields: (label * row_field) list; row_more: type_expr; - row_bound: unit; row_closed: bool; row_fixed: fixed_explanation option; row_name: (Path.t * type_expr list) option } and fixed_explanation = | Univar of type_expr | Fixed_private | Reified of Path.t | Rigid -and row_field = - Rpresent of type_expr option - | Reither of bool * type_expr list * bool * row_field option ref - (* 1st true denotes a constant constructor *) - (* 2nd true denotes a tag in a pattern matching, and - is erased later *) - | Rabsent +and row_field = [`some] row_field_gen +and _ row_field_gen = + RFpresent : type_expr option -> [> `some] row_field_gen + | RFeither : + { no_arg: bool; + arg_type: type_expr list; + matched: bool; + ext: [`some | `none] row_field_gen ref} -> [> `some] row_field_gen + | RFabsent : [> `some] row_field_gen + | RFnone : [> `none] row_field_gen and abbrev_memo = Mnil | Mcons of private_flag * Path.t * type_expr * type_expr * abbrev_memo | Mlink of abbrev_memo ref -and field_kind = - Fvar of field_kind option ref - | Fpresent - | Fabsent - -and commutable = - Cok - | Cunknown - | Clink of commutable ref - -module TypeOps = struct +and any = [`some | `none | `var] +and field_kind = [`some|`var] field_kind_gen +and _ field_kind_gen = + FKvar : {mutable field_kind: any field_kind_gen} -> [> `var] field_kind_gen + | FKprivate : [> `none] field_kind_gen (* private method; only under FKvar *) + | FKpublic : [> `some] field_kind_gen (* public method *) + | FKabsent : [> `some] field_kind_gen (* hidden private method *) + +and commutable = [`some|`var] commutable_gen +and _ commutable_gen = + Cok : [> `some] commutable_gen + | Cunknown : [> `none] commutable_gen + | Cvar : {mutable commu: any commutable_gen} -> [> `var] commutable_gen + +module TransientTypeOps = struct type t = type_expr let compare t1 t2 = t1.id - t2.id let hash t = t.id @@ -98,60 +106,16 @@ end (* *) -module Uid = struct - type t = - | Compilation_unit of string - | Item of { comp_unit: string; id: int } - | Internal - | Predef of string - - include Identifiable.Make(struct - type nonrec t = t - - let equal (x : t) y = x = y - let compare (x : t) y = compare x y - let hash (x : t) = Hashtbl.hash x - - let print fmt = function - | Internal -> Format.pp_print_string fmt "" - | Predef name -> Format.fprintf fmt "" name - | Compilation_unit s -> Format.pp_print_string fmt s - | Item { comp_unit; id } -> Format.fprintf fmt "%s.%d" comp_unit id - - let output oc t = - let fmt = Format.formatter_of_out_channel oc in - print fmt t - end) - - let id = ref (-1) - - let reinit () = id := (-1) - - let mk ~current_unit = - incr id; - Item { comp_unit = current_unit; id = !id } - - let of_compilation_unit_id id = - if not (Ident.is_global id) then - Misc.fatal_errorf "Types.Uid.of_compilation_unit_id %S" (Ident.name id); - Compilation_unit (Ident.name id) - - let of_predef_id id = - if not (Ident.is_predef id) then - Misc.fatal_errorf "Types.Uid.of_predef_id %S" (Ident.name id); - Predef (Ident.name id) - - let internal_not_actually_unique = Internal - - let for_actual_declaration = function - | Item _ -> true - | _ -> false -end +module Uid = Shape.Uid (* Maps of methods and instance variables *) +module MethSet = Misc.Stdlib.String.Set +module VarSet = Misc.Stdlib.String.Set + module Meths = Misc.Stdlib.String.Map -module Vars = Meths +module Vars = Misc.Stdlib.String.Map + (* Value descriptions *) @@ -167,14 +131,26 @@ and value_kind = Val_reg (* Regular value *) | Val_prim of Primitive.description (* Primitive *) | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) - | Val_self of (Ident.t * type_expr) Meths.t ref * - (Ident.t * Asttypes.mutable_flag * - Asttypes.virtual_flag * type_expr) Vars.t ref * - string * type_expr + | Val_self of + class_signature * self_meths * Ident.t Vars.t * string (* Self *) - | Val_anc of (string * Ident.t) list * string + | Val_anc of class_signature * Ident.t Meths.t * string (* Ancestor *) +and self_meths = + | Self_concrete of Ident.t Meths.t + | Self_virtual of Ident.t Meths.t ref + +and class_signature = + { csig_self: type_expr; + mutable csig_self_row: type_expr; + mutable csig_vars: (mutable_flag * virtual_flag * type_expr) Vars.t; + mutable csig_meths: (method_privacy * virtual_flag * type_expr) Meths.t; } + +and method_privacy = + | Mpublic + | Mprivate of field_kind + (* Variance *) module Variance = struct @@ -240,7 +216,7 @@ end type type_declaration = { type_params: type_expr list; type_arity: int; - type_kind: type_kind; + type_kind: type_decl_kind; type_private: private_flag; type_manifest: type_expr option; type_variance: Variance.t list; @@ -250,14 +226,16 @@ type type_declaration = type_loc: Location.t; type_attributes: Parsetree.attributes; type_immediate: Type_immediacy.t; - type_unboxed: unboxed_status; + type_unboxed_default: bool; type_uid: Uid.t; } -and type_kind = +and type_decl_kind = (label_declaration, constructor_declaration) type_kind + +and ('lbl, 'cstr) type_kind = Type_abstract - | Type_record of label_declaration list * record_representation - | Type_variant of constructor_declaration list + | Type_record of 'lbl list * record_representation + | Type_variant of 'cstr list * variant_representation | Type_open and record_representation = @@ -267,6 +245,10 @@ and record_representation = | Record_inlined of int (* Inlined record *) | Record_extension of Path.t (* Inlined record under extension *) +and variant_representation = + Variant_regular (* Constant or boxed constructors *) + | Variant_unboxed (* One unboxed single-field constructor *) + and global_flag = | Global | Nonlocal @@ -294,20 +276,9 @@ and constructor_declaration = } and constructor_arguments = - | Cstr_tuple of type_expr list + | Cstr_tuple of (type_expr * global_flag) list | Cstr_record of label_declaration list -and unboxed_status = - { - unboxed: bool; - default: bool; (* False if the unboxed field was set from an attribute. *) - } - -let unboxed_false_default_false = {unboxed = false; default = false} -let unboxed_false_default_true = {unboxed = false; default = true} -let unboxed_true_default_false = {unboxed = true; default = false} -let unboxed_true_default_true = {unboxed = true; default = true} - type extension_constructor = { ext_type_path: Path.t; ext_type_params: type_expr list; @@ -326,20 +297,11 @@ and type_transparence = (* Type expressions for the class language *) -module Concr = Misc.Stdlib.String.Set - type class_type = Cty_constr of Path.t * type_expr list * class_type | Cty_signature of class_signature | Cty_arrow of arg_label * type_expr * class_type -and class_signature = - { csig_self: type_expr; - csig_vars: - (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t; - csig_concr: Concr.t; - csig_inher: (Path.t * type_expr list) list } - type class_declaration = { cty_params: type_expr list; mutable cty_type: class_type; @@ -427,12 +389,11 @@ type constructor_description = { cstr_name: string; (* Constructor name *) cstr_res: type_expr; (* Type of the result *) cstr_existentials: type_expr list; (* list of existentials *) - cstr_args: type_expr list; (* Type of the arguments *) + cstr_args: (type_expr * global_flag) list; (* Type of the arguments *) cstr_arity: int; (* Number of arguments *) cstr_tag: constructor_tag; (* Tag for heap blocks *) cstr_consts: int; (* Number of constant constructors *) cstr_nonconsts: int; (* Number of non-const constructors *) - cstr_normal: int; (* Number of non generalized constrs *) cstr_generalized: bool; (* Constrained return type? *) cstr_private: private_flag; (* Read-only constructor? *) cstr_loc: Location.t; @@ -466,6 +427,15 @@ let may_equal_constr c1 c2 = | tag1, tag2 -> equal_tag tag1 tag2) +let item_visibility = function + | Sig_value (_, _, vis) + | Sig_type (_, _, _, vis) + | Sig_typext (_, _, _, vis) + | Sig_module (_, _, _, _, vis) + | Sig_modtype (_, _, vis) + | Sig_class (_, _, _, vis) + | Sig_class_type (_, _, _, vis) -> vis + type label_description = { lbl_name: string; (* Short name *) lbl_res: type_expr; (* Type of the result *) @@ -504,3 +474,880 @@ let signature_item_id = function type value_mode = { r_as_l : alloc_mode; r_as_g : alloc_mode; } + +(**** Definitions for backtracking ****) + +type change = + Ctype of type_expr * type_desc + | Ccompress of type_expr * type_desc * type_desc + | Clevel of type_expr * int + | Cscope of type_expr * int + | Cname of + (Path.t * type_expr list) option ref * (Path.t * type_expr list) option + | Crow of [`none|`some] row_field_gen ref + | Ckind of [`var] field_kind_gen + | Ccommu of [`var] commutable_gen + | Cuniv of type_expr option ref * type_expr option + | Cmode_upper of alloc_mode_var * alloc_mode_const + | Cmode_lower of alloc_mode_var * alloc_mode_const + | Cmode_vlower of alloc_mode_var * alloc_mode_var list + +type changes = + Change of change * changes ref + | Unchanged + | Invalid + +let trail = Local_store.s_table ref Unchanged + +let log_change ch = + let r' = ref Unchanged in + !trail := Change (ch, r'); + trail := r' + +let log_changes chead ctail = + if chead = Unchanged then (assert (!ctail = Unchanged)) + else begin + !trail := chead; + trail := ctail + end + +let append_change ctail ch = + assert (!(!ctail) = Unchanged); + let r' = ref Unchanged in + (!ctail) := Change (ch, r'); + ctail := r' + +(* constructor and accessors for [field_kind] *) + +type field_kind_view = + Fprivate + | Fpublic + | Fabsent + +let rec field_kind_internal_repr : field_kind -> field_kind = function + | FKvar {field_kind = FKvar _ | FKpublic | FKabsent as fk} -> + field_kind_internal_repr fk + | kind -> kind + +let field_kind_repr fk = + match field_kind_internal_repr fk with + | FKvar _ -> Fprivate + | FKpublic -> Fpublic + | FKabsent -> Fabsent + +let field_public = FKpublic +let field_absent = FKabsent +let field_private () = FKvar {field_kind=FKprivate} + +(* Constructor and accessors for [commutable] *) + +let rec is_commu_ok : type a. a commutable_gen -> bool = function + | Cvar {commu} -> is_commu_ok commu + | Cunknown -> false + | Cok -> true + +let commu_ok = Cok +let commu_var () = Cvar {commu=Cunknown} + +(**** Representative of a type ****) + +let rec repr_link (t : type_expr) d : type_expr -> type_expr = + function + {desc = Tlink t' as d'} -> + repr_link t d' t' + | {desc = Tfield (_, k, _, t') as d'} + when field_kind_internal_repr k = FKabsent -> + repr_link t d' t' + | t' -> + log_change (Ccompress (t, t.desc, d)); + t.desc <- d; + t' + +let repr_link1 t = function + {desc = Tlink t' as d'} -> + repr_link t d' t' + | {desc = Tfield (_, k, _, t') as d'} + when field_kind_internal_repr k = FKabsent -> + repr_link t d' t' + | t' -> t' + +let repr t = + match t.desc with + Tlink t' -> + repr_link1 t t' + | Tfield (_, k, _, t') when field_kind_internal_repr k = FKabsent -> + repr_link1 t t' + | _ -> t + +(* getters for type_expr *) + +let get_desc t = (repr t).desc +let get_level t = (repr t).level +let get_scope t = (repr t).scope +let get_id t = (repr t).id + +(* transient type_expr *) + +module Transient_expr = struct + let create desc ~level ~scope ~id = {desc; level; scope; id} + let set_desc ty d = ty.desc <- d + let set_stub_desc ty d = assert (ty.desc = Tvar None); ty.desc <- d + let set_level ty lv = ty.level <- lv + let set_scope ty sc = ty.scope <- sc + let coerce ty = ty + let repr = repr + let type_expr ty = ty +end + +(* Comparison for [type_expr]; cannot be used for functors *) + +let eq_type t1 t2 = t1 == t2 || repr t1 == repr t2 +let compare_type t1 t2 = compare (get_id t1) (get_id t2) + +(* Constructor and accessors for [row_desc] *) + +let create_row ~fields ~more ~closed ~fixed ~name = + { row_fields=fields; row_more=more; + row_closed=closed; row_fixed=fixed; row_name=name } + +(* [row_fields] subsumes the original [row_repr] *) +let rec row_fields row = + match get_desc row.row_more with + | Tvariant row' -> + row.row_fields @ row_fields row' + | _ -> + row.row_fields + +let rec row_repr_no_fields row = + match get_desc row.row_more with + | Tvariant row' -> row_repr_no_fields row' + | _ -> row + +let row_more row = (row_repr_no_fields row).row_more +let row_closed row = (row_repr_no_fields row).row_closed +let row_fixed row = (row_repr_no_fields row).row_fixed +let row_name row = (row_repr_no_fields row).row_name + +let rec get_row_field tag row = + let rec find = function + | (tag',f) :: fields -> + if tag = tag' then f else find fields + | [] -> + match get_desc row.row_more with + | Tvariant row' -> get_row_field tag row' + | _ -> RFabsent + in find row.row_fields + +let set_row_name row row_name = + let row_fields = row_fields row in + let row = row_repr_no_fields row in + {row with row_fields; row_name} + +type row_desc_repr = + Row of { fields: (label * row_field) list; + more:type_expr; + closed:bool; + fixed:fixed_explanation option; + name:(Path.t * type_expr list) option } + +let row_repr row = + let fields = row_fields row in + let row = row_repr_no_fields row in + Row { fields; + more = row.row_more; + closed = row.row_closed; + fixed = row.row_fixed; + name = row.row_name } + +type row_field_view = + Rpresent of type_expr option + | Reither of bool * type_expr list * bool + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) + | Rabsent + +let rec row_field_repr_aux tl : row_field -> row_field = function + | RFeither ({ext = {contents = RFnone}} as r) -> + RFeither {r with arg_type = tl@r.arg_type} + | RFeither {arg_type; + ext = {contents = RFeither _ | RFpresent _ | RFabsent as rf}} -> + row_field_repr_aux (tl@arg_type) rf + | RFpresent (Some _) when tl <> [] -> + RFpresent (Some (List.hd tl)) + | RFpresent _ as rf -> rf + | RFabsent -> RFabsent + +let row_field_repr fi = + match row_field_repr_aux [] fi with + | RFeither {no_arg; arg_type; matched} -> Reither (no_arg, arg_type, matched) + | RFpresent t -> Rpresent t + | RFabsent -> Rabsent + +let rec row_field_ext (fi : row_field) = + match fi with + | RFeither {ext = {contents = RFnone} as ext} -> ext + | RFeither {ext = {contents = RFeither _ | RFpresent _ | RFabsent as rf}} -> + row_field_ext rf + | _ -> Misc.fatal_error "Types.row_field_ext " + +let rf_present oty = RFpresent oty +let rf_absent = RFabsent +let rf_either ?use_ext_of ~no_arg arg_type ~matched = + let ext = + match use_ext_of with + Some rf -> row_field_ext rf + | None -> ref RFnone + in + RFeither {no_arg; arg_type; matched; ext} + +let rf_either_of = function + | None -> + RFeither {no_arg=true; arg_type=[]; matched=false; ext=ref RFnone} + | Some ty -> + RFeither {no_arg=false; arg_type=[ty]; matched=false; ext=ref RFnone} + +let eq_row_field_ext rf1 rf2 = + row_field_ext rf1 == row_field_ext rf2 + +let changed_row_field_exts l f = + let exts = List.map row_field_ext l in + f (); + List.exists (fun r -> !r <> RFnone) exts + +let match_row_field ~present ~absent ~either (f : row_field) = + match f with + | RFabsent -> absent () + | RFpresent t -> present t + | RFeither {no_arg; arg_type; matched; ext} -> + let e : row_field option = + match !ext with + | RFnone -> None + | RFeither _ | RFpresent _ | RFabsent as e -> Some e + in + either no_arg arg_type matched e + + +(**** Some type creators ****) + +let new_id = Local_store.s_ref (-1) + +let create_expr = Transient_expr.create + +let newty3 ~level ~scope desc = + incr new_id; + create_expr desc ~level ~scope ~id:!new_id + +let newty2 ~level desc = + newty3 ~level ~scope:Ident.lowest_scope desc + + (**********************************) + (* Utilities for backtracking *) + (**********************************) + +let undo_change = function + Ctype (ty, desc) -> Transient_expr.set_desc ty desc + | Ccompress (ty, desc, _) -> Transient_expr.set_desc ty desc + | Clevel (ty, level) -> Transient_expr.set_level ty level + | Cscope (ty, scope) -> Transient_expr.set_scope ty scope + | Cname (r, v) -> r := v + | Crow r -> r := RFnone + | Ckind (FKvar r) -> r.field_kind <- FKprivate + | Ccommu (Cvar r) -> r.commu <- Cunknown + | Cuniv (r, v) -> r := v + | Cmode_upper (v, u) -> v.upper <- u + | Cmode_lower (v, l) -> v.lower <- l + | Cmode_vlower (v, vs) -> v.vlower <- vs + +type snapshot = changes ref * int +let last_snapshot = Local_store.s_ref 0 + +let log_type ty = + if ty.id <= !last_snapshot then log_change (Ctype (ty, ty.desc)) +let link_type ty ty' = + let ty = repr ty in + let ty' = repr ty' in + if ty == ty' then () else begin + log_type ty; + let desc = ty.desc in + Transient_expr.set_desc ty (Tlink ty'); + (* Name is a user-supplied name for this unification variable (obtained + * through a type annotation for instance). *) + match desc, ty'.desc with + Tvar name, Tvar name' -> + begin match name, name' with + | Some _, None -> log_type ty'; Transient_expr.set_desc ty' (Tvar name) + | None, Some _ -> () + | Some _, Some _ -> + if ty.level < ty'.level then + (log_type ty'; Transient_expr.set_desc ty' (Tvar name)) + | None, None -> () + end + | _ -> () + end + (* ; assert (check_memorized_abbrevs ()) *) + (* ; check_expans [] ty' *) +(* TODO: consider eliminating set_type_desc, replacing it with link types *) +let set_type_desc ty td = + let ty = repr ty in + if td != ty.desc then begin + log_type ty; + Transient_expr.set_desc ty td + end +(* TODO: separate set_level into two specific functions: *) +(* set_lower_level and set_generic_level *) +let set_level ty level = + let ty = repr ty in + if level <> ty.level then begin + if ty.id <= !last_snapshot then log_change (Clevel (ty, ty.level)); + Transient_expr.set_level ty level + end +(* TODO: introduce a guard and rename it to set_higher_scope? *) +let set_scope ty scope = + let ty = repr ty in + if scope <> ty.scope then begin + if ty.id <= !last_snapshot then log_change (Cscope (ty, ty.scope)); + Transient_expr.set_scope ty scope + end +let set_univar rty ty = + log_change (Cuniv (rty, !rty)); rty := Some ty +let set_name nm v = + log_change (Cname (nm, !nm)); nm := v + +let rec link_row_field_ext ~(inside : row_field) (v : row_field) = + match inside with + | RFeither {ext = {contents = RFnone} as e} -> + let RFeither _ | RFpresent _ | RFabsent as v = v in + log_change (Crow e); e := v + | RFeither {ext = {contents = RFeither _ | RFpresent _ | RFabsent as rf}} -> + link_row_field_ext ~inside:rf v + | _ -> invalid_arg "Types.link_row_field_ext" + +let rec link_kind ~(inside : field_kind) (k : field_kind) = + match inside with + | FKvar ({field_kind = FKprivate} as rk) as inside -> + (* prevent a loop by normalizing k and comparing it with inside *) + let FKvar _ | FKpublic | FKabsent as k = field_kind_internal_repr k in + if k != inside then begin + log_change (Ckind inside); + rk.field_kind <- k + end + | FKvar {field_kind = FKvar _ | FKpublic | FKabsent as inside} -> + link_kind ~inside k + | _ -> invalid_arg "Types.link_kind" + +let rec commu_repr : commutable -> commutable = function + | Cvar {commu = Cvar _ | Cok as commu} -> commu_repr commu + | c -> c + +let rec link_commu ~(inside : commutable) (c : commutable) = + match inside with + | Cvar ({commu = Cunknown} as rc) as inside -> + (* prevent a loop by normalizing c and comparing it with inside *) + let Cvar _ | Cok as c = commu_repr c in + if c != inside then begin + log_change (Ccommu inside); + rc.commu <- c + end + | Cvar {commu = Cvar _ | Cok as inside} -> + link_commu ~inside c + | _ -> invalid_arg "Types.link_commu" + +let set_commu_ok c = link_commu ~inside:c Cok + +let snapshot () = + let old = !last_snapshot in + last_snapshot := !new_id; + (!trail, old) + +let rec rev_log accu = function + Unchanged -> accu + | Invalid -> assert false + | Change (ch, next) -> + let d = !next in + next := Invalid; + rev_log (ch::accu) d + +let backtrack ~cleanup_abbrev (changes, old) = + match !changes with + Unchanged -> last_snapshot := old + | Invalid -> failwith "Types.backtrack" + | Change _ as change -> + cleanup_abbrev (); + let backlog = rev_log [] change in + List.iter undo_change backlog; + changes := Unchanged; + last_snapshot := old; + trail := changes + +let undo_first_change_after (changes, _) = + match !changes with + | Change (ch, _) -> + undo_change ch + | _ -> () + +let rec rev_compress_log log r = + match !r with + Unchanged | Invalid -> + log + | Change (Ccompress _, next) -> + rev_compress_log (r::log) next + | Change (_, next) -> + rev_compress_log log next + +let undo_compress (changes, _old) = + match !changes with + Unchanged + | Invalid -> () + | Change _ -> + let log = rev_compress_log [] changes in + List.iter + (fun r -> match !r with + Change (Ccompress (ty, desc, d), next) when ty.desc == d -> + Transient_expr.set_desc ty desc; r := !next + | _ -> ()) + log + +module Alloc_mode = struct + type nonrec const = alloc_mode_const = Global | Local + type t = alloc_mode = + | Amode of const + | Amodevar of alloc_mode_var + + let global = Amode Global + let local = Amode Local + let of_const = function + | Global -> global + | Local -> local + + let min_mode = global + + let max_mode = local + + let le_const a b = + match a, b with + | Global, _ | _, Local -> true + | Local, Global -> false + + let join_const a b = + match a, b with + | Local, _ | _, Local -> Local + | Global, Global -> Global + + let meet_const a b = + match a, b with + | Global, _ | _, Global -> Global + | Local, Local -> Local + + exception NotSubmode +(* + let pp_c ppf = function + | Global -> Printf.fprintf ppf "0" + | Local -> Printf.fprintf ppf "1" + let pp_v ppf v = + let i = v.mvid in + (if i < 26 then Printf.fprintf ppf "%c" (Char.chr (Char.code 'a' + i)) + else Printf.fprintf ppf "v%d" i); + Printf.fprintf ppf "[%a%a]" pp_c v.lower pp_c v.upper +*) + + let set_lower ~log v lower = + append_change log (Cmode_lower (v, v.lower)); + v.lower <- lower + + let set_upper ~log v upper = + append_change log (Cmode_upper (v, v.upper)); + v.upper <- upper + + let set_vlower ~log v vlower = + append_change log (Cmode_vlower (v, v.vlower)); + v.vlower <- vlower + + let submode_cv ~log m v = + (* Printf.printf " %a <= %a\n" pp_c m pp_v v; *) + if le_const m v.lower then () + else if not (le_const m v.upper) then raise NotSubmode + else begin + let m = join_const v.lower m in + set_lower ~log v m; + if m = v.upper then set_vlower ~log v [] + end + + let rec submode_vc ~log v m = + (* Printf.printf " %a <= %a\n" pp_v v pp_c m; *) + if le_const v.upper m then () + else if not (le_const v.lower m) then raise NotSubmode + else begin + let m = meet_const v.upper m in + set_upper ~log v m; + v.vlower |> List.iter (fun a -> + (* a <= v <= m *) + submode_vc ~log a m; + set_lower ~log v (join_const v.lower a.lower); + ); + if v.lower = m then set_vlower ~log v [] + end + + let submode_vv ~log a b = + (* Printf.printf " %a <= %a\n" pp_v a pp_v b; *) + if le_const a.upper b.lower then () + else if a == b || List.memq a b.vlower then () + else begin + submode_vc ~log a b.upper; + set_vlower ~log b (a :: b.vlower); + submode_cv ~log a.lower b; + end + + let submode a b = + let log_head = ref Unchanged in + let log = ref log_head in + match + match a, b with + | Amode a, Amode b -> + if not (le_const a b) then raise NotSubmode + | Amodevar v, Amode c -> + (* Printf.printf "%a <= %a\n" pp_v v pp_c c; *) + submode_vc ~log v c + | Amode c, Amodevar v -> + (* Printf.printf "%a <= %a\n" pp_c c pp_v v; *) + submode_cv ~log c v + | Amodevar a, Amodevar b -> + (* Printf.printf "%a <= %a\n" pp_v a pp_v b; *) + submode_vv ~log a b + with + | () -> + log_changes !log_head !log; + Ok () + | exception NotSubmode -> + let backlog = rev_log [] !log_head in + List.iter undo_change backlog; + Error () + + let submode_exn t1 t2 = + match submode t1 t2 with + | Ok () -> () + | Error () -> invalid_arg "submode_exn" + + let equate a b = + match submode a b, submode b a with + | Ok (), Ok () -> Ok () + | Error (), _ | _, Error () -> Error () + + let make_global_exn t = + submode_exn t global + + let make_local_exn t = + submode_exn local t + + let next_id = ref (-1) + let fresh () = + incr next_id; + { upper = Local; + lower = Global; + vlower = []; + mvid = !next_id; + mark = false } + + let rec all_equal v = function + | [] -> true + | v' :: rest -> + if v == v' then all_equal v rest + else false + + let joinvars vars = + match vars with + | [] -> global + | v :: rest -> + let v = + if all_equal v rest then v + else begin + let v = fresh () in + List.iter (fun v' -> submode_exn (Amodevar v') (Amodevar v)) vars; + v + end + in + Amodevar v + + let join ms = + let rec aux vars = function + | [] -> joinvars vars + | Amode Global :: ms -> aux vars ms + | Amode Local :: _ -> local + | Amodevar v :: ms -> aux (v :: vars) ms + in aux [] ms + + let constrain_upper = function + | Amode m -> m + | Amodevar v -> + submode_exn (Amode v.upper) (Amodevar v); + v.upper + + exception Became_constant + let compress_vlower v = + let nmarked = ref 0 in + let mark v' = + assert (not v'.mark); + v'.mark <- true; + incr nmarked + in + let unmark v' = + assert v'.mark; + v'.mark <- false; + decr nmarked + in + let new_lower = ref v.lower in + let new_vlower = ref v.vlower in + (* Ensure that each transitive lower bound of v + is a direct lower bound of v *) + let rec trans v' = + if le_const v'.upper !new_lower then () + else if v'.mark then () + else begin + mark v'; + new_vlower := v' :: !new_vlower; + trans_low v' + end + and trans_low v' = + assert (v != v'); + if not (le_const v'.lower v.upper) then + Misc.fatal_error "compress_vlower: invalid bounds"; + if not (le_const v'.lower !new_lower) then begin + new_lower := join_const !new_lower v'.lower; + if !new_lower = v.upper then + (* v is now a constant, no need to keep computing bounds *) + raise Became_constant + end; + List.iter trans v'.vlower + in + mark v; + List.iter mark v.vlower; + let became_constant = + match List.iter trans_low v.vlower with + | () -> false + | exception Became_constant -> true + in + List.iter unmark !new_vlower; + unmark v; + assert (!nmarked = 0); + if became_constant then new_vlower := []; + if !new_lower != v.lower || !new_vlower != v.vlower then begin + let log_head = ref Unchanged in + let log = ref log_head in + set_lower ~log v !new_lower; + set_vlower ~log v !new_vlower; + log_changes !log_head !log; + end + + let constrain_lower = function + | Amode m -> m + | Amodevar v -> + compress_vlower v; + submode_exn (Amodevar v) (Amode v.lower); + v.lower + + let newvar () = Amodevar (fresh ()) + + let newvar_below = function + | Amode Global -> Amode Global, false + | m -> + let v = newvar () in + submode_exn v m; + v, true + + let newvar_above = function + | Amode Local -> Amode Local, false + | m -> + let v = newvar () in + submode_exn m v; + v, true + + let check_const = function + | Amode m -> Some m + | Amodevar v -> + compress_vlower v; + if v.lower = v.upper then Some v.lower else None + + let print_const ppf = function + | Global -> Format.fprintf ppf "Global" + | Local -> Format.fprintf ppf "Local" + + let print_var_id ppf v = + Format.fprintf ppf "?%i" v.mvid + + let print_var ppf v = + compress_vlower v; + if v.lower = v.upper then begin + print_const ppf v.lower + end else if v.vlower = [] then begin + print_var_id ppf v + end else begin + Format.fprintf ppf "%a[> %a]" + print_var_id v + (Format.pp_print_list print_var_id) v.vlower + end + + let print ppf = function + | Amode m -> print_const ppf m + | Amodevar v -> print_var ppf v + +end + +module Value_mode = struct + + type const = + | Global + | Regional + | Local + + let r_as_l : const -> Alloc_mode.const = function + | Global -> Global + | Regional -> Local + | Local -> Local + [@@warning "-unused-value-declaration"] + + let r_as_g : const -> Alloc_mode.const = function + | Global -> Global + | Regional -> Global + | Local -> Local + [@@warning "-unused-value-declaration"] + + let of_alloc_consts + ~(r_as_l : Alloc_mode.const) + ~(r_as_g : Alloc_mode.const) = + match r_as_l, r_as_g with + | Global, Global -> Global + | Global, Local -> assert false + | Local, Global -> Regional + | Local, Local -> Local + + type t = value_mode = + { r_as_l : Alloc_mode.t; + (* [r_as_l] is the image of the mode under the [r_as_l] function *) + r_as_g : Alloc_mode.t; + (* [r_as_g] is the image of the mode under the [r_as_g] function. + Always less than [r_as_l]. *) } + + let global = + let r_as_l = Alloc_mode.global in + let r_as_g = Alloc_mode.global in + { r_as_l; r_as_g } + + let regional = + let r_as_l = Alloc_mode.local in + let r_as_g = Alloc_mode.global in + { r_as_l; r_as_g } + + let local = + let r_as_l = Alloc_mode.local in + let r_as_g = Alloc_mode.local in + { r_as_l; r_as_g } + + let of_const = function + | Global -> global + | Regional -> regional + | Local -> local + + let max_mode = + let r_as_l = Alloc_mode.max_mode in + let r_as_g = Alloc_mode.max_mode in + { r_as_l; r_as_g } + + let min_mode = + let r_as_l = Alloc_mode.min_mode in + let r_as_g = Alloc_mode.min_mode in + { r_as_l; r_as_g } + + let of_alloc mode = + let r_as_l = mode in + let r_as_g = mode in + { r_as_l; r_as_g } + + let local_to_regional t = { t with r_as_g = Alloc_mode.global } + + let regional_to_global t = { t with r_as_l = t.r_as_g } + + let regional_to_local t = { t with r_as_g = t.r_as_l } + + let global_to_regional t = { t with r_as_l = Alloc_mode.local } + + let regional_to_global_alloc t = t.r_as_g + + let regional_to_local_alloc t = t.r_as_l + + type error = [`Regionality | `Locality] + + let submode t1 t2 = + match Alloc_mode.submode t1.r_as_l t2.r_as_l with + | Error () -> Error `Regionality + | Ok () as ok -> begin + match Alloc_mode.submode t1.r_as_g t2.r_as_g with + | Ok () -> ok + | Error () -> Error `Locality + end + + let submode_exn t1 t2 = + match submode t1 t2 with + | Ok () -> () + | Error _ -> invalid_arg "submode_exn" + + let rec submode_meet t = function + | [] -> Ok () + | t' :: rest -> + match submode t t' with + | Ok () -> submode_meet t rest + | Error _ as err -> err + + let join ts = + let r_as_l = Alloc_mode.join (List.map (fun t -> t.r_as_l) ts) in + let r_as_g = Alloc_mode.join (List.map (fun t -> t.r_as_g) ts) in + { r_as_l; r_as_g } + + let constrain_upper t = + let r_as_l = Alloc_mode.constrain_upper t.r_as_l in + let r_as_g = Alloc_mode.constrain_upper t.r_as_g in + of_alloc_consts ~r_as_l ~r_as_g + + let constrain_lower t = + let r_as_l = Alloc_mode.constrain_lower t.r_as_l in + let r_as_g = Alloc_mode.constrain_lower t.r_as_g in + of_alloc_consts ~r_as_l ~r_as_g + + let newvar () = + let r_as_l = Alloc_mode.newvar () in + let r_as_g = Alloc_mode.newvar () in + Alloc_mode.submode_exn r_as_g r_as_l; + { r_as_l; r_as_g } + + let newvar_below = function + | { r_as_l = Amode Global; + r_as_g = Amode Global } -> + global + | m -> + let v = newvar () in + submode_exn v m; + v + + let check_const t = + match Alloc_mode.check_const t.r_as_l with + | None -> None + | Some r_as_l -> + match Alloc_mode.check_const t.r_as_g with + | None -> None + | Some r_as_g -> + Some (of_alloc_consts ~r_as_l ~r_as_g) + + let print_const ppf = function + | Global -> Format.fprintf ppf "Global" + | Regional -> Format.fprintf ppf "Regional" + | Local -> Format.fprintf ppf "Local" + + let print ppf t = + match check_const t with + | Some const -> print_const ppf const + | None -> + Format.fprintf ppf + "@[<2>r_as_l: %a@ r_as_g: %a@]" + Alloc_mode.print t.r_as_l + Alloc_mode.print t.r_as_g + +end diff --git a/ocaml/typing/types.mli b/ocaml/typing/types.mli index 7bbb73c622c..ddc0072db94 100644 --- a/ocaml/typing/types.mli +++ b/ocaml/typing/types.mli @@ -55,13 +55,13 @@ open Asttypes Note on mutability: TBD. *) -type type_expr = - { mutable desc: type_desc; - mutable level: int; - mutable scope: int; - id: int } +type type_expr +type row_desc +type row_field +type field_kind +type commutable -and type_desc = +type type_desc = | Tvar of string option (** [Tvar (Some "a")] ==> ['a] or ['_a] [Tvar None] ==> [_] *) @@ -71,7 +71,8 @@ and type_desc = [Tarrow (Labelled "l", e1, e2, c)] ==> [l:e1 -> e2] [Tarrow (Optional "l", e1, e2, c)] ==> [?l:e1 -> e2] - See [commutable] for the last argument. *) + See [commutable] for the last argument. The argument + type must be a [Tpoly] node *) | Ttuple of type_expr list (** [Ttuple [t1;...;tn]] ==> [(t1 * ... * tn)] *) @@ -100,7 +101,7 @@ and type_desc = *) | Tfield of string * field_kind * type_expr * type_expr - (** [Tfield ("foo", Fpresent, t, ts)] ==> [<...; foo : t; ts>] *) + (** [Tfield ("foo", field_public, t, ts)] ==> [<...; foo : t; ts>] *) | Tnil (** [Tnil] ==> [<...; >] *) @@ -108,10 +109,13 @@ and type_desc = | Tlink of type_expr (** Indirection used by unification engine. *) - | Tsubst of type_expr (* for copying *) + | Tsubst of type_expr * type_expr option (** [Tsubst] is used temporarily to store information in low-level functions manipulating representation of types, such as instantiation or copy. + The first argument contains a copy of the original node. + The second is available only when the first is the row variable of + a polymorphic variant. It then contains a copy of the whole variant. This constructor should not appear outside of these cases. *) | Tvariant of row_desc @@ -126,7 +130,7 @@ and type_desc = where 'a1 ... 'an are names given to types in tyl and occurrences of those types in ty. *) - | Tpackage of Path.t * Longident.t list * type_expr list + | Tpackage of Path.t * (Longident.t * type_expr) list (** Type of a first-class module (a.k.a package). *) and arrow_desc = @@ -146,52 +150,11 @@ and alloc_mode = | Amode of alloc_mode_const | Amodevar of alloc_mode_var - -(** [ `X | `Y ] (row_closed = true) - [< `X | `Y ] (row_closed = true) - [> `X | `Y ] (row_closed = false) - [< `X | `Y > `X ] (row_closed = true) - - type t = [> `X ] as 'a (row_more = Tvar a) - type t = private [> `X ] (row_more = Tconstr (t#row, [], ref Mnil)) - - And for: - - let f = function `X -> `X -> | `Y -> `X - - the type of "f" will be a [Tarrow] whose lhs will (basically) be: - - Tvariant { row_fields = [("X", _)]; - row_more = - Tvariant { row_fields = [("Y", _)]; - row_more = - Tvariant { row_fields = []; - row_more = _; - _ }; - _ }; - _ - } - -*) -and row_desc = - { row_fields: (label * row_field) list; - row_more: type_expr; - row_bound: unit; (* kept for compatibility *) - row_closed: bool; - row_fixed: fixed_explanation option; - row_name: (Path.t * type_expr list) option } and fixed_explanation = | Univar of type_expr (** The row type was bound to an univar *) | Fixed_private (** The row type is private *) | Reified of Path.t (** The row was reified *) | Rigid (** The row type was made rigid during constraint verification *) -and row_field = - Rpresent of type_expr option - | Reither of bool * type_expr list * bool * row_field option ref - (* 1st true denotes a constant constructor *) - (* 2nd true denotes a tag in a pattern matching, and - is erased later *) - | Rabsent (** [abbrev_memo] allows one to keep track of different expansions of a type alias. This is done for performance purposes. @@ -220,23 +183,18 @@ and abbrev_memo = | Mlink of abbrev_memo ref (** Abbreviations can be found after this indirection *) -and field_kind = - Fvar of field_kind option ref - | Fpresent - | Fabsent - (** [commutable] is a flag appended to every arrow type. When typing an application, if the type of the functional is - known, its type is instantiated with [Cok] arrows, otherwise as - [Clink (ref Cunknown)]. + known, its type is instantiated with [commu_ok] arrows, otherwise as + [commu_var ()]. When the type is not known, the application will be used to infer the actual type. This is fragile in presence of labels where there is no principal type. - Two incompatible applications relying on [Cunknown] arrows will - trigger an error. + Two incompatible applications must rely on [is_commu_ok] arrows, + otherwise they will trigger an error. let f g = g ~a:() ~b:(); @@ -246,36 +204,180 @@ and field_kind = in an order different from other calls. This is only allowed when the real type is known. *) -and commutable = - Cok - | Cunknown - | Clink of commutable ref -module TypeOps : sig - type t = type_expr +val is_commu_ok: commutable -> bool +val commu_ok: commutable +val commu_var: unit -> commutable + +(** [field_kind] indicates the accessibility of a method. + + An [Fprivate] field may become [Fpublic] or [Fabsent] during unification, + but not the other way round. + + The same [field_kind] is kept shared when copying [Tfield] nodes + so that the copies of the self-type of a class share the same accessibility + (see also PR#10539). + *) + +type field_kind_view = + Fprivate + | Fpublic + | Fabsent + +val field_kind_repr: field_kind -> field_kind_view +val field_public: field_kind +val field_absent: field_kind +val field_private: unit -> field_kind +val field_kind_internal_repr: field_kind -> field_kind + (* Removes indirections in [field_kind]. + Only needed for performance. *) + +(** Getters for type_expr; calls repr before answering a value *) + +val get_desc: type_expr -> type_desc +val get_level: type_expr -> int +val get_scope: type_expr -> int +val get_id: type_expr -> int + +(** Transient [type_expr]. + Should only be used immediately after [Transient_expr.repr] *) +type transient_expr = private + { mutable desc: type_desc; + mutable level: int; + mutable scope: int; + id: int } + +module Transient_expr : sig + (** Operations on [transient_expr] *) + + val create: type_desc -> level: int -> scope: int -> id: int -> transient_expr + val set_desc: transient_expr -> type_desc -> unit + val set_level: transient_expr -> int -> unit + val set_scope: transient_expr -> int -> unit + val repr: type_expr -> transient_expr + val type_expr: transient_expr -> type_expr + val coerce: type_expr -> transient_expr + (** Coerce without normalizing with [repr] *) + + val set_stub_desc: type_expr -> type_desc -> unit + (** Instantiate a not yet instantiated stub. + Fail if already instantiated. *) +end + +val create_expr: type_desc -> level: int -> scope: int -> id: int -> type_expr + +(** Functions and definitions moved from Btype *) + +val newty3: level:int -> scope:int -> type_desc -> type_expr + (** Create a type with a fresh id *) + +val newty2: level:int -> type_desc -> type_expr + (** Create a type with a fresh id and no scope *) + +module TransientTypeOps : sig + (** Comparisons for functors *) + + type t = transient_expr val compare : t -> t -> int val equal : t -> t -> bool val hash : t -> int end -(* *) +(** Comparisons for [type_expr]; cannot be used for functors *) -module Uid : sig - type t +val eq_type: type_expr -> type_expr -> bool +val compare_type: type_expr -> type_expr -> int + +(** Constructor and accessors for [row_desc] *) + +(** [ `X | `Y ] (row_closed = true) + [< `X | `Y ] (row_closed = true) + [> `X | `Y ] (row_closed = false) + [< `X | `Y > `X ] (row_closed = true) - val reinit : unit -> unit + type t = [> `X ] as 'a (row_more = Tvar a) + type t = private [> `X ] (row_more = Tconstr ("t#row", [], ref Mnil)) - val mk : current_unit:string -> t - val of_compilation_unit_id : Ident.t -> t - val of_predef_id : Ident.t -> t - val internal_not_actually_unique : t + And for: - val for_actual_declaration : t -> bool + let f = function `X -> `X -> | `Y -> `X - include Identifiable.S with type t := t -end + the type of "f" will be a [Tarrow] whose lhs will (basically) be: + + Tvariant { row_fields = [("X", _)]; + row_more = + Tvariant { row_fields = [("Y", _)]; + row_more = + Tvariant { row_fields = []; + row_more = _; + _ }; + _ }; + _ + } + +*) + +val create_row: + fields:(label * row_field) list -> + more:type_expr -> + closed:bool -> + fixed:fixed_explanation option -> + name:(Path.t * type_expr list) option -> row_desc + +val row_fields: row_desc -> (label * row_field) list +val row_more: row_desc -> type_expr +val row_closed: row_desc -> bool +val row_fixed: row_desc -> fixed_explanation option +val row_name: row_desc -> (Path.t * type_expr list) option + +val set_row_name: row_desc -> (Path.t * type_expr list) option -> row_desc + +val get_row_field: label -> row_desc -> row_field + +(** get all fields at once; different from the old [row_repr] *) +type row_desc_repr = + Row of { fields: (label * row_field) list; + more: type_expr; + closed: bool; + fixed: fixed_explanation option; + name: (Path.t * type_expr list) option } + +val row_repr: row_desc -> row_desc_repr + +(** Current contents of a row field *) +type row_field_view = + Rpresent of type_expr option + | Reither of bool * type_expr list * bool + (* 1st true denotes a constant constructor *) + (* 2nd true denotes a tag in a pattern matching, and + is erased later *) + | Rabsent + +val row_field_repr: row_field -> row_field_view +val rf_present: type_expr option -> row_field +val rf_absent: row_field +val rf_either: + ?use_ext_of:row_field -> + no_arg:bool -> type_expr list -> matched:bool -> row_field +val rf_either_of: type_expr option -> row_field -(* Maps of methods and instance variables *) +val eq_row_field_ext: row_field -> row_field -> bool +val changed_row_field_exts: row_field list -> (unit -> unit) -> bool + +val match_row_field: + present:(type_expr option -> 'a) -> + absent:(unit -> 'a) -> + either:(bool -> type_expr list -> bool -> row_field option ->'a) -> + row_field -> 'a + +(* *) + +module Uid = Shape.Uid + +(* Sets and maps of methods and instance variables *) + +module MethSet : Set.S with type elt = string +module VarSet : Set.S with type elt = string module Meths : Map.S with type key = string module Vars : Map.S with type key = string @@ -294,13 +396,26 @@ and value_kind = Val_reg (* Regular value *) | Val_prim of Primitive.description (* Primitive *) | Val_ivar of mutable_flag * string (* Instance variable (mutable ?) *) - | Val_self of (Ident.t * type_expr) Meths.t ref * - (Ident.t * mutable_flag * virtual_flag * type_expr) Vars.t ref * - string * type_expr + | Val_self of class_signature * self_meths * Ident.t Vars.t * string (* Self *) - | Val_anc of (string * Ident.t) list * string + | Val_anc of class_signature * Ident.t Meths.t * string (* Ancestor *) +and self_meths = + | Self_concrete of Ident.t Meths.t + | Self_virtual of Ident.t Meths.t ref + +and class_signature = + { csig_self: type_expr; + mutable csig_self_row: type_expr; + mutable csig_vars: (mutable_flag * virtual_flag * type_expr) Vars.t; + mutable csig_meths: (method_privacy * virtual_flag * type_expr) Meths.t; } + +and method_privacy = + | Mpublic + | Mprivate of field_kind + (* The [field_kind] is always [Fabsent] in a complete class type. *) + (* Variance *) module Variance : sig @@ -367,7 +482,7 @@ end type type_declaration = { type_params: type_expr list; type_arity: int; - type_kind: type_kind; + type_kind: type_decl_kind; type_private: private_flag; type_manifest: type_expr option; type_variance: Variance.t list; @@ -378,14 +493,17 @@ type type_declaration = type_loc: Location.t; type_attributes: Parsetree.attributes; type_immediate: Type_immediacy.t; - type_unboxed: unboxed_status; + type_unboxed_default: bool; + (* true if the unboxed-ness of this type was chosen by a compiler flag *) type_uid: Uid.t; } -and type_kind = +and type_decl_kind = (label_declaration, constructor_declaration) type_kind + +and ('lbl, 'cstr) type_kind = Type_abstract - | Type_record of label_declaration list * record_representation - | Type_variant of constructor_declaration list + | Type_record of 'lbl list * record_representation + | Type_variant of 'cstr list * variant_representation | Type_open and record_representation = @@ -395,6 +513,10 @@ and record_representation = | Record_inlined of int (* Inlined record *) | Record_extension of Path.t (* Inlined record under extension *) +and variant_representation = + Variant_regular (* Constant or boxed constructors *) + | Variant_unboxed (* One unboxed single-field constructor *) + and global_flag = | Global | Nonlocal @@ -422,23 +544,9 @@ and constructor_declaration = } and constructor_arguments = - | Cstr_tuple of type_expr list + | Cstr_tuple of (type_expr * global_flag) list | Cstr_record of label_declaration list -and unboxed_status = private - (* This type must be private in order to ensure perfect sharing of the - four possible values. Otherwise, ocamlc.byte and ocamlc.opt produce - different executables. *) - { - unboxed: bool; - default: bool; (* True for unannotated unboxable types. *) - } - -val unboxed_false_default_false : unboxed_status -val unboxed_false_default_true : unboxed_status -val unboxed_true_default_false : unboxed_status -val unboxed_true_default_true : unboxed_status - type extension_constructor = { ext_type_path: Path.t; @@ -458,20 +566,11 @@ and type_transparence = (* Type expressions for the class language *) -module Concr : Set.S with type elt = string - type class_type = Cty_constr of Path.t * type_expr list * class_type | Cty_signature of class_signature | Cty_arrow of arg_label * type_expr * class_type -and class_signature = - { csig_self: type_expr; - csig_vars: - (Asttypes.mutable_flag * Asttypes.virtual_flag * type_expr) Vars.t; - csig_concr: Concr.t; - csig_inher: (Path.t * type_expr list) list } - type class_declaration = { cty_params: type_expr list; mutable cty_type: class_type; @@ -551,6 +650,7 @@ and ext_status = | Text_next (* not first constructor in an extension *) | Text_exception +val item_visibility : signature_item -> visibility (* Constructor and record label descriptions inserted held in typing environments *) @@ -559,12 +659,11 @@ type constructor_description = { cstr_name: string; (* Constructor name *) cstr_res: type_expr; (* Type of the result *) cstr_existentials: type_expr list; (* list of existentials *) - cstr_args: type_expr list; (* Type of the arguments *) + cstr_args: (type_expr * global_flag) list; (* Type of the arguments *) cstr_arity: int; (* Number of arguments *) cstr_tag: constructor_tag; (* Tag for heap blocks *) cstr_consts: int; (* Number of constant constructors *) cstr_nonconsts: int; (* Number of non-const constructors *) - cstr_normal: int; (* Number of non generalized constrs *) cstr_generalized: bool; (* Constrained return type? *) cstr_private: private_flag; (* Read-only constructor? *) cstr_loc: Location.t; @@ -611,6 +710,192 @@ val bound_value_identifiers: signature -> Ident.t list val signature_item_id : signature_item -> Ident.t type value_mode = - (* See Btype.Value_mode *) + (* See Value_mode below *) { r_as_l : alloc_mode; r_as_g : alloc_mode; } + +(**** Utilities for backtracking ****) + +type snapshot + (* A snapshot for backtracking *) +val snapshot: unit -> snapshot + (* Make a snapshot for later backtracking. Costs nothing *) +val backtrack: cleanup_abbrev:(unit -> unit) -> snapshot -> unit + (* Backtrack to a given snapshot. Only possible if you have + not already backtracked to a previous snapshot. + Calls [cleanup_abbrev] internally *) +val undo_first_change_after: snapshot -> unit + (* Backtrack only the first change after a snapshot. + Does not update the list of changes *) +val undo_compress: snapshot -> unit + (* Backtrack only path compression. Only meaningful if you have + not already backtracked to a previous snapshot. + Does not call [cleanup_abbrev] *) + +(** Functions to use when modifying a type (only Ctype?). + The old values are logged and reverted on backtracking. + *) + +val link_type: type_expr -> type_expr -> unit + (* Set the desc field of [t1] to [Tlink t2], logging the old + value if there is an active snapshot *) +val set_type_desc: type_expr -> type_desc -> unit + (* Set directly the desc field, without sharing *) +val set_level: type_expr -> int -> unit +val set_scope: type_expr -> int -> unit +val set_name: + (Path.t * type_expr list) option ref -> + (Path.t * type_expr list) option -> unit +val link_row_field_ext: inside:row_field -> row_field -> unit + (* Extract the extension variable of [inside] and set it to the + second argument *) +val set_univar: type_expr option ref -> type_expr -> unit +val link_kind: inside:field_kind -> field_kind -> unit +val link_commu: inside:commutable -> commutable -> unit +val set_commu_ok: commutable -> unit + + +(**** Allocation modes ****) + +module Alloc_mode : sig + + (* Modes are ordered so that [global] is a submode of [local] *) + type t = alloc_mode + type const = alloc_mode_const = Global | Local + + val global : t + + val local : t + + val of_const : const -> t + + val min_mode : t + + val max_mode : t + + val submode : t -> t -> (unit, unit) result + + val submode_exn : t -> t -> unit + + val equate : t -> t -> (unit, unit) result + + val make_global_exn : t -> unit + + val make_local_exn : t -> unit + + val join_const : const -> const -> const + + val join : t list -> t + + (* Force a mode variable to its upper bound *) + val constrain_upper : t -> const + + (* Force a mode variable to its lower bound *) + val constrain_lower : t -> const + + val newvar : unit -> t + + val newvar_below : t -> t * bool + + val newvar_above : t -> t * bool + + val check_const : t -> const option + + val print : Format.formatter -> t -> unit + +end + +module Value_mode : sig + + type const = + | Global + | Regional + | Local + + type t = value_mode + + val global : t + + val regional : t + + val local : t + + val of_const : const -> t + + val max_mode : t + + val min_mode : t + + (** Injections from [Alloc_mode.t] into [Value_mode.t] *) + + (** [of_alloc] maps [Global] to [Global] and [Local] to [Local] *) + val of_alloc : Alloc_mode.t -> t + + (** Kernel operators *) + + (** The kernel operator [local_to_regional] maps [Local] to + [Regional] and leaves the others unchanged. *) + val local_to_regional : t -> t + + (** The kernel operator [regional_to_global] maps [Regional] + to [Global] and leaves the others unchanged. *) + val regional_to_global : t -> t + + (** Closure operators *) + + (** The closure operator [regional_to_local] maps [Regional] + to [Local] and leaves the others unchanged. *) + val regional_to_local : t -> t + + (** The closure operator [global_to_regional] maps [Global] to + [Regional] and leaves the others unchanged. *) + val global_to_regional : t -> t + + (** Note that the kernal and closure operators are in the following + adjunction relationship: + {v + local_to_regional + -| regional_to_local + -| regional_to_global + -| global_to_regional + v} + + Equivalently, + {v + local_to_regional a <= b iff a <= regional_to_local b + regional_to_local a <= b iff a <= regional_to_global b + regional_to_global a <= b iff a <= global_to_regional b + v} + *) + + (** Versions of the operators that return [Alloc.t] *) + + (** Maps [Regional] to [Global] and leaves the others unchanged. *) + val regional_to_global_alloc : t -> Alloc_mode.t + + (** Maps [Regional] to [Local] and leaves the others unchanged. *) + val regional_to_local_alloc : t -> Alloc_mode.t + + type error = [`Regionality | `Locality] + + val submode : t -> t -> (unit, error) result + + val submode_exn : t -> t -> unit + + val submode_meet : t -> t list -> (unit, error) result + + val join : t list -> t + + val constrain_upper : t -> const + + val constrain_lower : t -> const + + val newvar : unit -> t + + val newvar_below : t -> t + + val check_const : t -> const option + + val print : Format.formatter -> t -> unit + +end diff --git a/ocaml/typing/typetexp.ml b/ocaml/typing/typetexp.ml index 65b76cc260b..217c5eef652 100644 --- a/ocaml/typing/typetexp.ml +++ b/ocaml/typing/typetexp.ml @@ -23,7 +23,6 @@ open Parsetree open Typedtree open Types open Ctype -module Alloc_mode = Btype.Alloc_mode exception Already_bound @@ -34,8 +33,8 @@ type error = | Bound_type_variable of string | Recursive_type | Unbound_row_variable of Longident.t - | Type_mismatch of Ctype.Unification_trace.t - | Alias_type_mismatch of Ctype.Unification_trace.t + | Type_mismatch of Errortrace.unification_error + | Alias_type_mismatch of Errortrace.unification_error | Present_has_conjunction of string | Present_has_no_type of string | Constructor_mismatch of type_expr * type_expr @@ -47,7 +46,8 @@ type error = | Method_mismatch of string * type_expr * type_expr | Opened_object of Path.t option | Not_an_object of type_expr - | Local_not_enabled + | Unsupported_extension of Clflags.Extension.t + | Polymorphic_optional_param exception Error of Location.t * Env.t * error exception Error_forward of Location.error @@ -162,7 +162,7 @@ let get_alloc_mode styp = | Ok true -> Alloc_mode.Local | Ok false -> Alloc_mode.Global | Error () -> - raise (Error(styp.ptyp_loc, Env.empty, Local_not_enabled)) + raise (Error(styp.ptyp_loc, Env.empty, Unsupported_extension Local)) let rec extract_params styp = let final styp = @@ -181,6 +181,40 @@ let rec extract_params styp = let new_pre_univar ?name () = let v = newvar ?name () in pre_univars := v :: !pre_univars; v +type poly_univars = (string * type_expr) list +let make_poly_univars vars = + List.map (fun name -> name, newvar ~name ()) vars + +let check_poly_univars env loc vars = + vars |> List.iter (fun (_, v) -> generalize v); + vars |> List.map (fun (name, ty1) -> + let v = Btype.proxy ty1 in + begin match get_desc v with + | Tvar name when get_level v = Btype.generic_level -> + set_type_desc v (Tunivar name) + | _ -> + raise (Error (loc, env, Cannot_quantify(name, v))) + end; + v) + +let instance_poly_univars env loc vars = + let vs = check_poly_univars env loc vars in + vs |> List.iter (fun v -> + match get_desc v with + | Tunivar name -> + set_type_desc v (Tvar name) + | _ -> assert false); + vs + +let check_arg_type styp = + if not (Clflags.Extension.is_enabled Polymorphic_parameters) then begin + match styp.ptyp_desc with + | Ptyp_poly _ -> + raise (Error (styp.ptyp_loc, Env.empty, + Unsupported_extension Polymorphic_parameters)) + | _ -> () + end + type policy = Fixed | Extensible | Univars let rec transl_type env policy mode styp = @@ -224,6 +258,7 @@ and transl_type_aux env policy mode styp = let rec loop acc_mode args = match args with | (l, arg_mode, arg) :: rest -> + check_arg_type arg; let arg_cty = transl_type env policy arg_mode arg in let acc_mode = Alloc_mode.join_const acc_mode arg_mode in let ret_mode = @@ -234,15 +269,22 @@ and transl_type_aux env policy mode styp = let ret_cty = loop acc_mode rest in let arg_ty = arg_cty.ctyp_type in let arg_ty = - if Btype.is_optional l - then newty (Tconstr(Predef.path_option,[arg_ty], ref Mnil)) - else arg_ty + if Btype.is_Tpoly arg_ty then arg_ty else newmono arg_ty + in + let arg_ty = + if not (Btype.is_optional l) then arg_ty + else begin + if not (Btype.tpoly_is_mono arg_ty) then + raise (Error (arg.ptyp_loc, env, Polymorphic_optional_param)); + newmono + (newconstr Predef.path_option [Btype.tpoly_get_mono arg_ty]) + end in let arg_mode = Alloc_mode.of_const arg_mode in let ret_mode = Alloc_mode.of_const ret_mode in + let arrow_desc = (l, arg_mode, ret_mode) in let ty = - newty - (Tarrow((l,arg_mode,ret_mode), arg_ty, ret_cty.ctyp_type, Cok)) + newty (Tarrow(arrow_desc, arg_ty, ret_cty.ctyp_type, commu_ok)) in ctyp (Ttyp_arrow (l, arg_cty, ret_cty)) ty | [] -> transl_type env policy ret_mode ret @@ -271,22 +313,17 @@ and transl_type_aux env policy mode styp = match decl.type_manifest with None -> unify_var | Some ty -> - if (repr ty).level = Btype.generic_level then unify_var else unify + if get_level ty = Btype.generic_level then unify_var else unify in List.iter2 (fun (sty, cty) ty' -> - try unify_param env ty' cty.ctyp_type with Unify trace -> - let trace = Unification_trace.swap trace in - raise (Error(sty.ptyp_loc, env, Type_mismatch trace)) + try unify_param env ty' cty.ctyp_type with Unify err -> + let err = Errortrace.swap_unification_error err in + raise (Error(sty.ptyp_loc, env, Type_mismatch err)) ) (List.combine stl args) params; let constr = newconstr path (List.map (fun ctyp -> ctyp.ctyp_type) args) in - begin try - Ctype.enforce_constraints env constr - with Unify trace -> - raise (Error(styp.ptyp_loc, env, Type_mismatch trace)) - end; ctyp (Ttyp_constr (path, lid, args)) constr | Ptyp_object (fields, o) -> let ty, fields = transl_fields env policy o fields in @@ -299,7 +336,7 @@ and transl_type_aux env policy mode styp = match decl.type_manifest with None -> raise Not_found | Some ty -> - match (repr ty).desc with + match get_desc ty with Tvariant row when Btype.static_row row -> () | Tconstr (path, _, _) -> check (Env.find_type path env) @@ -330,40 +367,29 @@ and transl_type_aux env policy mode styp = let params = instance_list decl.type_params in List.iter2 (fun (sty, cty) ty' -> - try unify_var env ty' cty.ctyp_type with Unify trace -> - let trace = Unification_trace.swap trace in - raise (Error(sty.ptyp_loc, env, Type_mismatch trace)) + try unify_var env ty' cty.ctyp_type with Unify err -> + let err = Errortrace.swap_unification_error err in + raise (Error(sty.ptyp_loc, env, Type_mismatch err)) ) (List.combine stl args) params; let ty_args = List.map (fun ctyp -> ctyp.ctyp_type) args in - let ty = - try Ctype.expand_head env (newconstr path ty_args) - with Unify trace -> - raise (Error(styp.ptyp_loc, env, Type_mismatch trace)) - in - let ty = match ty.desc with + let ty = Ctype.expand_head env (newconstr path ty_args) in + let ty = match get_desc ty with Tvariant row -> - let row = Btype.row_repr row in let fields = List.map (fun (l,f) -> l, - match Btype.row_field_repr f with - | Rpresent (Some ty) -> - Reither(false, [ty], false, ref None) - | Rpresent None -> - Reither (true, [], false, ref None) + match row_field_repr f with + | Rpresent oty -> rf_either_of oty | _ -> f) - row.row_fields + (row_fields row) in - let row = { row_closed = true; row_fields = fields; - row_bound = (); row_name = Some (path, ty_args); - row_fixed = None; row_more = newvar () } in - let static = Btype.static_row row in + (* NB: row is always non-static here; more is thus never Tnil *) + let more = + if policy = Univars then new_pre_univar () else newvar () in let row = - if static then { row with row_more = newty Tnil } - else if policy <> Univars then row - else { row with row_more = new_pre_univar () } - in + create_row ~fields ~more + ~closed:true ~fixed:None ~name:(Some (path, ty_args)) in newty (Tvariant row) | Tobject (fi, _) -> let _, tv = flatten_fields fi in @@ -382,9 +408,9 @@ and transl_type_aux env policy mode styp = instance (fst(TyVarMap.find alias !used_variables)) in let ty = transl_type env policy mode st in - begin try unify_var env t ty.ctyp_type with Unify trace -> - let trace = Unification_trace.swap trace in - raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace)) + begin try unify_var env t ty.ctyp_type with Unify err -> + let err = Errortrace.swap_unification_error err in + raise(Error(styp.ptyp_loc, env, Alias_type_mismatch err)) end; ty with Not_found -> @@ -393,9 +419,9 @@ and transl_type_aux env policy mode styp = used_variables := TyVarMap.add alias (t, styp.ptyp_loc) !used_variables; let ty = transl_type env policy mode st in - begin try unify_var env t ty.ctyp_type with Unify trace -> - let trace = Unification_trace.swap trace in - raise(Error(styp.ptyp_loc, env, Alias_type_mismatch trace)) + begin try unify_var env t ty.ctyp_type with Unify err -> + let err = Errortrace.swap_unification_error err in + raise(Error(styp.ptyp_loc, env, Alias_type_mismatch err)) end; if !Clflags.principal then begin end_def (); @@ -403,9 +429,9 @@ and transl_type_aux env policy mode styp = end; let t = instance t in let px = Btype.proxy t in - begin match px.desc with - | Tvar None -> Btype.set_type_desc px (Tvar (Some alias)) - | Tunivar None -> Btype.set_type_desc px (Tunivar (Some alias)) + begin match get_desc px with + | Tvar None -> set_type_desc px (Tvar (Some alias)) + | Tunivar None -> set_type_desc px (Tunivar (Some alias)) | _ -> () end; { ty with ctyp_type = t } @@ -414,9 +440,8 @@ and transl_type_aux env policy mode styp = | Ptyp_variant(fields, closed, present) -> let name = ref None in let mkfield l f = - newty (Tvariant {row_fields=[l,f]; row_more=newvar(); - row_bound=(); row_closed=true; - row_fixed=None; row_name=None}) in + newty (Tvariant (create_row ~fields:[l,f] ~more:(newvar()) + ~closed:true ~fixed:None ~name:None)) in let hfields = Hashtbl.create 17 in let add_typed_field loc l f = let h = Btype.hash_variant l in @@ -425,7 +450,7 @@ and transl_type_aux env policy mode styp = (* Check for tag conflicts *) if l <> l' then raise(Error(styp.ptyp_loc, env, Variant_tags(l, l'))); let ty = mkfield l f and ty' = mkfield l f' in - if equal env false [ty] [ty'] then () else + if is_equal env false [ty] [ty'] then () else try unify env ty ty' with Unify _trace -> raise(Error(loc, env, Constructor_mismatch (ty,ty'))) @@ -446,14 +471,13 @@ and transl_type_aux env policy mode styp = let f = match present with Some present when not (List.mem l.txt present) -> let ty_tl = List.map (fun cty -> cty.ctyp_type) tl in - Reither(c, ty_tl, false, ref None) + rf_either ty_tl ~no_arg:c ~matched:false | _ -> if List.length stl > 1 || c && stl <> [] then raise(Error(styp.ptyp_loc, env, Present_has_conjunction l.txt)); - match tl with [] -> Rpresent None - | st :: _ -> - Rpresent (Some st.ctyp_type) + match tl with [] -> rf_present None + | st :: _ -> rf_present (Some st.ctyp_type) in add_typed_field styp.ptyp_loc l.txt f; Ttag (l,c,tl) @@ -461,16 +485,15 @@ and transl_type_aux env policy mode styp = let cty = transl_type env policy Alloc_mode.Global sty in let ty = cty.ctyp_type in let nm = - match repr cty.ctyp_type with - {desc=Tconstr(p, tl, _)} -> Some(p, tl) - | _ -> None + match get_desc cty.ctyp_type with + Tconstr(p, tl, _) -> Some(p, tl) + | _ -> None in name := if Hashtbl.length hfields <> 0 then None else nm; - let fl = match expand_head env cty.ctyp_type, nm with - {desc=Tvariant row}, _ when Btype.static_row row -> - let row = Btype.row_repr row in - row.row_fields - | {desc=Tvar _}, Some(p, _) -> + let fl = match get_desc (expand_head env cty.ctyp_type), nm with + Tvariant row, _ when Btype.static_row row -> + row_fields row + | Tvar _, Some(p, _) -> raise(Error(sty.ptyp_loc, env, Undefined_type_constructor p)) | _ -> raise(Error(sty.ptyp_loc, env, Not_a_variant ty)) @@ -479,13 +502,9 @@ and transl_type_aux env policy mode styp = (fun (l, f) -> let f = match present with Some present when not (List.mem l present) -> - begin match f with - Rpresent(Some ty) -> - Reither(false, [ty], false, ref None) - | Rpresent None -> - Reither(true, [], false, ref None) - | _ -> - assert false + begin match row_field_repr f with + Rpresent oty -> rf_either_of oty + | _ -> assert false end | _ -> f in @@ -496,7 +515,7 @@ and transl_type_aux env policy mode styp = { rf_desc; rf_loc; rf_attributes; } in let tfields = List.map add_field fields in - let fields = Hashtbl.fold (fun _ p l -> p :: l) hfields [] in + let fields = List.rev (Hashtbl.fold (fun _ p l -> p :: l) hfields []) in begin match present with None -> () | Some present -> List.iter @@ -504,22 +523,20 @@ and transl_type_aux env policy mode styp = raise(Error(styp.ptyp_loc, env, Present_has_no_type l))) present end; - let row = - { row_fields = List.rev fields; row_more = newvar (); - row_bound = (); row_closed = (closed = Closed); - row_fixed = None; row_name = !name } in - let static = Btype.static_row row in - let row = - if static then { row with row_more = newty Tnil } - else if policy <> Univars then row - else { row with row_more = new_pre_univar () } + let name = !name in + let make_row more = + create_row ~fields ~more ~closed:(closed = Closed) ~fixed:None ~name in - let ty = newty (Tvariant row) in + let more = + if Btype.static_row (make_row (newvar ())) then newty Tnil else + if policy = Univars then new_pre_univar () else newvar () + in + let ty = newty (Tvariant (make_row more)) in ctyp (Ttyp_variant (tfields, closed, present)) ty | Ptyp_poly(vars, st) -> let vars = List.map (fun v -> v.txt) vars in begin_def(); - let new_univars = List.map (fun name -> name, newvar ~name ()) vars in + let new_univars = make_poly_univars vars in let old_univars = !univars in univars := new_univars @ !univars; let cty = transl_type env policy mode st in @@ -527,21 +544,9 @@ and transl_type_aux env policy mode styp = univars := old_univars; end_def(); generalize ty; - let ty_list = - List.fold_left - (fun tyl (name, ty1) -> - let v = Btype.proxy ty1 in - if deep_occur v ty then begin - match v.desc with - Tvar name when v.level = Btype.generic_level -> - v.desc <- Tunivar name; - v :: tyl - | _ -> - raise (Error (styp.ptyp_loc, env, Cannot_quantify (name, v))) - end else tyl) - [] new_univars - in - let ty' = Btype.newgenty (Tpoly(ty, List.rev ty_list)) in + let ty_list = check_poly_univars env styp.ptyp_loc new_univars in + let ty_list = List.filter (fun v -> deep_occur v ty) ty_list in + let ty' = Btype.newgenty (Tpoly(ty, ty_list)) in unify_var env (newvar()) ty'; ctyp (Ttyp_poly (vars, cty)) ty' | Ptyp_package (p, l) -> @@ -554,8 +559,7 @@ and transl_type_aux env policy mode styp = ) l in let path = !transl_modtype_longident styp.ptyp_loc env p.txt in let ty = newty (Tpackage (path, - List.map (fun (s, _pty) -> s.txt) l, - List.map (fun (_,cty) -> cty.ctyp_type) ptys)) + List.map (fun (s, cty) -> (s.txt, cty.ctyp_type)) ptys)) in ctyp (Ttyp_package { pack_path = path; @@ -566,15 +570,12 @@ and transl_type_aux env policy mode styp = | Ptyp_extension ext -> raise (Error_forward (Builtin_attributes.error_of_extension ext)) -and transl_poly_type env policy mode t = - transl_type env policy mode (Ast_helper.Typ.force_poly t) - and transl_fields env policy o fields = let hfields = Hashtbl.create 17 in let add_typed_field loc l ty = try let ty' = Hashtbl.find hfields l in - if equal env false [ty] [ty'] then () else + if is_equal env false [ty] [ty'] then () else try unify env ty ty' with Unify _trace -> raise(Error(loc, env, Method_mismatch (l, ty, ty'))) @@ -587,7 +588,7 @@ and transl_fields env policy o fields = | Otag (s, ty1) -> begin let ty1 = Builtin_attributes.warning_scope of_attributes - (fun () -> transl_poly_type env policy Alloc_mode.Global ty1) + (fun () -> transl_type env policy Alloc_mode.Global (Ast_helper.Typ.force_poly ty1)) in let field = OTtag (s, ty1) in add_typed_field ty1.ctyp_loc s.txt ty1.ctyp_type; @@ -596,25 +597,28 @@ and transl_fields env policy o fields = | Oinherit sty -> begin let cty = transl_type env policy Alloc_mode.Global sty in let nm = - match repr cty.ctyp_type with - {desc=Tconstr(p, _, _)} -> Some p - | _ -> None in + match get_desc cty.ctyp_type with + Tconstr(p, _, _) -> Some p + | _ -> None in let t = expand_head env cty.ctyp_type in - match t, nm with - {desc=Tobject ({desc=(Tfield _ | Tnil) as tf}, _)}, _ -> begin - if opened_object t then - raise (Error (sty.ptyp_loc, env, Opened_object nm)); - let rec iter_add = function - | Tfield (s, _k, ty1, ty2) -> begin - add_typed_field sty.ptyp_loc s ty1; - iter_add ty2.desc - end - | Tnil -> () - | _ -> assert false in - iter_add tf; - OTinherit cty + match get_desc t, nm with + Tobject (tf, _), _ + when (match get_desc tf with Tfield _ | Tnil -> true | _ -> false) -> + begin + if opened_object t then + raise (Error (sty.ptyp_loc, env, Opened_object nm)); + let rec iter_add ty = + match get_desc ty with + | Tfield (s, _k, ty1, ty2) -> + add_typed_field sty.ptyp_loc s ty1; + iter_add ty2 + | Tnil -> () + | _ -> assert false + in + iter_add tf; + OTinherit cty end - | {desc=Tvar _}, Some p -> + | Tvar _, Some p -> raise (Error (sty.ptyp_loc, env, Undefined_type_constructor p)) | _ -> raise (Error (sty.ptyp_loc, env, Not_an_object t)) end in @@ -628,30 +632,32 @@ and transl_fields env policy o fields = | Open, Univars -> new_pre_univar () | Open, _ -> newvar () in let ty = List.fold_left (fun ty (s, ty') -> - newty (Tfield (s, Fpresent, ty', ty))) ty_init fields in + newty (Tfield (s, field_public, ty', ty))) ty_init fields in ty, object_fields (* Make the rows "fixed" in this type, to make universal check easier *) let rec make_fixed_univars ty = - let ty = repr ty in - if ty.level >= Btype.lowest_level then begin - Btype.mark_type_node ty; - match ty.desc with + if Btype.try_mark_node ty then + begin match get_desc ty with | Tvariant row -> - let row = Btype.row_repr row in - let more = Btype.row_more row in + let Row {fields; more; name; closed} = row_repr row in if Btype.is_Tunivar more then - ty.desc <- Tvariant - {row with row_fixed=Some(Univar more); - row_fields = List.map - (fun (s,f as p) -> match Btype.row_field_repr f with - Reither (c, tl, _m, r) -> s, Reither (c, tl, true, r) - | _ -> p) - row.row_fields}; + let fields = + List.map + (fun (s,f as p) -> match row_field_repr f with + Reither (no_arg, tl, _m) -> + s, rf_either tl ~use_ext_of:f ~no_arg ~matched:true + | _ -> p) + fields + in + set_type_desc ty + (Tvariant + (create_row ~fields ~more ~name ~closed + ~fixed:(Some (Univar more)))); Btype.iter_row make_fixed_univars row | _ -> Btype.iter_type_expr make_fixed_univars ty - end + end let make_fixed_univars ty = make_fixed_univars ty; @@ -669,7 +675,7 @@ let globalize_used_variables env fixed = then try r := (loc, v, TyVarMap.find name !type_variables) :: !r with Not_found -> - if fixed && Btype.is_Tvar (repr ty) then + if fixed && Btype.is_Tvar ty then raise(Error(loc, env, Unbound_type_variable ("'"^name))); let v2 = new_global_var () in r := (loc, v, v2) :: !r; @@ -679,12 +685,12 @@ let globalize_used_variables env fixed = fun () -> List.iter (function (loc, t1, t2) -> - try unify env t1 t2 with Unify trace -> - raise (Error(loc, env, Type_mismatch trace))) + try unify env t1 t2 with Unify err -> + raise (Error(loc, env, Type_mismatch err))) !r -let transl_simple_type env fixed mode styp = - univars := []; used_variables := TyVarMap.empty; +let transl_simple_type env ?univars:(uvs=[]) fixed mode styp = + univars := uvs; used_variables := TyVarMap.empty; let typ = transl_type env (if fixed then Fixed else Extensible) mode styp in globalize_used_variables env fixed (); make_fixed_univars typ.ctyp_type; @@ -708,10 +714,9 @@ let transl_simple_type_univars env styp = let univs = List.fold_left (fun acc v -> - let v = repr v in - match v.desc with - Tvar name when v.level = Btype.generic_level -> - v.desc <- Tunivar name; v :: acc + match get_desc v with + Tvar name when get_level v = Btype.generic_level -> + set_type_desc v (Tunivar name); v :: acc | _ -> acc) [] !pre_univars in @@ -735,11 +740,26 @@ let transl_simple_type_delayed env mode styp = let transl_type_scheme env styp = reset_type_variables(); - begin_def(); - let typ = transl_simple_type env false Alloc_mode.Global styp in - end_def(); - generalize typ.ctyp_type; - typ + match styp.ptyp_desc with + | Ptyp_poly (vars, st) -> + begin_def(); + let vars = List.map (fun v -> v.txt) vars in + let univars = make_poly_univars vars in + let typ = transl_simple_type env ~univars true Alloc_mode.Global st in + end_def(); + generalize typ.ctyp_type; + let _ = instance_poly_univars env styp.ptyp_loc univars in + { ctyp_desc = Ttyp_poly (vars, typ); + ctyp_type = typ.ctyp_type; + ctyp_env = env; + ctyp_loc = styp.ptyp_loc; + ctyp_attributes = styp.ptyp_attributes } + | _ -> + begin_def(); + let typ = transl_simple_type env false Alloc_mode.Global styp in + end_def(); + generalize typ.ctyp_type; + typ (* Error report *) @@ -794,17 +814,17 @@ let report_error env ppf = function l l | Constructor_mismatch (ty, ty') -> wrap_printing_env ~error:true env (fun () -> - Printtyp.reset_and_mark_loops_list [ty; ty']; + Printtyp.prepare_for_printing [ty; ty']; fprintf ppf "@[%s %a@ %s@ %a@]" "This variant type contains a constructor" - !Oprint.out_type (tree_of_typexp false ty) + !Oprint.out_type (tree_of_typexp Type ty) "which should be" - !Oprint.out_type (tree_of_typexp false ty')) + !Oprint.out_type (tree_of_typexp Type ty')) | Not_a_variant ty -> fprintf ppf "@[The type %a@ does not expand to a polymorphic variant type@]" Printtyp.type_expr ty; - begin match ty.desc with + begin match get_desc ty with | Tvar (Some s) -> (* PR#7012: help the user that wrote 'Foo instead of `Foo *) Misc.did_you_mean ppf (fun () -> ["`" ^ s]) @@ -842,9 +862,12 @@ let report_error env ppf = function | Not_an_object ty -> fprintf ppf "@[The type %a@ is not an object type@]" Printtyp.type_expr ty - | Local_not_enabled -> - fprintf ppf "@[The local extension is disabled@ \ - To enable it, pass the '-extension local' flag@]" + | Unsupported_extension ext -> + let ext = Clflags.Extension.to_string ext in + fprintf ppf "@[The %s extension is disabled@ \ + To enable it, pass the '-extension %s' flag@]" ext ext + | Polymorphic_optional_param -> + fprintf ppf "@[Optional parameters cannot be polymorphic@]" let () = Location.register_error_of_exn diff --git a/ocaml/typing/typetexp.mli b/ocaml/typing/typetexp.mli index 0c14ba58de9..abfad1d74b1 100644 --- a/ocaml/typing/typetexp.mli +++ b/ocaml/typing/typetexp.mli @@ -19,8 +19,21 @@ open Types val valid_tyvar_name : string -> bool +type poly_univars +val make_poly_univars : string list -> poly_univars + (* Create a set of univars with given names *) +val check_poly_univars : + Env.t -> Location.t -> poly_univars -> type_expr list + (* Verify that the given univars are universally quantified, + and return the list of variables. The type in which the + univars are used must be generalised *) +val instance_poly_univars : + Env.t -> Location.t -> poly_univars -> type_expr list + (* Same as [check_poly_univars], but instantiates the resulting + type scheme (i.e. variables become Tvar rather than Tunivar) *) + val transl_simple_type: - Env.t -> bool -> alloc_mode_const + Env.t -> ?univars:poly_univars -> bool -> alloc_mode_const -> Parsetree.core_type -> Typedtree.core_type val transl_simple_type_univars: Env.t -> Parsetree.core_type -> Typedtree.core_type @@ -38,6 +51,8 @@ val type_variable: Location.t -> string -> type_expr val transl_type_param: Env.t -> Parsetree.core_type -> Typedtree.core_type +val get_alloc_mode : Parsetree.core_type -> alloc_mode_const + type variable_context val narrow: unit -> variable_context val widen: variable_context -> unit @@ -51,8 +66,8 @@ type error = | Bound_type_variable of string | Recursive_type | Unbound_row_variable of Longident.t - | Type_mismatch of Ctype.Unification_trace.t - | Alias_type_mismatch of Ctype.Unification_trace.t + | Type_mismatch of Errortrace.unification_error + | Alias_type_mismatch of Errortrace.unification_error | Present_has_conjunction of string | Present_has_no_type of string | Constructor_mismatch of type_expr * type_expr @@ -64,7 +79,8 @@ type error = | Method_mismatch of string * type_expr * type_expr | Opened_object of Path.t option | Not_an_object of type_expr - | Local_not_enabled + | Unsupported_extension of Clflags.Extension.t + | Polymorphic_optional_param exception Error of Location.t * Env.t * error diff --git a/ocaml/typing/untypeast.ml b/ocaml/typing/untypeast.ml index fbffaf03dd9..9bc3ae5b95c 100644 --- a/ocaml/typing/untypeast.ml +++ b/ocaml/typing/untypeast.ml @@ -245,13 +245,14 @@ let type_kind sub tk = match tk with | Ttype_open -> Ptype_open let constructor_arguments sub = function - | Cstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) + | Cstr_tuple l -> Pcstr_tuple (List.map (fun (ty, _) -> sub.typ sub ty) l) | Cstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l) let constructor_declaration sub cd = let loc = sub.location sub cd.cd_loc in let attrs = sub.attributes sub cd.cd_attributes in Type.constructor ~loc ~attrs + ~vars:cd.cd_vars ~args:(constructor_arguments sub cd.cd_args) ?res:(Option.map (sub.typ sub) cd.cd_res) (map_loc sub cd.cd_name) @@ -283,8 +284,8 @@ let extension_constructor sub ext = Te.constructor ~loc ~attrs (map_loc sub ext.ext_name) (match ext.ext_kind with - | Text_decl (args, ret) -> - Pext_decl (constructor_arguments sub args, + | Text_decl (vs, args, ret) -> + Pext_decl (vs, constructor_arguments sub args, Option.map (sub.typ sub) ret) | Text_rebind (_p, lid) -> Pext_rebind (map_loc sub lid) ) @@ -329,17 +330,28 @@ let pattern : type k . _ -> k T.general_pattern -> _ = fun sub pat -> | Tpat_constant cst -> Ppat_constant (constant cst) | Tpat_tuple list -> Ppat_tuple (List.map (sub.pat sub) list) - | Tpat_construct (lid, _, args) -> + | Tpat_construct (lid, _, args, vto) -> + let tyo = + match vto with + None -> None + | Some (vl, ty) -> + let vl = + List.map (fun x -> {x with txt = Ident.name x.txt}) vl + in + Some (vl, sub.typ sub ty) + in + let arg = + match args with + [] -> None + | [arg] -> Some (sub.pat sub arg) + | args -> Some (Pat.tuple ~loc (List.map (sub.pat sub) args)) + in Ppat_construct (map_loc sub lid, - (match args with - [] -> None - | [arg] -> Some (sub.pat sub arg) - | args -> - Some - (Pat.tuple ~loc - (List.map (sub.pat sub) args) - ) - )) + match tyo, arg with + | Some (vl, ty), Some arg -> + Some (vl, Pat.mk ~loc (Ppat_constraint (arg, ty))) + | None, Some arg -> Some ([], arg) + | _, None -> None) | Tpat_variant (label, pato, _) -> Ppat_variant (label, Option.map (sub.pat sub) pato) | Tpat_record (list, closed) -> @@ -485,10 +497,11 @@ let expression sub exp = Pexp_for (for_pat, sub.expr sub for_from, sub.expr sub for_to, for_dir, sub.expr sub for_body) - | Texp_send (exp, meth, _, _) -> + | Texp_send (exp, meth, _) -> Pexp_send (sub.expr sub exp, match meth with Tmeth_name name -> mkloc name loc - | Tmeth_val id -> mkloc (Ident.name id) loc) + | Tmeth_val id -> mkloc (Ident.name id) loc + | Tmeth_ancestor(id, _) -> mkloc (Ident.name id) loc) | Texp_new (_path, lid, _, _) -> Pexp_new (map_loc sub lid) | Texp_instvar (_, path, name) -> Pexp_ident ({loc = sub.location sub name.loc ; txt = lident_of_path path}) @@ -611,6 +624,8 @@ let signature_item sub item = Psig_recmodule (List.map (sub.module_declaration sub) list) | Tsig_modtype mtd -> Psig_modtype (sub.module_type_declaration sub mtd) + | Tsig_modtypesubst mtd -> + Psig_modtypesubst (sub.module_type_declaration sub mtd) | Tsig_open od -> Psig_open (sub.open_description sub od) | Tsig_include incl -> @@ -664,7 +679,7 @@ let functor_parameter sub : functor_parameter -> Parsetree.functor_parameter = | Unit -> Unit | Named (_, name, mtype) -> Named (name, sub.module_type sub mtype) -let module_type sub mty = +let module_type (sub : mapper) mty = let loc = sub.location sub mty.mty_loc in let attrs = sub.attributes sub mty.mty_attributes in let desc = match mty.mty_desc with @@ -687,12 +702,18 @@ let with_constraint sub (_path, lid, cstr) = Pwith_type (map_loc sub lid, sub.type_declaration sub decl) | Twith_module (_path, lid2) -> Pwith_module (map_loc sub lid, map_loc sub lid2) + | Twith_modtype mty -> + let mty = sub.module_type sub mty in + Pwith_modtype (map_loc sub lid,mty) | Twith_typesubst decl -> Pwith_typesubst (map_loc sub lid, sub.type_declaration sub decl) | Twith_modsubst (_path, lid2) -> Pwith_modsubst (map_loc sub lid, map_loc sub lid2) + | Twith_modtypesubst mty -> + let mty = sub.module_type sub mty in + Pwith_modtypesubst (map_loc sub lid, mty) -let module_expr sub mexpr = +let module_expr (sub : mapper) mexpr = let loc = sub.location sub mexpr.mod_loc in let attrs = sub.attributes sub mexpr.mod_attributes in match mexpr.mod_desc with @@ -941,10 +962,10 @@ let default_mapper = object_field = object_field ; } -let untype_structure ?(mapper=default_mapper) structure = +let untype_structure ?(mapper : mapper = default_mapper) structure = mapper.structure mapper structure -let untype_signature ?(mapper=default_mapper) signature = +let untype_signature ?(mapper : mapper = default_mapper) signature = mapper.signature mapper signature let untype_expression ?(mapper=default_mapper) expression = diff --git a/ocaml/utils/.ocamlformat b/ocaml/utils/.ocamlformat new file mode 100644 index 00000000000..a6f157798c0 --- /dev/null +++ b/ocaml/utils/.ocamlformat @@ -0,0 +1,17 @@ +# Please make a pull request to change this file. +disable=true +# There is an .ocamlformat-enable file in this directory. +# Keep the remainder of this file in sync with other .ocamlformat files in this repo. +assignment-operator=begin-line +cases-exp-indent=2 +doc-comments=before +dock-collection-brackets=false +if-then-else=keyword-first +module-item-spacing=sparse +parens-tuple=multi-line-only +sequence-blank-line=compact +space-around-lists=false +space-around-variants=false +type-decl=sparse +wrap-comments=true +version=0.24.1 diff --git a/ocaml/utils/.ocamlformat-enable b/ocaml/utils/.ocamlformat-enable new file mode 100644 index 00000000000..dc0bce1feed --- /dev/null +++ b/ocaml/utils/.ocamlformat-enable @@ -0,0 +1,4 @@ +compilation_unit.ml +compilation_unit.mli +import_info.ml +import_info.mli diff --git a/ocaml/utils/HACKING.adoc b/ocaml/utils/HACKING.adoc index 5ae1a0f510f..707fdfd6568 100644 --- a/ocaml/utils/HACKING.adoc +++ b/ocaml/utils/HACKING.adoc @@ -46,5 +46,5 @@ tested on a large scale: this is when tool authors may update their tools to test the new release, and if you update *after* that you risk breaking them again without them noticing. -For example, the magic numbers for 4.10 were updated in - 6423e5c9d11cfac1c07208aec9f761f37c1640f0 +For example, the magic numbers for 4.13 were updated in + dd7927e156b7cb2f9 diff --git a/ocaml/utils/Makefile b/ocaml/utils/Makefile index 3067f423215..92338486a44 100644 --- a/ocaml/utils/Makefile +++ b/ocaml/utils/Makefile @@ -19,14 +19,16 @@ ROOTDIR = .. include $(ROOTDIR)/Makefile.common -ifeq "$(UNIX_OR_WIN32)" "win32" -ifeq "$(wildcard $(ROOTDIR)/flexdll/Makefile)" "" +domainstate.ml: domainstate.ml.c ../runtime/caml/domain_state.tbl + $(CPP) -I ../runtime/caml $< > $@ + +domainstate.mli: domainstate.mli.c ../runtime/caml/domain_state.tbl + $(CPP) -I ../runtime/caml $< > $@ + +ifeq "$(BOOTSTRAPPING_FLEXDLL)" "false" FLEXDLL_DIR = else - FLEXDLL_DIR = $(if $(wildcard $(ROOTDIR)/flexdll/flexdll_*.$(O)),+flexdll) -endif -else - FLEXDLL_DIR = + FLEXDLL_DIR = +flexdll endif FLEXLINK_FLAGS ?= @@ -63,6 +65,7 @@ config.ml: config.mlp $(ROOTDIR)/Makefile.config Makefile $(call SUBST_STRING,FLEXLINK_FLAGS) \ $(call SUBST_QUOTE,FLEXDLL_DIR) \ $(call SUBST,HOST) \ + $(call SUBST_STRING,BINDIR) \ $(call SUBST_STRING,LIBDIR) \ $(call SUBST_STRING,MKDLL) \ $(call SUBST_STRING,MKEXE) \ @@ -77,10 +80,12 @@ config.ml: config.mlp $(ROOTDIR)/Makefile.config Makefile $(call SUBST_STRING,OCAMLOPT_CPPFLAGS) \ $(call SUBST_STRING,PACKLD) \ $(call SUBST,PROFINFO_WIDTH) \ - $(call SUBST_STRING,RANLIBCMD) \ + $(call SUBST_STRING,RPATH) \ + $(call SUBST_STRING,MKSHAREDLIBRPATH) \ $(call SUBST,FORCE_SAFE_STRING) \ $(call SUBST,DEFAULT_SAFE_STRING) \ $(call SUBST,WINDOWS_UNICODE) \ + $(call SUBST,NAKED_POINTERS) \ $(call SUBST,SUPPORTS_SHARED_LIBRARIES) \ $(call SUBST,SYSTEM) \ $(call SUBST,SYSTHREAD_SUPPORT) \ @@ -94,6 +99,7 @@ config.ml: config.mlp $(ROOTDIR)/Makefile.config Makefile $(call SUBST,CC_HAS_DEBUG_PREFIX_MAP) \ $(call SUBST,AS_HAS_DEBUG_PREFIX_MAP) \ $(call SUBST,STACK_ALLOCATION) \ + $(call SUBST,POLL_INSERTION) \ $< > $@ # Test for the substitution functions above diff --git a/ocaml/utils/binutils.ml b/ocaml/utils/binutils.ml index f3c92c8c52b..40d7cea72ce 100644 --- a/ocaml/utils/binutils.ml +++ b/ocaml/utils/binutils.ml @@ -489,14 +489,14 @@ module FlexDLL = struct e_lfanew: int64; number_of_sections: int; size_of_optional_header: int; - characteristics: int; + _characteristics: int; } let read_header e_lfanew d buf = let number_of_sections = get_uint16 d buf 6 in let size_of_optional_header = get_uint16 d buf 20 in - let characteristics = get_uint16 d buf 22 in - {e_lfanew; number_of_sections; size_of_optional_header; characteristics} + let _characteristics = get_uint16 d buf 22 in + {e_lfanew; number_of_sections; size_of_optional_header; _characteristics} type optional_header_magic = | PE32 @@ -504,7 +504,7 @@ module FlexDLL = struct type optional_header = { - magic: optional_header_magic; + _magic: optional_header_magic; image_base: int64; } @@ -515,24 +515,19 @@ module FlexDLL = struct load_bytes d Int64.(add e_lfanew (of_int header_size)) size_of_optional_header in - let magic = + let _magic, image_base = match get_uint16 d buf 0 with - | 0x10b -> PE32 - | 0x20b -> PE32PLUS + | 0x10b -> PE32, uint64_of_uint32 (get_uint32 d buf 28) + | 0x20b -> PE32PLUS, get_uint64 d buf 24 | n -> raise (Error (Unsupported ("optional_header_magic", Int64.of_int n))) in - let image_base = - match magic with - | PE32 -> uint64_of_uint32 (get_uint32 d buf 28) - | PE32PLUS -> get_uint64 d buf 24 - in - {magic; image_base} + {_magic; image_base} type section = { name: string; - virtual_size: int; + _virtual_size: int; virtual_address: int64; size_of_raw_data: int; pointer_to_raw_data: int64; @@ -550,12 +545,12 @@ module FlexDLL = struct let mk i = let base = i * section_header_size in let name = name_at ~max_len:8 buf (base + 0) in - let virtual_size = get_uint "virtual_size" d buf (base + 8) in + let _virtual_size = get_uint "virtual_size" d buf (base + 8) in let virtual_address = uint64_of_uint32 (get_uint32 d buf (base + 12)) in let size_of_raw_data = get_uint "size_of_raw_data" d buf (base + 16) in let pointer_to_raw_data = uint64_of_uint32 (get_uint32 d buf (base + 20)) in - {name; virtual_size; virtual_address; + {name; _virtual_size; virtual_address; size_of_raw_data; pointer_to_raw_data} in Array.init number_of_sections mk diff --git a/ocaml/utils/ccomp.ml b/ocaml/utils/ccomp.ml index 22b60a8b92c..1399c3ec0c3 100644 --- a/ocaml/utils/ccomp.ml +++ b/ocaml/utils/ccomp.ml @@ -140,24 +140,19 @@ let create_archive archive file_list = quoted_archive (quote_files file_list)) | _ -> assert(String.length Config.ar > 0); - let r1 = - command(Printf.sprintf "%s rc %s %s" - Config.ar quoted_archive (quote_files file_list)) in - if r1 <> 0 || String.length Config.ranlib = 0 - then r1 - else command(Config.ranlib ^ " " ^ quoted_archive) - -let expand_libname name = - if String.length name < 2 || String.sub name 0 2 <> "-l" - then name - else begin - let libname = - "lib" ^ String.sub name 2 (String.length name - 2) ^ Config.ext_lib in - try - Load_path.find libname - with Not_found -> - libname - end + command(Printf.sprintf "%s rc %s %s" + Config.ar quoted_archive (quote_files file_list)) + +let expand_libname cclibs = + cclibs |> List.map (fun cclib -> + if Misc.Stdlib.String.starts_with ~prefix:"-l" cclib then + let libname = + "lib" ^ String.sub cclib 2 (String.length cclib - 2) ^ Config.ext_lib in + try + Load_path.find libname + with Not_found -> + libname + else cclib) type link_mode = | Exe @@ -177,10 +172,10 @@ let call_linker mode output_name files extra = Profile.record_call "c-linker" (fun () -> let cmd = if mode = Partial then - let l_prefix = + let (l_prefix, files) = match Config.ccomp_type with - | "msvc" -> "/libpath:" - | _ -> "-L" + | "msvc" -> ("/libpath:", expand_libname files) + | _ -> ("-L", files) in Printf.sprintf "%s%s %s %s %s" Config.native_pack_linker diff --git a/ocaml/utils/ccomp.mli b/ocaml/utils/ccomp.mli index fb520e2a497..46f58a982e4 100644 --- a/ocaml/utils/ccomp.mli +++ b/ocaml/utils/ccomp.mli @@ -25,7 +25,6 @@ val run_command: string -> unit val compile_file: ?output:string -> ?opt:string -> ?stable_name:string -> string -> int val create_archive: string -> string list -> int -val expand_libname: string -> string val quote_files: string list -> string val quote_optfile: string option -> string (*val make_link_options: string list -> string*) diff --git a/ocaml/utils/clflags.ml b/ocaml/utils/clflags.ml index e8ba917f482..434b5246075 100644 --- a/ocaml/utils/clflags.ml +++ b/ocaml/utils/clflags.ml @@ -46,6 +46,7 @@ let compile_only = ref false (* -c *) and output_name = ref (None : string option) (* -o *) and include_dirs = ref ([] : string list)(* -I *) and no_std_include = ref false (* -nostdlib *) +and no_cwd = ref false (* -nocwd *) and print_types = ref false (* -i *) and make_archive = ref false (* -a *) and debug = ref false (* -g *) @@ -67,7 +68,7 @@ and preprocessor = ref(None : string option) (* -pp *) and all_ppx = ref ([] : string list) (* -ppx *) let absname = ref false (* -absname *) let annotations = ref false (* -annot *) -let binary_annotations = ref false (* -annot *) +let binary_annotations = ref false (* -bin-annot *) and use_threads = ref false (* -thread *) and noassert = ref false (* -noassert *) and verbose = ref false (* -verbose *) @@ -100,6 +101,7 @@ let locations = ref true (* -d(no-)locations *) let dump_source = ref false (* -dsource *) let dump_parsetree = ref false (* -dparsetree *) and dump_typedtree = ref false (* -dtypedtree *) +and dump_shape = ref false (* -dshape *) and dump_rawlambda = ref false (* -drawlambda *) and dump_lambda = ref false (* -dlambda *) and dump_rawclambda = ref false (* -drawclambda *) @@ -119,7 +121,6 @@ and dump_cmm = ref false (* -dcmm *) let dump_selection = ref false (* -dsel *) let dump_cse = ref false (* -dcse *) let dump_live = ref false (* -dlive *) -let dump_avail = ref false (* -davail *) let dump_spill = ref false (* -dspill *) let dump_split = ref false (* -dsplit *) let dump_interf = ref false (* -dinterf *) @@ -135,8 +136,6 @@ let default_timings_precision = 3 let timings_precision = ref default_timings_precision (* -dtimings-precision *) let profile_columns : Profile.column list ref = ref [] (* -dprofile/-dtimings *) -let debug_runavail = ref false (* -drunavail *) - let native_code = ref false (* set to true under ocamlopt *) let force_slash = ref false (* for ocamldep *) @@ -378,10 +377,10 @@ let set_dumped_pass s enabled = end module Extension = struct - type t = Comprehensions | Local | Include_functor + type t = Comprehensions | Local | Include_functor | Polymorphic_parameters - let all = [ Comprehensions; Local; Include_functor ] - let default_extensions = [ Local; Include_functor ] + let all = [ Comprehensions; Local; Include_functor; Polymorphic_parameters ] + let default_extensions = [ Local; Include_functor; Polymorphic_parameters ] let extensions = ref ([] : t list) (* -extension *) let equal (a : t) (b : t) = (a = b) @@ -390,11 +389,13 @@ module Extension = struct | Comprehensions -> "comprehensions" | Local -> "local" | Include_functor -> "include_functor" + | Polymorphic_parameters -> "polymorphic_parameters" let of_string = function | "comprehensions" -> Comprehensions | "local" -> Local | "include_functor" -> Include_functor + | "polymorphic_parameters" -> Polymorphic_parameters | extn -> raise (Arg.Bad(Printf.sprintf "Extension %s is not known" extn)) let disable_all_extensions = ref false (* -disable-all-extensions *) @@ -426,6 +427,7 @@ module Extension = struct end let dump_into_file = ref false (* -dump-into-file *) +let dump_dir: string option ref = ref None (* -dump-dir *) type 'a env_reader = { parse : string -> 'a option; @@ -552,7 +554,7 @@ module Compiler_pass = struct (* If you add a new pass, the following must be updated: - the variable `passes` below - the manpages in man/ocaml{c,opt}.m - - the manual manual/manual/cmds/unified-options.etex + - the manual manual/src/cmds/unified-options.etex *) type t = Parsing | Typing | Scheduling | Emit | Simplify_cfg | Selection @@ -673,17 +675,10 @@ let add_arguments loc args = arg_names := String.Map.add arg_name loc !arg_names ) args -let print_arguments usage = - Arg.usage !arg_spec usage - -(* This function is almost the same as [Arg.parse_expand], except - that [Arg.parse_expand] could not be used because it does not take a - reference for [arg_spec].*) -let parse_arguments argv f msg = - try - let argv = ref argv in - let current = ref 0 in - Arg.parse_and_expand_argv_dynamic current argv arg_spec f msg - with - | Arg.Bad msg -> Printf.eprintf "%s" msg; exit 2 - | Arg.Help msg -> Printf.printf "%s" msg; exit 0 +let create_usage_msg program = + Printf.sprintf "Usage: %s \n\ + Try '%s --help' for more information." program program + + +let print_arguments program = + Arg.usage !arg_spec (create_usage_msg program) diff --git a/ocaml/utils/clflags.mli b/ocaml/utils/clflags.mli index 36c02a8b351..ef5eddcabb1 100644 --- a/ocaml/utils/clflags.mli +++ b/ocaml/utils/clflags.mli @@ -13,6 +13,8 @@ (* *) (**************************************************************************) + + (** Command line flags *) (** Optimization parameters represented as ints indexed by round number. *) @@ -56,6 +58,7 @@ val compile_only : bool ref val output_name : string option ref val include_dirs : string list ref val no_std_include : bool ref +val no_cwd : bool ref val print_types : bool ref val make_archive : bool ref val debug : bool ref @@ -110,6 +113,7 @@ val locations : bool ref val dump_source : bool ref val dump_parsetree : bool ref val dump_typedtree : bool ref +val dump_shape : bool ref val dump_rawlambda : bool ref val dump_lambda : bool ref val dump_rawclambda : bool ref @@ -125,8 +129,6 @@ val dump_cmm : bool ref val dump_selection : bool ref val dump_cse : bool ref val dump_live : bool ref -val dump_avail : bool ref -val debug_runavail : bool ref val dump_spill : bool ref val dump_split : bool ref val dump_interf : bool ref @@ -202,9 +204,10 @@ val dumped_pass : string -> bool val set_dumped_pass : string -> bool -> unit val dump_into_file : bool ref +val dump_dir : string option ref module Extension : sig - type t = Comprehensions | Local | Include_functor + type t = Comprehensions | Local | Include_functor | Polymorphic_parameters val enable : string -> unit val is_enabled : t -> bool val to_string : t -> string @@ -282,11 +285,8 @@ val arg_spec : (string * Arg.spec * string) list ref added. *) val add_arguments : string -> (string * Arg.spec * string) list -> unit -(* [parse_arguments argv anon_arg usage] will parse the arguments, using - the arguments provided in [Clflags.arg_spec]. -*) -val parse_arguments : string array -> Arg.anon_fun -> string -> unit - +(* [create_usage_msg program] creates a usage message for [program] *) +val create_usage_msg: string -> string (* [print_arguments usage] print the standard usage message *) val print_arguments : string -> unit diff --git a/ocaml/utils/compilation_unit.ml b/ocaml/utils/compilation_unit.ml index 49e29068da0..bf52786d86d 100644 --- a/ocaml/utils/compilation_unit.ml +++ b/ocaml/utils/compilation_unit.ml @@ -17,12 +17,11 @@ [@@@ocaml.warning "+a-9-40-41-42"] open! Int_replace_polymorphic_compare - module List = Misc.Stdlib.List module String = Misc.Stdlib.String type error = - | Invalid_character of char + | Invalid_character of char * string | Bad_compilation_unit_name of string exception Error of error @@ -41,17 +40,23 @@ let output_of_print print = module Name : sig type t + include Identifiable.S with type t := t + val dummy : t + + val predef_exn : t + val of_string : string -> t + val to_string : t -> string - val persistent_ident : t -> Ident.t + val check_as_path_component : t -> unit end = struct (* Be VERY careful changing this. Anything not equivalent to [string] will require bumping magic numbers due to changes in file formats, in addition to breaking the (somewhat horrifying) invariant on - [Cmm_helpers.globals_map]. Furthermore there are uses of polymorphic + [Cmm_helpers.globals_map]. Furthermore there are uses of polymorphic compare hidden in [List.mem], [List.assoc] etc. *) type t = string @@ -59,14 +64,17 @@ end = struct type nonrec t = t let compare = String.compare + let equal = String.equal + let hash = Hashtbl.hash + let print = String.print + let output = output_of_print print end) - let isupper chr = - Char.equal (Char.uppercase_ascii chr) chr + let isupper chr = Char.equal (Char.uppercase_ascii chr) chr let of_string str = if String.equal str "" @@ -78,25 +86,34 @@ end = struct executables to have names like ".cinaps" that aren't valid module names. *) let check_as_path_component t = if String.length t < 1 - || not (isupper (String.get t 0)) - || String.contains t '.' + || (not (isupper (String.get t 0))) + || String.contains t '.' then raise (Error (Bad_compilation_unit_name t)) let dummy = "*dummy*" - let to_string t = t + let predef_exn = "*predef*" - let persistent_ident t = Ident.create_persistent t + let to_string t = t end module Prefix : sig type t + include Identifiable.S with type t := t - val parse_for_pack : string option -> t + + val parse_for_pack : string -> t + val from_clflags : unit -> t + + val of_list : Name.t list -> t + val to_list : t -> Name.t list + val to_string : t -> string + val empty : t + val is_empty : t -> bool end = struct (* As with [Name.t], changing this will change several file formats, requiring @@ -122,157 +139,256 @@ end = struct let is_valid_character first_char c = let code = Char.code c in - if first_char then - code >= 65 && code <= 90 (* [A-Z] *) + if first_char + then code >= 65 && code <= 90 (* [A-Z] *) else Char.equal c '_' - || code >= 48 && 57 <= 90 (* [0-9] *) - || code >= 65 && code <= 90 (* [A-Z] *) - || code >= 97 && code <= 122 (* [a-z] *) + || (code >= 48 && 57 <= 90 (* [0-9] *)) + || (code >= 65 && code <= 90 (* [A-Z] *)) + || (code >= 97 && code <= 122 (* [a-z] *)) - let parse pack = + let parse_for_pack pack = let prefix = String.split_on_char '.' pack in ListLabels.iter prefix ~f:(fun module_name -> - String.iteri (fun i c -> - if not (is_valid_character (i=0) c) then - raise (Error (Invalid_character c))) - module_name); + String.iteri + (fun i c -> + if not (is_valid_character (i = 0) c) + then raise (Error (Invalid_character (c, module_name)))) + module_name); ListLabels.map prefix ~f:Name.of_string - let parse_for_pack = function + let from_clflags () = + match !Clflags.for_package with | None -> [] - | Some pack -> parse pack - - let from_clflags () = parse_for_pack !Clflags.for_package + | Some pack -> parse_for_pack pack - let to_string p = - Format.asprintf "%a" print p + let to_string p = Format.asprintf "%a" print p let empty = [] - let is_empty t = - match t with - | [] -> true - | _::_ -> false + let is_empty t = match t with [] -> true | _ :: _ -> false + + let of_list t = t let to_list t = t end -(* As with [Name.t], changing this requires bumping magic numbers. *) -type t = { - name : Name.t; - for_pack_prefix : Prefix.t; - hash : int; -} +(* As with [Name.t], changing [with_prefix] or [t] requires bumping magic + numbers. *) +type with_prefix = + { name : Name.t; + for_pack_prefix : Prefix.t + } + +(* type t = Without_prefix of Name.t [@@unboxed] | With_prefix of with_prefix *) +type t = Obj.t + +(* Some manual inlining is done here to ensure good performance under + Closure. *) + +let for_pack_prefix_and_name t = + let tag = Obj.tag t in + assert (tag = 0 || tag = Obj.string_tag); + if tag <> 0 + then Prefix.empty, Sys.opaque_identity (Obj.obj t : Name.t) + else + let with_prefix = Sys.opaque_identity (Obj.obj t : with_prefix) in + with_prefix.for_pack_prefix, with_prefix.name + +let name t = + let tag = Obj.tag t in + assert (tag = 0 || tag = Obj.string_tag); + if tag <> 0 + then Sys.opaque_identity (Obj.obj t : Name.t) + else + let with_prefix = Sys.opaque_identity (Obj.obj t : with_prefix) in + with_prefix.name + +let for_pack_prefix t = + let tag = Obj.tag t in + assert (tag = 0 || tag = Obj.string_tag); + if tag <> 0 + then Prefix.empty + else + let with_prefix = Sys.opaque_identity (Obj.obj t : with_prefix) in + with_prefix.for_pack_prefix let create for_pack_prefix name = - if not (Prefix.is_empty for_pack_prefix) then begin - Name.check_as_path_component name; - ListLabels.iter ~f:Name.check_as_path_component - (for_pack_prefix |> Prefix.to_list) - end; - { name; - for_pack_prefix; - hash = Hashtbl.hash (name, for_pack_prefix) - } + let empty_prefix = Prefix.is_empty for_pack_prefix in + let () = + if not empty_prefix + then ( + Name.check_as_path_component name; + ListLabels.iter ~f:Name.check_as_path_component + (for_pack_prefix |> Prefix.to_list)) + in + if empty_prefix + then Sys.opaque_identity (Obj.repr name) + else Sys.opaque_identity (Obj.repr { for_pack_prefix; name }) + +let create_child parent name_ = + let prefix = + (for_pack_prefix parent |> Prefix.to_list) @ [name parent] |> Prefix.of_list + in + create prefix name_ let of_string str = let for_pack_prefix, name = match String.rindex_opt str '.' with | None -> Prefix.empty, Name.of_string str | Some 0 -> - (* See [Name.check_as_path_component]; this allows ".cinaps" as a - compilation unit *) - Prefix.empty, Name.of_string str - | Some pos -> - Prefix.parse_for_pack (Some (String.sub str 0 (pos+1))), - Name.of_string (String.sub str (pos+1) (String.length str - pos - 1)) + (* See [Name.check_as_path_component]; this allows ".cinaps" as a + compilation unit *) + Prefix.empty, Name.of_string str + | Some _ -> Misc.fatal_errorf "[of_string] does not parse qualified names" in create for_pack_prefix name let dummy = create Prefix.empty (Name.of_string "*none*") -let predef_exn = create Prefix.empty (Name.of_string "*predef*") - -let name t = t.name +let predef_exn = create Prefix.empty Name.predef_exn -let for_pack_prefix t = t.for_pack_prefix +let name_as_string t = name t |> Name.to_string -let with_for_pack_prefix t for_pack_prefix = { t with for_pack_prefix; } +let with_for_pack_prefix t for_pack_prefix = create for_pack_prefix (name t) -let is_packed t = not (Prefix.is_empty t.for_pack_prefix) +let is_packed t = not (Prefix.is_empty (for_pack_prefix t)) include Identifiable.Make (struct type nonrec t = t - let compare - ({ name = name1; for_pack_prefix = for_pack_prefix1; - hash = hash1; _} as t1) - ({ name = name2; for_pack_prefix = for_pack_prefix2; - hash = hash2; _} as t2) = - if t1 == t2 then 0 + let compare t1 t2 = + if t1 == t2 + then 0 else - let c = Stdlib.compare hash1 hash2 in - if c <> 0 then c - else - let c = Name.compare name1 name2 in - if c <> 0 then c - else Prefix.compare for_pack_prefix1 for_pack_prefix2 + let for_pack_prefix1, name1 = for_pack_prefix_and_name t1 in + let for_pack_prefix2, name2 = for_pack_prefix_and_name t2 in + let c = Name.compare name1 name2 in + if c <> 0 then c else Prefix.compare for_pack_prefix1 for_pack_prefix2 - let equal x y = - if x == y then true - else compare x y = 0 + let equal x y = if x == y then true else compare x y = 0 let print fmt t = - if Prefix.is_empty t.for_pack_prefix then - Format.fprintf fmt "%a" Name.print t.name - else - Format.fprintf fmt "%a.%a" - Prefix.print t.for_pack_prefix - Name.print t.name + let for_pack_prefix, name = for_pack_prefix_and_name t in + if Prefix.is_empty for_pack_prefix + then Format.fprintf fmt "%a" Name.print name + else Format.fprintf fmt "%a.%a" Prefix.print for_pack_prefix Name.print name let output = output_of_print print - let hash t = t.hash + let hash t = + let for_pack_prefix, name = for_pack_prefix_and_name t in + Hashtbl.hash (Name.hash name, Prefix.hash for_pack_prefix) end) -let full_path t = - (Prefix.to_list t.for_pack_prefix) @ [ t.name ] +let full_path t = Prefix.to_list (for_pack_prefix t) @ [name t] let is_parent t ~child = - List.equal Name.equal (full_path t) (Prefix.to_list child.for_pack_prefix) - -let print_name ppf t = - Format.fprintf ppf "%a" Name.print t.name + List.equal Name.equal (full_path t) (Prefix.to_list (for_pack_prefix child)) + +let is_strict_prefix list1 ~of_:list2 ~equal = + (not (List.equal equal list1 list2)) && List.is_prefix list1 ~of_:list2 ~equal + +let can_access_by_name t ~accessed_by:me = + let my_path = full_path me in + (* Criterion 1 in .mli *) + let t's_prefix_is_my_ancestor = + List.is_prefix + (for_pack_prefix t |> Prefix.to_list) + ~of_:my_path ~equal:Name.equal + in + (* Criterion 2 *) + let t_is_not_my_strict_ancestor = + not (is_strict_prefix (full_path t) ~of_:my_path ~equal:Name.equal) + in + t's_prefix_is_my_ancestor && t_is_not_my_strict_ancestor + +let can_access_cmx_file = can_access_by_name + +let which_cmx_file desired_comp_unit ~accessed_by : t = + let desired_prefix = for_pack_prefix desired_comp_unit in + if Prefix.is_empty desired_prefix + then + (* If the unit we're looking for is not in a pack, then the correct .cmx + file is the one with the same name as the unit, irrespective of any + current pack. *) + desired_comp_unit + else + (* This lines up the full paths as described above. *) + let rec match_components ~current ~desired ~acc_rev = + match current, desired with + | current_name :: current, desired_name :: desired -> + if Name.equal current_name desired_name + then + (* The full paths are equal up to the current point; keep going. *) + let acc_rev = current_name :: acc_rev in + match_components ~current ~desired ~acc_rev + else + (* The paths have diverged. The next component of the desired path is + the .cmx file to load. *) + acc_rev, desired_name + | [], desired_name :: _desired -> + (* The whole of the current unit's full path (including the name of the + unit itself) is now known to be a prefix of the desired unit's pack + *prefix*. This means we must be making a pack. The .cmx file to load + is named after the next component of the desired unit's path (which + may in turn be a pack). *) + acc_rev, desired_name + | [], [] -> + (* The paths were equal, so the desired compilation unit is just the + current one. *) + acc_rev, name desired_comp_unit + | _ :: _, [] -> + (* The current path is longer than the desired unit's path, which means + we're attempting to go back up the pack hierarchy. This is an + error. *) + Misc.fatal_errorf + "Compilation unit@ %a@ is inaccessible when compiling compilation \ + unit@ %a" + print desired_comp_unit print accessed_by + in + let prefix_rev, name = + match_components ~current:(full_path accessed_by) + ~desired:(full_path desired_comp_unit) + ~acc_rev:[] + in + (* CR lmaurer: It's silly to be writing `ListLabels` out everywhere, + especially here. *) + create (ListLabels.rev prefix_rev |> Prefix.of_list) name + +let print_name ppf t = Format.fprintf ppf "%a" Name.print (name t) let full_path_as_string t = - Format.asprintf "%a" print t - -let print_debug ppf { for_pack_prefix; hash = _; name } = - if Prefix.is_empty for_pack_prefix then - Format.fprintf ppf "@[(\ - @[(id@ %a)@])@]" - Name.print name + (* We take care not to break sharing when the prefix is empty. However we + can't share in the case where there is a prefix. *) + if Prefix.is_empty (for_pack_prefix t) + then Name.to_string (name t) + else Format.asprintf "%a" print t + +let to_global_ident_for_bytecode t = + Ident.create_persistent (full_path_as_string t) + +let print_debug ppf t = + let name = name t in + let for_pack_prefix = for_pack_prefix t in + if Prefix.is_empty for_pack_prefix + then Format.fprintf ppf "@[(@[(id@ %a)@])@]" Name.print name else - Format.fprintf ppf "@[(\ - @[(for_pack_prefix@ %a)@]@;\ - @[(name@ %a)@]" - Prefix.print for_pack_prefix - Name.print name + Format.fprintf ppf + "@[(@[(for_pack_prefix@ %a)@]@;@[(name@ %a)@]" + Prefix.print for_pack_prefix Name.print name let current = ref None -let set_current t = - current := Some t +let set_current t_opt = current := t_opt let get_current () = !current +let get_current_or_dummy () = Option.value !current ~default:dummy + let get_current_exn () = match !current with | Some t -> t | None -> Misc.fatal_error "No compilation unit set" -let is_current t = - match !current with - | None -> false - | Some t' -> equal t t' +let is_current t = match !current with None -> false | Some t' -> equal t t' diff --git a/ocaml/utils/compilation_unit.mli b/ocaml/utils/compilation_unit.mli index 72215ab9a14..d75c89c60bc 100644 --- a/ocaml/utils/compilation_unit.mli +++ b/ocaml/utils/compilation_unit.mli @@ -18,10 +18,9 @@ prefixes. By "compilation unit" we mean the code and data associated with the - compilation of a single .ml source file: that is to say, file-level - entities having OCaml semantics. The notion neither includes the special - "startup" files nor external libraries. -*) + compilation of a single .ml source file: that is to say, file-level entities + having OCaml semantics. The notion neither includes the special "startup" + files nor external libraries. *) [@@@ocaml.warning "+a-9-40-41-42"] @@ -43,7 +42,8 @@ module Name : sig val to_string : t -> string - val persistent_ident : t -> Ident.t + (** The name of the distinguished compilation unit for predefined exceptions. *) + val predef_exn : t end module Prefix : sig @@ -56,10 +56,12 @@ module Prefix : sig val empty : t - (** [parse_for_pack p] returns the list of nested packed modules from a - "-for-pack" argument. *) - val parse_for_pack : string option -> t + (** [parse_for_pack p] returns the list of nested packed modules, as expressed + in the syntax of the "-for-pack" argument. *) + val parse_for_pack : string -> t + (** Return the prefix specified to "-for-pack". Returns the empty prefix if + no "-for-pack" was passed. *) val from_clflags : unit -> t (** Return the list of names comprising the prefix, outermost first. *) @@ -89,14 +91,71 @@ val print_debug : Format.formatter -> t -> unit mangled in any way). *) val create : Prefix.t -> Name.t -> t -(** Create a compilation unit from the given [name]. The "-for-pack" of - prefix is extracted if there is any. *) +(** Create a compilation unit contained by another. Effectively uses the + parent compilation unit as the prefix. *) +val create_child : t -> Name.t -> t + +(** Create a compilation unit from the given [name]. No prefix is allowed; + throws a fatal error if there is a "." in the name. (As a special case, + a "." is allowed as the first character, to handle compilation units + which take their names from hidden files.) *) val of_string : string -> t +(** Create a global [Ident.t] representing this compilation unit. Only intended + for use in bytecode; most uses of [Ident.t]s that are known to be global + should simply use [t] instead. *) +val to_global_ident_for_bytecode : t -> Ident.t + (** Find whether one compilation unit has another as a child. That is, whether the other unit has this one as its path prefix. *) val is_parent : t -> child:t -> bool +(** Find whether one compilation unit can access another directly, without going + through a pack. Equivalently, find whether one unit's .cmx file is visible + while compiling another. Access to a packed unit is allowed only "from + inside the pack," which is to say, a unit can only access its own members + and those of its ancestors, though not the ancestors themselves. Thought of + as a node in a tree, this means a module can access its own children, its + own siblings, and its ancestors' siblings. + + In terms of paths, in order for [X] to access [Y], + + (1) [Y]'s prefix must be equal to or a prefix of [X]'s full path, and + (2) [Y] itself must not be (strictly) a prefix of [X] (though [X] and [Y] may + be equal). + + For example: + + * [A.B.C] _can_ access [A.Q] because [A.Q] is a member of [A] and [A] is + an ancestor of [A.B.C]. In other words, [A.Q]'s prefix is [A] and [A] is a + prefix of [A.B.C]. + * [A.Q] _cannot_ access [A.B.C] because [A.B] is not a prefix of [A.Q]. + * [A.Q] _can_ however access [A.B], because [A] _is_ a prefix of [A.Q]. + * [A.Q] _can_ also access its own member, [A.Q.R], because [A.Q.R]'s prefix + is exactly [A.Q]. + * [A.Q] _cannot_ access [A.Q.R.S], because [A.Q.R] is not a prefix of [A.Q]. + * [A.Q] _can_ access [F], since [F]'s prefix is the empty path, which is + trivially a prefix of [A.Q]. + * [A.Q] _cannot_ access [F.G] (by criterion 1) or [A] (by criterion 2). *) +val can_access_by_name : t -> accessed_by:t -> bool + +(** A clearer name for [can_access_by_name] when the .cmx file is what's of + interest. *) +val can_access_cmx_file : t -> accessed_by:t -> bool + +(*_ CR-someday lmaurer: Arguably [which_cmx_file] should return a different + type, since "compilation unit for which we can load the .cmx" is an important + constraint. *) + +(** Determine which .cmx file to load for a given compilation unit. + This is tricky in the case of packs. It can be done by lining up the + desired compilation unit's full path (i.e. pack prefix then unit name) + against the accessing unit's full path and observing when/if they + diverge. + + This is only used for native code compilation. *) +val which_cmx_file : t -> accessed_by:t -> t + (** A distinguished compilation unit for initialisation of mutable state. *) val dummy : t @@ -106,6 +165,13 @@ val predef_exn : t (** The name of the compilation unit, excluding any [for_pack_prefix]. *) val name : t -> Name.t +(** The name of the compilation unit, excluding any [for_pack_prefix], as + as a string. *) + +(* CR mshinwell: Try to delete this as soon as the functor packs work is + finished. *) +val name_as_string : t -> string + (** The "-for-pack" prefix associated with the given compilation unit. *) val for_pack_prefix : t -> Prefix.t @@ -125,13 +191,18 @@ val full_path : t -> Name.t list val full_path_as_string : t -> string type error = private - | Invalid_character of char + | Invalid_character of char * string | Bad_compilation_unit_name of string (** The exception raised by conversion functions in this module. *) exception Error of error -val set_current : t -> unit +val set_current : t option -> unit + val get_current : unit -> t option + +val get_current_or_dummy : unit -> t + val get_current_exn : unit -> t + val is_current : t -> bool diff --git a/ocaml/utils/config.mli b/ocaml/utils/config.mli index 3a49e4054c2..5c17c085481 100644 --- a/ocaml/utils/config.mli +++ b/ocaml/utils/config.mli @@ -23,6 +23,9 @@ val version: string (** The current version number of the system *) +val bindir: string +(** The directory containing the binary programs *) + val standard_library: string (** The directory containing the standard libraries *) @@ -79,8 +82,13 @@ val mkexe: string val mkmaindll: string (** The linker command line to build main programs as dlls. *) -val ranlib: string -(** Command to randomize a library, or "" if not needed *) +val default_rpath: string +(** Option to add a directory to be searched for libraries at runtime + (used by ocamlmklib) *) + +val mksharedlibrpath: string +(** Option to add a directory to be searched for shared libraries at runtime + (used by ocamlmklib) *) val ar: string (** Name of the ar command, or "" if not needed (MSVC) *) @@ -249,6 +257,11 @@ val probes : bool val windows_unicode: bool (** Whether Windows Unicode runtime is enabled *) +val naked_pointers : bool +(** Whether the runtime supports naked pointers + + @since 4.14.0 *) + val supports_shared_libraries: bool (** Whether shared libraries are supported @@ -260,6 +273,9 @@ val afl_instrument : bool val stack_allocation : bool (** Whether to stack allocate local values *) +val poll_insertion : bool +(** Whether to insert poll points *) + (** Access to configuration values *) val print_config : out_channel -> unit diff --git a/ocaml/utils/config.mlp b/ocaml/utils/config.mlp index 813518a98fe..a96a6aefd68 100644 --- a/ocaml/utils/config.mlp +++ b/ocaml/utils/config.mlp @@ -14,9 +14,11 @@ (* *) (**************************************************************************) -(* The main OCaml version string has moved to ../VERSION *) +(* The main OCaml version string has moved to ../build-aux/ocaml_version.m4 *) let version = Sys.ocaml_version +let bindir = "%%BINDIR%%" + let standard_library_default = "%%LIBDIR%%" let standard_library = @@ -52,18 +54,20 @@ let native_c_compiler = c_compiler ^ " " ^ ocamlopt_cflags ^ " " ^ ocamlopt_cppflags let native_c_libraries = "%%NATIVECCLIBS%%" let native_pack_linker = "%%PACKLD%%" -let ranlib = "%%RANLIBCMD%%" +let default_rpath = "%%RPATH%%" +let mksharedlibrpath = "%%MKSHAREDLIBRPATH%%" let ar = "%%ARCMD%%" +let supports_shared_libraries = %%SUPPORTS_SHARED_LIBRARIES%% let mkdll, mkexe, mkmaindll = (* @@DRA Cygwin - but only if shared libraries are enabled, which we should be able to detect? *) - if Sys.os_type = "Win32" then + if Sys.win32 || Sys.cygwin && supports_shared_libraries then try let flexlink = let flexlink = Sys.getenv "OCAML_FLEXLINK" in let f i = let c = flexlink.[i] in - if c = '/' then '\\' else c in + if c = '/' && Sys.win32 then '\\' else c in (String.init (String.length flexlink) f) ^ " %%FLEXLINK_FLAGS%%" in flexlink ^ "%%FLEXLINK_DLL_LDFLAGS%%", flexlink ^ " -exe%%FLEXLINK_LDFLAGS%%", @@ -76,14 +80,12 @@ let mkdll, mkexe, mkmaindll = let flambda = %%FLAMBDA%% let flambda2 = %%FLAMBDA2%% let with_flambda_invariants = %%WITH_FLAMBDA_INVARIANTS%% - let with_cmm_invariants = %%WITH_CMM_INVARIANTS%% let flambda_backend = true - let safe_string = %%FORCE_SAFE_STRING%% let default_safe_string = %%DEFAULT_SAFE_STRING%% let windows_unicode = %%WINDOWS_UNICODE%% != 0 -let supports_shared_libraries = %%SUPPORTS_SHARED_LIBRARIES%% +let naked_pointers = %%NAKED_POINTERS%% let flat_float_array = %%FLAT_FLOAT_ARRAY%% @@ -92,31 +94,32 @@ let probes = %%PROBES%% let afl_instrument = %%AFL_INSTRUMENT%% let stack_allocation = %%STACK_ALLOCATION%% +let poll_insertion = %%POLL_INSERTION%% (* When artifacts are incompatible with upstream OCaml, ocaml-jst uses - magic numbers ending in 5xx. (The AST and bytecode executables remain + magic numbers ending in 5xx. (The AST remains compatible, so use upstream numbers) *) -let exec_magic_number = "Caml1999X029" +let exec_magic_number = "Caml1999X500" (* exec_magic_number is duplicated in runtime/caml/exec.h *) -and cmi_magic_number = "Caml1999I500" -and cmo_magic_number = "Caml1999O500" -and cma_magic_number = "Caml1999A500" +and cmi_magic_number = "Caml1999I501" +and cmo_magic_number = "Caml1999O501" +and cma_magic_number = "Caml1999A501" and cmx_magic_number = if flambda || flambda2 then - "Caml2021y502" + "Caml2021y503" else - "Caml2021Y502" + "Caml2021Y503" and cmxa_magic_number = if flambda || flambda2 then - "Caml2021z502" + "Caml2021z503" else - "Caml2021Z502" -and ast_impl_magic_number = "Caml1999M029" -and ast_intf_magic_number = "Caml1999N029" -and cmxs_magic_number = "Caml1999D501" -and cmt_magic_number = "Caml1999T500" -and linear_magic_number = "Caml1999L500" -and cfg_magic_number = "Caml2021G500" + "Caml2021Z503" +and ast_impl_magic_number = "Caml1999M031" +and ast_intf_magic_number = "Caml1999N031" +and cmxs_magic_number = "Caml1999D502" +and cmt_magic_number = "Caml1999T501" +and linear_magic_number = "Caml1999L501" +and cfg_magic_number = "Caml2021G501" let interface_suffix = ref ".mli" @@ -184,7 +187,6 @@ let configuration_variables = p "bytecomp_c_libraries" bytecomp_c_libraries; p "native_c_libraries" native_c_libraries; p "native_pack_linker" native_pack_linker; - p "ranlib" ranlib; p "architecture" architecture; p "model" model; p_int "int_size" Sys.int_size; @@ -213,6 +215,7 @@ let configuration_variables = p_bool "afl_instrument" afl_instrument; p_bool "windows_unicode" windows_unicode; p_bool "supports_shared_libraries" supports_shared_libraries; + p_bool "naked_pointers" naked_pointers; p "exec_magic_number" exec_magic_number; p "cmi_magic_number" cmi_magic_number; @@ -228,6 +231,7 @@ let configuration_variables = p_bool "flambda_backend" flambda_backend; p_bool "probes" probes; + p_bool "stack_allocation" stack_allocation; ] let print_config_value oc = function diff --git a/ocaml/utils/consistbl.ml b/ocaml/utils/consistbl.ml index 311c0e413ab..5fd05939b3b 100644 --- a/ocaml/utils/consistbl.ml +++ b/ocaml/utils/consistbl.ml @@ -23,8 +23,10 @@ module Make (Module_name : sig module Map : Map.S with type key = t module Tbl : Hashtbl.S with type key = t val compare : t -> t -> int +end) (Data : sig + type t end) = struct - type t = (Digest.t * filepath) Module_name.Tbl.t + type t = (Data.t * Digest.t * filepath) Module_name.Tbl.t let create () = Module_name.Tbl.create 13 @@ -34,36 +36,41 @@ end) = struct unit_name : Module_name.t; inconsistent_source : string; original_source : string; + inconsistent_data : Data.t; + original_data : Data.t; } exception Not_available of Module_name.t - let check_ tbl name crc source = - let (old_crc, old_source) = Module_name.Tbl.find tbl name in - if crc <> old_crc then raise(Inconsistency { + let check_ tbl name data crc source = + let (old_data, old_crc, old_source) = Module_name.Tbl.find tbl name in + if not (Digest.equal crc old_crc) + then raise(Inconsistency { unit_name = name; inconsistent_source = source; original_source = old_source; + inconsistent_data = data; + original_data = old_data; }) - let check tbl name crc source = - try check_ tbl name crc source + let check tbl name data crc source = + try check_ tbl name data crc source with Not_found -> - Module_name.Tbl.add tbl name (crc, source) + Module_name.Tbl.add tbl name (data, crc, source) - let check_noadd tbl name crc source = - try check_ tbl name crc source + let check_noadd tbl name data crc source = + try check_ tbl name data crc source with Not_found -> raise (Not_available name) - let set tbl name crc source = Module_name.Tbl.add tbl name (crc, source) + let set tbl name data crc source = Module_name.Tbl.add tbl name (data, crc, source) - let source tbl name = snd (Module_name.Tbl.find tbl name) + let source tbl name = thd3 (Module_name.Tbl.find tbl name) let find t name = match Module_name.Tbl.find t name with | exception Not_found -> None - | (crc, _) -> Some crc + | (data, crc, _) -> Some (data, crc) let extract l tbl = let l = List.sort_uniq Module_name.compare l in diff --git a/ocaml/utils/consistbl.mli b/ocaml/utils/consistbl.mli index 6ca571bd891..8deb715aa40 100644 --- a/ocaml/utils/consistbl.mli +++ b/ocaml/utils/consistbl.mli @@ -28,6 +28,8 @@ module Make (Module_name : sig module Map : Map.S with type key = t module Tbl : Hashtbl.S with type key = t val compare : t -> t -> int +end) (Data : sig + type t end) : sig type t @@ -35,21 +37,21 @@ end) : sig val clear: t -> unit - val check: t -> Module_name.t -> Digest.t -> filepath -> unit - (* [check tbl name crc source] + val check: t -> Module_name.t -> Data.t -> Digest.t -> filepath -> unit + (* [check tbl name data crc source] checks consistency of ([name], [crc]) with infos previously stored in [tbl]. If no CRC was previously associated with - [name], record ([name], [crc]) in [tbl]. + [name], record ([name], [data], [crc]) in [tbl]. [source] is the name of the file from which the information comes from. This is used for error reporting. *) - val check_noadd: t -> Module_name.t -> Digest.t -> filepath -> unit + val check_noadd: t -> Module_name.t -> Data.t -> Digest.t -> filepath -> unit (* Same as [check], but raise [Not_available] if no CRC was previously associated with [name]. *) - val set: t -> Module_name.t -> Digest.t -> filepath -> unit - (* [set tbl name crc source] forcefully associates [name] with - [crc] in [tbl], even if [name] already had a different CRC + val set: t -> Module_name.t -> Data.t -> Digest.t -> filepath -> unit + (* [set tbl name data crc source] forcefully associates [name] with + ([data], [crc]) in [tbl], even if [name] already had a different CRC associated with [name] in [tbl]. *) val source: t -> Module_name.t -> filepath @@ -57,14 +59,16 @@ end) : sig if the latter has an associated CRC in [tbl]. Raise [Not_found] otherwise. *) - val find: t -> Module_name.t -> Digest.t option + val find: t -> Module_name.t -> (Data.t * Digest.t) option - val extract: Module_name.t list -> t -> (Module_name.t * Digest.t option) list + val extract: + Module_name.t list -> t -> (Module_name.t * (Data.t * Digest.t) option) list (* [extract tbl names] returns an associative list mapping each string - in [names] to the CRC associated with it in [tbl]. If no CRC is - associated with a name then it is mapped to [None]. *) + in [names] to the data and CRC associated with it in [tbl]. If no CRC + is associated with a name then it is mapped to [None]. *) - val extract_map : Module_name.Set.t -> t -> Digest.t option Module_name.Map.t + val extract_map : + Module_name.Set.t -> t -> (Data.t * Digest.t) option Module_name.Map.t (* Like [extract] but with a more sophisticated type. *) val filter: (Module_name.t -> bool) -> t -> unit @@ -75,6 +79,8 @@ end) : sig unit_name : Module_name.t; inconsistent_source : string; original_source : string; + inconsistent_data : Data.t; + original_data : Data.t; } (* Raised by [check] when a CRC mismatch is detected. *) diff --git a/ocaml/utils/diffing.ml b/ocaml/utils/diffing.ml new file mode 100644 index 00000000000..e5b230e2334 --- /dev/null +++ b/ocaml/utils/diffing.ml @@ -0,0 +1,447 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Radanne, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2020 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +[@@@warning "-16"] + +(* This module implements a modified version of Wagner-Fischer + See + for preliminary reading. + + The main extensions is that: + - State is computed based on the optimal patch so far. + - The lists can be extended at each state computation. + + We add the constraint that extensions can only be in one side + (either the left or right list). This is enforced by the external API. + +*) + +(** Shared types *) +type change_kind = + | Deletion + | Insertion + | Modification + | Preservation + +let style = function + | Preservation -> Misc.Color.[ FG Green ] + | Deletion -> Misc.Color.[ FG Red; Bold] + | Insertion -> Misc.Color.[ FG Red; Bold] + | Modification -> Misc.Color.[ FG Magenta; Bold] + +let prefix ppf (pos, p) = + let sty = style p in + Format.pp_open_stag ppf (Misc.Color.Style sty); + Format.fprintf ppf "%i. " pos; + Format.pp_close_stag ppf () + + +let (let*) = Option.bind +let (let+) x f = Option.map f x +let (let*!) x f = Option.iter f x + +module type Defs = sig + type left + type right + type eq + type diff + type state +end + +type ('left,'right,'eq,'diff) change = + | Delete of 'left + | Insert of 'right + | Keep of 'left * 'right *' eq + | Change of 'left * 'right * 'diff + +let classify = function + | Delete _ -> Deletion + | Insert _ -> Insertion + | Change _ -> Modification + | Keep _ -> Preservation + +module Define(D:Defs) = struct + open D + +type nonrec change = (left,right,eq,diff) change + +type patch = change list +module type S = sig + val diff: state -> left array -> right array -> patch +end + + +type full_state = { + line: left array; + column: right array; + state: state +} + +(* The matrix supporting our dynamic programming implementation. + + Each cell contains: + - The diff and its weight + - The state computed so far + - The lists, potentially extended locally. + + The matrix can also be reshaped. +*) +module Matrix : sig + + type shape = { l : int ; c : int } + + type t + + val make : shape -> t + val reshape : shape -> t -> t + + (** accessor functions *) + val diff : t -> int -> int -> change option + val state : t -> int -> int -> full_state option + val weight : t -> int -> int -> int + + val line : t -> int -> int -> left option + val column : t -> int -> int -> right option + + val set : + t -> int -> int -> + diff:change option -> + weight:int -> + state:full_state -> + unit + + (** the shape when starting filling the matrix *) + val shape : t -> shape + + (** [shape m i j] is the shape as seen from the state at position (i,j) + after some possible extensions + *) + val shape_at : t -> int -> int -> shape option + + (** the maximal shape on the whole matrix *) + val real_shape : t -> shape + + (** debugging printer *) + val[@warning "-32"] pp : Format.formatter -> t -> unit + +end = struct + + type shape = { l : int ; c : int } + + type t = + { states: full_state option array array; + weight: int array array; + diff: change option array array; + columns: int; + lines: int; + } + let opt_get a n = + if n < Array.length a then Some (Array.unsafe_get a n) else None + let line m i j = let* st = m.states.(i).(j) in opt_get st.line i + let column m i j = let* st = m.states.(i).(j) in opt_get st.column j + let diff m i j = m.diff.(i).(j) + let weight m i j = m.weight.(i).(j) + let state m i j = m.states.(i).(j) + let shape m = { l = m.lines ; c = m.columns } + + let set m i j ~diff ~weight ~state = + m.weight.(i).(j) <- weight; + m.states.(i).(j) <- Some state; + m.diff.(i).(j) <- diff; + () + + let shape_at tbl i j = + let+ st = tbl.states.(i).(j) in + let l = Array.length st.line in + let c = Array.length st.column in + { l ; c } + + let real_shape tbl = + let lines = ref tbl.lines in + let columns = ref tbl.columns in + for i = 0 to tbl.lines do + for j = 0 to tbl.columns do + let*! {l; c} = shape_at tbl i j in + if l > !lines then lines := l; + if c > !columns then columns := c + done; + done; + { l = !lines ; c = !columns } + + let make { l = lines ; c = columns } = + { states = Array.make_matrix (lines + 1) (columns + 1) None; + weight = Array.make_matrix (lines + 1) (columns + 1) max_int; + diff = Array.make_matrix (lines + 1) (columns + 1) None; + lines; + columns; + } + + let reshape { l = lines ; c = columns } m = + let copy default a = + Array.init (1+lines) (fun i -> Array.init (1+columns) (fun j -> + if i <= m.lines && j <= m.columns then + a.(i).(j) + else default) ) in + { states = copy None m.states; + weight = copy max_int m.weight; + diff = copy None m.diff; + lines; + columns + } + + let pp ppf m = + let { l ; c } = shape m in + Format.eprintf "Shape : %i, %i@." l c; + for i = 0 to l do + for j = 0 to c do + let d = diff m i j in + match d with + | None -> + Format.fprintf ppf " " + | Some diff -> + let sdiff = match diff with + | Insert _ -> "\u{2190}" + | Delete _ -> "\u{2191}" + | Keep _ -> "\u{2196}" + | Change _ -> "\u{21F1}" + in + let w = weight m i j in + Format.fprintf ppf "%s%i " sdiff w + done; + Format.pp_print_newline ppf () + done + +end + + +(* Building the patch. + + We first select the best final cell. A potential final cell + is a cell where the local shape (i.e., the size of the strings) correspond + to its position in the matrix. In other words: it's at the end of both its + strings. We select the final cell with the smallest weight. + + We then build the patch by walking backward from the final cell to the + origin. +*) + +let select_final_state m0 = + let maybe_final i j = + match Matrix.shape_at m0 i j with + | Some shape_here -> shape_here.l = i && shape_here.c = j + | None -> false + in + let best_state (i0,j0,weigth0) (i,j) = + let weight = Matrix.weight m0 i j in + if weight < weigth0 then (i,j,weight) else (i0,j0,weigth0) + in + let res = ref (0,0,max_int) in + let shape = Matrix.shape m0 in + for i = 0 to shape.l do + for j = 0 to shape.c do + if maybe_final i j then + res := best_state !res (i,j) + done + done; + let i_final, j_final, _ = !res in + assert (i_final <> 0 || j_final <> 0); + (i_final, j_final) + +let construct_patch m0 = + let rec aux acc (i, j) = + if i = 0 && j = 0 then + acc + else + match Matrix.diff m0 i j with + | None -> assert false + | Some d -> + let next = match d with + | Keep _ | Change _ -> (i-1, j-1) + | Delete _ -> (i-1, j) + | Insert _ -> (i, j-1) + in + aux (d::acc) next + in + aux [] (select_final_state m0) + +(* Computation of new cells *) + +let select_best_proposition l = + let compare_proposition curr prop = + match curr, prop with + | None, o | o, None -> o + | Some (curr_m, curr_res), Some (m, res) -> + Some (if curr_m <= m then curr_m, curr_res else m,res) + in + List.fold_left compare_proposition None l + + module type Full_core = sig + type update_result + type update_state + val weight: change -> int + val test: state -> left -> right -> (eq, diff) result + val update: change -> update_state -> update_result + end + +module Generic + (X: Full_core + with type update_result := full_state + and type update_state := full_state) = struct + open X + + (* Boundary cell update *) + let compute_column0 tbl i = + let*! st = Matrix.state tbl (i-1) 0 in + let*! line = Matrix.line tbl (i-1) 0 in + let diff = Delete line in + Matrix.set tbl i 0 + ~weight:(weight diff + Matrix.weight tbl (i-1) 0) + ~state:(update diff st) + ~diff:(Some diff) + + let compute_line0 tbl j = + let*! st = Matrix.state tbl 0 (j-1) in + let*! column = Matrix.column tbl 0 (j-1) in + let diff = Insert column in + Matrix.set tbl 0 j + ~weight:(weight diff + Matrix.weight tbl 0 (j-1)) + ~state:(update diff st) + ~diff:(Some diff) + +let compute_inner_cell tbl i j = + let compute_proposition i j diff = + let* diff = diff in + let+ localstate = Matrix.state tbl i j in + weight diff + Matrix.weight tbl i j, (diff, localstate) + in + let del = + let diff = let+ x = Matrix.line tbl (i-1) j in Delete x in + compute_proposition (i-1) j diff + in + let insert = + let diff = let+ x = Matrix.column tbl i (j-1) in Insert x in + compute_proposition i (j-1) diff + in + let diag = + let diff = + let* state = Matrix.state tbl (i-1) (j-1) in + let* line = Matrix.line tbl (i-1) (j-1) in + let* column = Matrix.column tbl (i-1) (j-1) in + match test state.state line column with + | Ok ok -> Some (Keep (line, column, ok)) + | Error err -> Some (Change (line, column, err)) + in + compute_proposition (i-1) (j-1) diff + in + let*! newweight, (diff, localstate) = + select_best_proposition [diag;del;insert] + in + let state = update diff localstate in + Matrix.set tbl i j ~weight:newweight ~state ~diff:(Some diff) + +let compute_cell m i j = + match i, j with + | _ when Matrix.diff m i j <> None -> () + | 0,0 -> () + | 0,j -> compute_line0 m j + | i,0 -> compute_column0 m i; + | _ -> compute_inner_cell m i j + +(* Filling the matrix + + We fill the whole matrix, as in vanilla Wagner-Fischer. + At this point, the lists in some states might have been extended. + If any list have been extended, we need to reshape the matrix + and repeat the process +*) +let compute_matrix state0 = + let m0 = Matrix.make { l = 0 ; c = 0 } in + Matrix.set m0 0 0 ~weight:0 ~state:state0 ~diff:None; + let rec loop m = + let shape = Matrix.shape m in + let new_shape = Matrix.real_shape m in + if new_shape.l > shape.l || new_shape.c > shape.c then + let m = Matrix.reshape new_shape m in + for i = 0 to new_shape.l do + for j = 0 to new_shape.c do + compute_cell m i j + done + done; + loop m + else + m + in + loop m0 + end + + + module type Parameters = Full_core with type update_state := state + + module Simple(X:Parameters with type update_result := state) = struct + module Internal = Generic(struct + let test = X.test + let weight = X.weight + let update d fs = { fs with state = X.update d fs.state } + end) + + let diff state line column = + let fullstate = { line; column; state } in + Internal.compute_matrix fullstate + |> construct_patch + end + + + let may_append x = function + | [||] -> x + | y -> Array.append x y + + + module Left_variadic + (X:Parameters with type update_result := state * left array) = struct + open X + + module Internal = Generic(struct + let test = X.test + let weight = X.weight + let update d fs = + let state, a = update d fs.state in + { fs with state ; line = may_append fs.line a } + end) + + let diff state line column = + let fullstate = { line; column; state } in + Internal.compute_matrix fullstate + |> construct_patch + end + + module Right_variadic + (X:Parameters with type update_result := state * right array) = struct + open X + + module Internal = Generic(struct + let test = X.test + let weight = X.weight + let update d fs = + let state, a = update d fs.state in + { fs with state ; column = may_append fs.column a } + end) + + let diff state line column = + let fullstate = { line; column; state } in + Internal.compute_matrix fullstate + |> construct_patch + end + +end diff --git a/ocaml/utils/diffing.mli b/ocaml/utils/diffing.mli new file mode 100644 index 00000000000..80cfa5e2791 --- /dev/null +++ b/ocaml/utils/diffing.mli @@ -0,0 +1,147 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Gabriel Radanne, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2020 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Parametric diffing + + This module implements diffing over lists of arbitrary content. + It is parameterized by + - The content of the two lists + - The equality witness when an element is kept + - The diffing witness when an element is changed + + Diffing is extended to maintain state depending on the + computed changes while walking through the two lists. + + The underlying algorithm is a modified Wagner-Fischer algorithm + (see ). + + We provide the following guarantee: + Given two lists [l] and [r], if different patches result in different + states, we say that the state diverges. + - We always return the optimal patch on prefixes of [l] and [r] + on which state does not diverge. + - Otherwise, we return a correct but non-optimal patch where subpatches + with no divergent states are optimal for the given initial state. + + More precisely, the optimality of Wagner-Fischer depends on the property + that the edit-distance between a k-prefix of the left input and a l-prefix + of the right input d(k,l) satisfies + + d(k,l) = min ( + del_cost + d(k-1,l), + insert_cost + d(k,l-1), + change_cost + d(k-1,l-1) + ) + + Under this hypothesis, it is optimal to choose greedily the state of the + minimal patch transforming the left k-prefix into the right l-prefix as a + representative of the states of all possible patches transforming the left + k-prefix into the right l-prefix. + + If this property is not satisfied, we can still choose greedily a + representative state. However, the computed patch is no more guaranteed to + be globally optimal. + Nevertheless, it is still a correct patch, which is even optimal among all + explored patches. + +*) + +(** The core types of a diffing implementation *) +module type Defs = sig + type left + type right + type eq + (** Detailed equality trace *) + + type diff + (** Detailed difference trace *) + + type state + (** environment of a partial patch *) +end + +(** The kind of changes which is used to share printing and styling + across implementation*) +type change_kind = + | Deletion + | Insertion + | Modification + | Preservation +val prefix: Format.formatter -> (int * change_kind) -> unit +val style: change_kind -> Misc.Color.style list + + +type ('left,'right,'eq,'diff) change = + | Delete of 'left + | Insert of 'right + | Keep of 'left * 'right *' eq + | Change of 'left * 'right * 'diff + +val classify: _ change -> change_kind + +(** [Define(Defs)] creates the diffing types from the types + defined in [Defs] and the functors that need to be instantatied + with the diffing algorithm parameters +*) +module Define(D:Defs): sig + open D + + (** The type of potential changes on a list. *) + type nonrec change = (left,right,eq,diff) change + type patch = change list + (** A patch is an ordered list of changes. *) + + module type Parameters = sig + type update_result + + val weight: change -> int + (** [weight ch] returns the weight of the change [ch]. + Used to find the smallest patch. *) + + val test: state -> left -> right -> (eq, diff) result + (** + [test st xl xr] tests if the elements [xl] and [xr] are + co mpatible ([Ok]) or not ([Error]). + *) + + val update: change -> state -> update_result + (** [update ch st] returns the new state after applying a change. + The [update_result] type also contains expansions in the variadic + case. + *) + end + + module type S = sig + val diff: state -> left array -> right array -> patch + (** [diff state l r] computes the optimal patch between [l] and [r], + using the initial state [state]. + *) + end + + + module Simple: (Parameters with type update_result := state) -> S + + (** {1 Variadic diffing} + + Variadic diffing allows to expand the lists being diffed during diffing. + in one specific direction. + *) + module Left_variadic: + (Parameters with type update_result := state * left array) -> S + + module Right_variadic: + (Parameters with type update_result := state * right array) -> S + +end diff --git a/ocaml/utils/diffing_with_keys.ml b/ocaml/utils/diffing_with_keys.ml new file mode 100644 index 00000000000..3e1ea136803 --- /dev/null +++ b/ocaml/utils/diffing_with_keys.ml @@ -0,0 +1,208 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + + +type 'a with_pos = {pos:int; data:'a} +let with_pos l = List.mapi (fun n data -> {pos=n+1; data}) l + +(** Composite change and mismatches *) +type ('l,'r,'diff) mismatch = + | Name of {pos:int; got:string; expected:string; types_match:bool} + | Type of {pos:int; got:'l; expected:'r; reason:'diff} + +type ('l,'r,'diff) change = + | Change of ('l,'r,'diff) mismatch + | Swap of { pos: int * int; first: string; last: string } + | Move of {name:string; got:int; expected:int} + | Insert of {pos:int; insert:'r} + | Delete of {pos:int; delete:'l} + +let prefix ppf x = + let kind = match x with + | Change _ | Swap _ | Move _ -> Diffing.Modification + | Insert _ -> Diffing.Insertion + | Delete _ -> Diffing.Deletion + in + let style k ppf inner = + let sty = Diffing.style k in + Format.pp_open_stag ppf (Misc.Color.Style sty); + Format.kfprintf (fun ppf -> Format.pp_close_stag ppf () ) ppf inner + in + match x with + | Change (Name {pos; _ } | Type {pos; _}) + | Insert { pos; _ } | Delete { pos; _ } -> + style kind ppf "%i. " pos + | Swap { pos = left, right; _ } -> + style kind ppf "%i<->%i. " left right + | Move { got; expected; _ } -> + style kind ppf "%i->%i. " expected got + + + +(** To detect [move] and [swaps], we are using the fact that + there are 2-cycles in the graph of name renaming. + - [Change (x,y,_) is then an edge from + [key_left x] to [key_right y]. + - [Insert x] is an edge between the special node epsilon and + [key_left x] + - [Delete x] is an edge between [key_right] and the epsilon node + Since for 2-cycle, knowing one edge is enough to identify the cycle + it might belong to, we are using maps of partial 2-cycles. +*) +module Two_cycle: sig + type t = private (string * string) + val create: string -> string -> t +end = struct + type t = string * string + let create kx ky = + if kx <= ky then kx, ky else ky, kx +end +module Swap = Map.Make(struct + type t = Two_cycle.t + let compare: t -> t -> int = Stdlib.compare + end) +module Move = Misc.Stdlib.String.Map + + +module Define(D:Diffing.Defs with type eq := unit) = struct + + module Internal_defs = struct + type left = D.left with_pos + type right = D.right with_pos + type diff = (D.left, D.right, D.diff) mismatch + type eq = unit + type state = D.state + end + module Diff = Diffing.Define(Internal_defs) + + type left = Internal_defs.left + type right = Internal_defs.right + type diff = (D.left, D.right, D.diff) mismatch + type composite_change = (D.left,D.right,D.diff) change + type nonrec change = (left, right, unit, diff) Diffing.change + type patch = composite_change list + + module type Parameters = sig + include Diff.Parameters with type update_result := D.state + val key_left: D.left -> string + val key_right: D.right -> string + end + + module Simple(Impl:Parameters) = struct + open Impl + + (** Partial 2-cycles *) + type ('l,'r) partial_cycle = + | Left of int * D.state * 'l + | Right of int * D.state * 'r + | Both of D.state * 'l * 'r + + (** Compute the partial cycle and edge associated to an edge *) + let edge state (x:left) (y:right) = + let kx, ky = key_left x.data, key_right y.data in + let edge = + if kx <= ky then + Left (x.pos, state, (x,y)) + else + Right (x.pos,state, (x,y)) + in + Two_cycle.create kx ky, edge + + let merge_edge ex ey = match ex, ey with + | ex, None -> Some ex + | Left (lpos, lstate, l), Some Right (rpos, rstate,r) + | Right (rpos, rstate,r), Some Left (lpos, lstate, l) -> + let state = if lpos < rpos then rstate else lstate in + Some (Both (state,l,r)) + | Both _ as b, _ | _, Some (Both _ as b) -> Some b + | l, _ -> Some l + + let two_cycles state changes = + let add (state,(swaps,moves)) (d:change) = + update d state, + match d with + | Change (x,y,_) -> + let k, edge = edge state x y in + Swap.update k (merge_edge edge) swaps, moves + | Insert nx -> + let k = key_right nx.data in + let edge = Right (nx.pos, state,nx) in + swaps, Move.update k (merge_edge edge) moves + | Delete nx -> + let k, edge = key_left nx.data, Left (nx.pos, state, nx) in + swaps, Move.update k (merge_edge edge) moves + | _ -> swaps, moves + in + List.fold_left add (state,(Swap.empty,Move.empty)) changes + + (** Check if an edge belongs to a known 2-cycle *) + let swap swaps x y = + let kx, ky = key_left x.data, key_right y.data in + let key = Two_cycle.create kx ky in + match Swap.find_opt key swaps with + | None | Some (Left _ | Right _)-> None + | Some Both (state, (ll,lr),(rl,rr)) -> + match test state ll rr, test state rl lr with + | Ok _, Ok _ -> + Some ({pos=ll.pos; data=kx}, {pos=rl.pos; data=ky}) + | Error _, _ | _, Error _ -> None + + let move moves x = + let name = + match x with + | Either.Left x -> key_left x.data + | Either.Right x -> key_right x.data + in + match Move.find_opt name moves with + | None | Some (Left _ | Right _)-> None + | Some Both (state,got,expected) -> + match test state got expected with + | Ok _ -> + Some (Move {name; got=got.pos; expected=expected.pos}) + | Error _ -> None + + let refine state patch = + let _, (swaps, moves) = two_cycles state patch in + let filter: change -> composite_change option = function + | Keep _ -> None + | Insert x -> + begin match move moves (Either.Right x) with + | Some _ as move -> move + | None -> Some (Insert {pos=x.pos;insert=x.data}) + end + | Delete x -> + begin match move moves (Either.Left x) with + | Some _ -> None + | None -> Some (Delete {pos=x.pos; delete=x.data}) + end + | Change(x,y, reason) -> + match swap swaps x y with + | Some ({pos=pos1; data=first}, {pos=pos2; data=last}) -> + if x.pos = pos1 then + Some (Swap { pos = pos1, pos2; first; last}) + else None + | None -> Some (Change reason) + in + List.filter_map filter patch + + let diff state left right = + let left = with_pos left in + let right = with_pos right in + let module Raw = Diff.Simple(Impl) in + let raw = Raw.diff state (Array.of_list left) (Array.of_list right) in + refine state raw + + end +end diff --git a/ocaml/utils/diffing_with_keys.mli b/ocaml/utils/diffing_with_keys.mli new file mode 100644 index 00000000000..2da82687673 --- /dev/null +++ b/ocaml/utils/diffing_with_keys.mli @@ -0,0 +1,77 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Florian Angeletti, projet Cambium, Inria Paris *) +(* *) +(* Copyright 2021 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** + + When diffing lists where each element has a distinct key, we can refine + the diffing patch by introducing two composite edit moves: swaps and moves. + + [Swap]s exchange the position of two elements. [Swap] cost is set to + [2 * change - epsilon]. + [Move]s change the position of one element. [Move] cost is set to + [delete + addition - epsilon]. + + When the cost [delete + addition] is greater than [change] and with those + specific weights, the optimal patch with [Swap]s and [Move]s can be computed + directly and cheaply from the original optimal patch. + +*) + +type 'a with_pos = {pos: int; data:'a} +val with_pos: 'a list -> 'a with_pos list + +type ('l,'r,'diff) mismatch = + | Name of {pos:int; got:string; expected:string; types_match:bool} + | Type of {pos:int; got:'l; expected:'r; reason:'diff} + +(** This specialized version of changes introduces two composite + changes: [Move] and [Swap] +*) +type ('l,'r,'diff) change = + | Change of ('l,'r,'diff) mismatch + | Swap of { pos: int * int; first: string; last: string } + | Move of {name:string; got:int; expected:int} + | Insert of {pos:int; insert:'r} + | Delete of {pos:int; delete:'l} + +val prefix: Format.formatter -> ('l,'r,'diff) change -> unit + +module Define(D:Diffing.Defs with type eq := unit): sig + + type diff = (D.left, D.right, D.diff) mismatch + type left = D.left with_pos + type right = D.right with_pos + + (** Composite changes and patches *) + type composite_change = (D.left,D.right,D.diff) change + type patch = composite_change list + + (** Atomic changes *) + type change = (left,right,unit,diff) Diffing.change + + module type Parameters = sig + val weight: change -> int + val test: D.state -> left -> right -> (unit, diff) result + val update: change -> D.state -> D.state + + val key_left: D.left -> string + val key_right: D.right -> string + end + + module Simple: Parameters -> sig + val diff: D.state -> D.left list -> D.right list -> patch + end + +end diff --git a/ocaml/utils/dune b/ocaml/utils/dune index 3b9a901233c..2bc72c23ac5 100644 --- a/ocaml/utils/dune +++ b/ocaml/utils/dune @@ -13,37 +13,15 @@ ;************************************************************************** (rule - (targets config.ml) + (targets config.ml domainstate.ml domainstate.mli) (mode fallback) (deps (:mk Makefile) ../Makefile.config ../Makefile.common ../Makefile.config_if_required ../Makefile.build_config - ; for now the utils Makefile does not use build_config + domainstate.ml.c + domainstate.mli.c + ../runtime/caml/domain_state.tbl config.mlp) (action (system "make -sf %{mk} %{targets}"))) - -(rule - (targets domainstate.ml) - (mode fallback) - (deps (:conf ../Makefile.config) - (:c domainstate.ml.c) - (:tbl ../runtime/caml/domain_state.tbl)) - (action - (with-stdout-to %{targets} - (bash - "`grep '^CPP=' %{conf} | cut -d'=' -f2` -I ../runtime/caml %{c}" - )))) - -(rule - (targets domainstate.mli) - (mode fallback) - (deps (:conf ../Makefile.config) - (:c domainstate.mli.c) - (:tbl ../runtime/caml/domain_state.tbl)) - (action - (with-stdout-to %{targets} - (bash - "`grep '^CPP=' %{conf} | cut -d'=' -f2` -I ../runtime/caml %{c}" - )))) diff --git a/ocaml/utils/import_info.ml b/ocaml/utils/import_info.ml new file mode 100644 index 00000000000..3efc610c1fe --- /dev/null +++ b/ocaml/utils/import_info.ml @@ -0,0 +1,66 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, Jane Street UK Partnership LLP *) +(* *) +(* Copyright 2022 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module CU = Compilation_unit + +type t = + | Normal of CU.t * Digest.t + | Normal_no_crc of CU.t + | Other of CU.Name.t * (CU.t * Digest.t) option + +(* CR xclerc: Maybe introduce Other_no_crc to flatten the option *) + +let create cu_name ~crc_with_unit = + match crc_with_unit with + | None -> Other (cu_name, None) + | Some (cu, crc) -> + (* For the moment be conservative and only use the [Normal] constructor when + there is no pack prefix at all. *) + if CU.Prefix.is_empty (CU.for_pack_prefix cu) + && CU.Name.equal (CU.name cu) cu_name + then Normal (cu, crc) + else Other (cu_name, Some (cu, crc)) + +let create_normal cu ~crc = + match crc with Some crc -> Normal (cu, crc) | None -> Normal_no_crc cu + +let name t = + match t with + | Normal (cu, _) | Normal_no_crc cu -> CU.name cu + | Other (name, _) -> name + +let cu t = + match t with + | Normal (cu, _) | Normal_no_crc cu | Other (_, Some (cu, _)) -> cu + | Other (name, None) -> + Misc.fatal_errorf + "Cannot extract [Compilation_unit.t] from [Import_info.t] (for unit %a) \ + that never received it" + CU.Name.print name + +let crc t = + match t with + | Normal (_, crc) -> Some crc + | Normal_no_crc _ | Other (_, None) -> None + | Other (_, Some (_, crc)) -> Some crc + +let crc_with_unit t = + match t with + | Normal (cu, crc) -> Some (cu, crc) + | Normal_no_crc _ | Other (_, None) -> None + | Other (_, some_cu_and_crc) -> some_cu_and_crc + +let has_name t ~name:name' = CU.Name.equal (name t) name' + +let dummy = Other (CU.Name.dummy, None) diff --git a/ocaml/utils/import_info.mli b/ocaml/utils/import_info.mli new file mode 100644 index 00000000000..845e5f086ff --- /dev/null +++ b/ocaml/utils/import_info.mli @@ -0,0 +1,50 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Mark Shinwell, Jane Street UK Partnership LLP *) +(* *) +(* Copyright 2022 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module CU = Compilation_unit + +(* CR mshinwell: maybe there should be a phantom type allowing to distinguish + the .cmx case from the others. Unclear it's worth it. + + xclerc: I also wonder whether it could be useful to have an abstract Array.t + in this module. Indeed the import infos are now mutable; we could hide the + mutability behind an abstract type. I reckon we use only a handful of array + operations on such values, so it should not be too bad. If that happens, it + should probably be in another PR. + + (We could also wait for immutable arrays.) *) + +(* CR mshinwell/xclerc: maybe the reading and writing code should be put in + here, or somewhere alongside, rather than being duplicated around the + tree. *) + +type t + +val create : CU.Name.t -> crc_with_unit:(CU.t * string) option -> t + +val create_normal : CU.t -> crc:string option -> t + +val name : t -> CU.Name.t + +(** This function will cause a fatal error if a [CU.t] was not provided when the + supplied value of type [t] was created. *) +val cu : t -> CU.t + +val crc : t -> string option + +val crc_with_unit : t -> (CU.t * string) option + +val has_name : t -> name:CU.Name.t -> bool + +val dummy : t diff --git a/ocaml/utils/lazy_backtrack.ml b/ocaml/utils/lazy_backtrack.ml new file mode 100644 index 00000000000..13e4eb44001 --- /dev/null +++ b/ocaml/utils/lazy_backtrack.ml @@ -0,0 +1,87 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type ('a,'b) t = ('a,'b) eval ref + +and ('a,'b) eval = + | Done of 'b + | Raise of exn + | Thunk of 'a + +type undo = + | Nil + | Cons : ('a, 'b) t * 'a * undo -> undo + +type log = undo ref + +let force f x = + match !x with + | Done x -> x + | Raise e -> raise e + | Thunk e -> + match f e with + | y -> + x := Done y; + y + | exception e -> + x := Raise e; + raise e + +let get_arg x = + match !x with Thunk a -> Some a | _ -> None + +let get_contents x = + match !x with + | Thunk a -> Either.Left a + | Done b -> Either.Right b + | Raise e -> raise e + +let create x = + ref (Thunk x) + +let create_forced y = + ref (Done y) + +let create_failed e = + ref (Raise e) + +let log () = + ref Nil + +let force_logged log f x = + match !x with + | Done x -> x + | Raise e -> raise e + | Thunk e -> + match f e with + | (Error _ as err : _ result) -> + x := Done err; + log := Cons(x, e, !log); + err + | Ok _ as res -> + x := Done res; + res + | exception e -> + x := Raise e; + raise e + +let backtrack log = + let rec loop = function + | Nil -> () + | Cons(x, e, rest) -> + x := Thunk e; + loop rest + in + loop !log diff --git a/ocaml/utils/lazy_backtrack.mli b/ocaml/utils/lazy_backtrack.mli new file mode 100644 index 00000000000..4e2fbd38080 --- /dev/null +++ b/ocaml/utils/lazy_backtrack.mli @@ -0,0 +1,34 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Fabrice Le Fessant, INRIA Saclay *) +(* *) +(* Copyright 2012 Institut National de Recherche en Informatique et *) +(* en Automatique. *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type ('a,'b) t + +type log + +val force : ('a -> 'b) -> ('a,'b) t -> 'b +val create : 'a -> ('a,'b) t +val get_arg : ('a,'b) t -> 'a option +val get_contents : ('a,'b) t -> ('a,'b) Either.t +val create_forced : 'b -> ('a, 'b) t +val create_failed : exn -> ('a, 'b) t + +(* [force_logged log f t] is equivalent to [force f t] but if [f] + returns [Error _] then [t] is recorded in [log]. [backtrack log] + will then reset all the recorded [t]s back to their original + state. *) +val log : unit -> log +val force_logged : + log -> ('a -> ('b, 'c) result) -> ('a,('b, 'c) result) t -> ('b, 'c) result +val backtrack : log -> unit diff --git a/ocaml/utils/load_path.ml b/ocaml/utils/load_path.ml index 41eb22e9eaf..b1187e993d1 100644 --- a/ocaml/utils/load_path.ml +++ b/ocaml/utils/load_path.ml @@ -14,13 +14,13 @@ open Local_store -module SMap = Misc.Stdlib.String.Map +module STbl = Misc.Stdlib.String.Tbl (* Mapping from basenames to full filenames *) -type registry = string SMap.t ref +type registry = string STbl.t -let files : registry = s_ref SMap.empty -let files_uncap : registry = s_ref SMap.empty +let files : registry ref = s_table STbl.create 42 +let files_uncap : registry ref = s_table STbl.create 42 module Dir = struct type t = { @@ -31,6 +31,22 @@ module Dir = struct let path t = t.path let files t = t.files + let find t fn = + if List.mem fn t.files then + Some (Filename.concat t.path fn) + else + None + + let find_uncap t fn = + let fn = String.uncapitalize_ascii fn in + let search base = + if String.uncapitalize_ascii base = fn then + Some (Filename.concat t.path base) + else + None + in + List.find_map search t.files + (* For backward compatibility reason, simulate the behavior of [Misc.find_in_path]: silently ignore directories that don't exist + treat [""] as the current directory. *) @@ -45,47 +61,42 @@ module Dir = struct end let dirs = s_ref [] +let default_auto_include_callback _ _ = raise Not_found +let auto_include_callback = ref default_auto_include_callback let reset () = assert (not Config.merlin || Local_store.is_bound ()); - files := SMap.empty; - files_uncap := SMap.empty; - dirs := [] + STbl.clear !files; + STbl.clear !files_uncap; + dirs := []; + auto_include_callback := default_auto_include_callback let get () = List.rev !dirs let get_paths () = List.rev_map Dir.path !dirs -let add_to_maps fn basenames files files_uncap = - List.fold_left (fun (files, files_uncap) base -> - let fn = fn base in - SMap.add base fn files, - SMap.add (String.uncapitalize_ascii base) fn files_uncap - ) (files, files_uncap) basenames - (* Optimized version of [add] below, for use in [init] and [remove_dir]: since we are starting from an empty cache, we can avoid checking whether a unit name already exists in the cache simply by adding entries in reverse order. *) -let add dir = - assert (not Config.merlin || Local_store.is_bound ()); - let new_files, new_files_uncap = - add_to_maps (Filename.concat dir.Dir.path) - dir.Dir.files !files !files_uncap - in - files := new_files; - files_uncap := new_files_uncap - -let init l = +let prepend_add dir = + List.iter (fun base -> + let fn = Filename.concat dir.Dir.path base in + STbl.replace !files base fn; + STbl.replace !files_uncap (String.uncapitalize_ascii base) fn + ) dir.Dir.files + +let init ~auto_include l = reset (); dirs := List.rev_map Dir.create l; - List.iter add !dirs + List.iter prepend_add !dirs; + auto_include_callback := auto_include let remove_dir dir = assert (not Config.merlin || Local_store.is_bound ()); let new_dirs = List.filter (fun d -> Dir.path d <> dir) !dirs in if List.compare_lengths new_dirs !dirs <> 0 then begin reset (); - List.iter add new_dirs; + List.iter prepend_add new_dirs; dirs := new_dirs end @@ -94,29 +105,69 @@ let remove_dir dir = order to enforce left-to-right precedence. *) let add dir = assert (not Config.merlin || Local_store.is_bound ()); - let new_files, new_files_uncap = - add_to_maps (Filename.concat dir.Dir.path) dir.Dir.files - SMap.empty SMap.empty - in - let first _ fn _ = Some fn in - files := SMap.union first !files new_files; - files_uncap := SMap.union first !files_uncap new_files_uncap; + List.iter + (fun base -> + let fn = Filename.concat dir.Dir.path base in + if not (STbl.mem !files base) then + STbl.replace !files base fn; + let ubase = String.uncapitalize_ascii base in + if not (STbl.mem !files_uncap ubase) then + STbl.replace !files_uncap ubase fn) + dir.Dir.files; dirs := dir :: !dirs +let append_dir = add + let add_dir dir = add (Dir.create dir) +(* Add the directory at the start of load path - so basenames are + unconditionally added. *) +let prepend_dir dir = + assert (not Config.merlin || Local_store.is_bound ()); + prepend_add dir; + dirs := !dirs @ [dir] + let is_basename fn = Filename.basename fn = fn +let auto_include_libs libs alert find_in_dir fn = + let scan (lib, lazy dir) = + let file = find_in_dir dir fn in + let alert_and_add_dir _ = + alert lib; + append_dir dir + in + Option.iter alert_and_add_dir file; + file + in + match List.find_map scan libs with + | Some base -> base + | None -> raise Not_found + +let auto_include_otherlibs = + (* Ensure directories are only ever scanned once *) + let expand = Misc.expand_directory Config.standard_library in + let otherlibs = + let read_lib lib = lazy (Dir.create (expand ("+" ^ lib))) in + List.map (fun lib -> (lib, read_lib lib)) ["dynlink"; "str"; "unix"] in + auto_include_libs otherlibs + let find fn = assert (not Config.merlin || Local_store.is_bound ()); - if is_basename fn then - SMap.find fn !files - else - Misc.find_in_path (get_paths ()) fn + try + if is_basename fn && not !Sys.interactive then + STbl.find !files fn + else + Misc.find_in_path (get_paths ()) fn + with Not_found -> + !auto_include_callback Dir.find fn let find_uncap fn = assert (not Config.merlin || Local_store.is_bound ()); - if is_basename fn then - SMap.find (String.uncapitalize_ascii fn) !files_uncap - else - Misc.find_in_path_uncap (get_paths ()) fn + try + if is_basename fn && not !Sys.interactive then + STbl.find !files_uncap (String.uncapitalize_ascii fn) + else + Misc.find_in_path_uncap (get_paths ()) fn + with Not_found -> + let fn_uncap = String.uncapitalize_ascii fn in + !auto_include_callback Dir.find_uncap fn_uncap diff --git a/ocaml/utils/load_path.mli b/ocaml/utils/load_path.mli index ea9fe3d3702..312e174c315 100644 --- a/ocaml/utils/load_path.mli +++ b/ocaml/utils/load_path.mli @@ -23,7 +23,7 @@ *) val add_dir : string -> unit -(** Add a directory to the load path *) +(** Add a directory to the end of the load path (i.e. at lowest priority.) *) val remove_dir : string -> unit (** Remove a directory from the load path *) @@ -31,9 +31,37 @@ val remove_dir : string -> unit val reset : unit -> unit (** Remove all directories *) -val init : string list -> unit +module Dir : sig + type t + (** Represent one directory in the load path. *) + + val create : string -> t + + val path : t -> string + + val files : t -> string list + (** All the files in that directory. This doesn't include files in + sub-directories of this directory. *) + + val find : t -> string -> string option + (** [find dir fn] returns the full path to [fn] in [dir]. *) + + val find_uncap : t -> string -> string option + (** As {!find}, but search also for uncapitalized name, i.e. if name is + Foo.ml, either /path/Foo.ml or /path/foo.ml may be returned. *) +end + +val init : + auto_include:((Dir.t -> string -> string option) -> string -> string) -> + string list -> unit (** [init l] is the same as [reset (); List.iter add_dir (List.rev l)] *) +val auto_include_otherlibs : + (string -> unit) -> (Dir.t -> string -> string option) -> string -> string +(** [auto_include_otherlibs alert] is a callback function to be passed to + {!Load_path.init} and automatically adds [-I +lib] to the load path after + calling [alert lib]. *) + val get_paths : unit -> string list (** Return the list of directories passed to [add_dir] so far. *) @@ -47,20 +75,16 @@ val find_uncap : string -> string (** Same as [find], but search also for uncapitalized name, i.e. if name is Foo.ml, allow /path/Foo.ml and /path/foo.ml to match. *) -module Dir : sig - type t - (** Represent one directory in the load path. *) - - val create : string -> t +val[@deprecated] add : Dir.t -> unit +(** Old name for {!append_dir} *) - val path : t -> string - - val files : t -> string list - (** All the files in that directory. This doesn't include files in - sub-directories of this directory. *) -end +val append_dir : Dir.t -> unit +(** [append_dir d] adds [d] to the end of the load path (i.e. at lowest + priority. *) -val add : Dir.t -> unit +val prepend_dir : Dir.t -> unit +(** [prepend_dir d] adds [d] to the start of the load path (i.e. at highest + priority. *) val get : unit -> Dir.t list (** Same as [get_paths ()], except that it returns a [Dir.t list]. *) diff --git a/ocaml/utils/local_store.mli b/ocaml/utils/local_store.mli index f39cd123282..ebd5069393b 100644 --- a/ocaml/utils/local_store.mli +++ b/ocaml/utils/local_store.mli @@ -23,8 +23,8 @@ (** {1 Creators} *) val s_ref : 'a -> 'a ref -(** Similar to {!ref}, except the allocated reference is registered into the - store. *) +(** Similar to {!val:ref}, except the allocated reference is registered into + the store. *) val s_table : ('a -> 'b) -> 'a -> 'b ref (** Used to register hash tables. Those also need to be placed into refs to be @@ -52,7 +52,7 @@ val fresh : unit -> store initialized to those values. *) val with_store : store -> (unit -> 'a) -> 'a -(** [with_scope s f] resets all the registered references to the value they have +(** [with_store s f] resets all the registered references to the value they have in [s] for the run of [f]. If [f] updates any of the registered refs, [s] is updated to remember those changes. *) @@ -62,5 +62,5 @@ val reset : unit -> unit that new instances start with). *) val is_bound : unit -> bool -(** Returns [true] when a scope is active (i.e. when called from the callback - passed to {!with_scope}), [false] otherwise. *) +(** Returns [true] when a store is active (i.e. when called from the callback + passed to {!with_store}), [false] otherwise. *) diff --git a/ocaml/utils/misc.ml b/ocaml/utils/misc.ml index 951c3e515cb..36b7cadd4f1 100644 --- a/ocaml/utils/misc.ml +++ b/ocaml/utils/misc.ml @@ -276,11 +276,38 @@ module Stdlib = struct let n = String.length str in let ridx = String.rindex str split_on in String.sub str 0 ridx, String.sub str (ridx + 1) (n - ridx - 1) + + let starts_with ~prefix s = + let len_s = length s + and len_pre = length prefix in + let rec aux i = + if i = len_pre then true + else if unsafe_get s i <> unsafe_get prefix i then false + else aux (i + 1) + in len_s >= len_pre && aux 0 + + let ends_with ~suffix s = + let len_s = length s + and len_suf = length suffix in + let diff = len_s - len_suf in + let rec aux i = + if i = len_suf then true + else if unsafe_get s (diff + i) <> unsafe_get suffix i then false + else aux (i + 1) + in diff >= 0 && aux 0 + end + + module Int = struct + include Int + let min (a : int) (b : int) = min a b + let max (a : int) (b : int) = max a b end external compare : 'a -> 'a -> int = "%compare" end +module Int = Stdlib.Int + (* File functions *) let find_in_path path name = @@ -368,7 +395,7 @@ let copy_file_chunk ic oc len = let buff = Bytes.create 0x1000 in let rec copy n = if n <= 0 then () else begin - let r = input ic buff 0 (min n 0x1000) in + let r = input ic buff 0 (Int.min n 0x1000) in if r = 0 then raise End_of_file else (output oc buff 0 r; copy(n-r)) end in copy len @@ -551,7 +578,7 @@ module LongString = struct let input_bytes_into tbl ic len = let count = ref len in Array.iter (fun str -> - let chunk = min !count (Bytes.length str) in + let chunk = Int.min !count (Bytes.length str) in really_input ic str 0 chunk; count := !count - chunk) tbl @@ -567,7 +594,7 @@ let edit_distance a b cutoff = let cutoff = (* using max_int for cutoff would cause overflows in (i + cutoff + 1); we bring it back to the (max la lb) worstcase *) - min (max la lb) cutoff in + Int.min (Int.max la lb) cutoff in if abs (la - lb) > cutoff then None else begin (* initialize with 'cutoff + 1' so that not-yet-written-to cases have @@ -582,11 +609,11 @@ let edit_distance a b cutoff = m.(0).(j) <- j; done; for i = 1 to la do - for j = max 1 (i - cutoff - 1) to min lb (i + cutoff + 1) do + for j = Int.max 1 (i - cutoff - 1) to Int.min lb (i + cutoff + 1) do let cost = if a.[i-1] = b.[j-1] then 0 else 1 in let best = (* insert, delete or substitute *) - min (1 + min m.(i-1).(j) m.(i).(j-1)) (m.(i-1).(j-1) + cost) + Int.min (1 + Int.min m.(i-1).(j) m.(i).(j-1)) (m.(i-1).(j-1) + cost) in let best = (* swap two adjacent letters; we use "cost" again in case of @@ -596,7 +623,7 @@ let edit_distance a b cutoff = imitation has its virtues *) if not (i > 1 && j > 1 && a.[i-1] = b.[j-2] && a.[i-2] = b.[j-1]) then best - else min best (m.(i-2).(j-2) + cost) + else Int.min best (m.(i-2).(j-2) + cost) in m.(i).(j) <- best done; @@ -646,6 +673,14 @@ let cut_at s c = let pos = String.index s c in String.sub s 0 pos, String.sub s (pos+1) (String.length s - pos - 1) +let ordinal_suffix n = + let teen = (n mod 100)/10 = 1 in + match n mod 10 with + | 1 when not teen -> "st" + | 2 when not teen -> "nd" + | 3 when not teen -> "rd" + | _ -> "th" + (* Color handling *) module Color = struct (* use ANSI color codes, see https://en.wikipedia.org/wiki/ANSI_escape_code *) @@ -690,6 +725,8 @@ module Color = struct in "\x1b[" ^ s ^ "m" + + type Format.stag += Style of style list type styles = { error: style list; warning: style list; @@ -712,6 +749,7 @@ module Color = struct | Format.String_tag "error" -> (!cur_styles).error | Format.String_tag "warning" -> (!cur_styles).warning | Format.String_tag "loc" -> (!cur_styles).loc + | Style s -> s | _ -> raise Not_found let color_enabled = ref true @@ -825,7 +863,7 @@ let delete_eol_spaces src = let pp_two_columns ?(sep = "|") ?max_lines ppf (lines: (string * string) list) = let left_column_size = - List.fold_left (fun acc (s, _) -> max acc (String.length s)) 0 lines in + List.fold_left (fun acc (s, _) -> Int.max acc (String.length s)) 0 lines in let lines_nb = List.length lines in let ellipsed_first, ellipsed_last = match max_lines with @@ -906,8 +944,6 @@ let print_if ppf flag printer arg = type filepath = string -type modname = string -type crcs = (modname * Digest.t option) list type alerts = string Stdlib.String.Map.t @@ -959,83 +995,6 @@ module Bitmap = struct done end -module EnvLazy = struct - type ('a,'b) t = ('a,'b) eval ref - - and ('a,'b) eval = - | Done of 'b - | Raise of exn - | Thunk of 'a - - type undo = - | Nil - | Cons : ('a, 'b) t * 'a * undo -> undo - - type log = undo ref - - let force f x = - match !x with - | Done x -> x - | Raise e -> raise e - | Thunk e -> - match f e with - | y -> - x := Done y; - y - | exception e -> - x := Raise e; - raise e - - let get_arg x = - match !x with Thunk a -> Some a | _ -> None - - let get_contents x = - match !x with - | Thunk a -> Either.Left a - | Done b -> Either.Right b - | Raise e -> raise e - - let create x = - ref (Thunk x) - - let create_forced y = - ref (Done y) - - let create_failed e = - ref (Raise e) - - let log () = - ref Nil - - let force_logged log f x = - match !x with - | Done x -> x - | Raise e -> raise e - | Thunk e -> - match f e with - | (Error _ as err : _ result) -> - x := Done err; - log := Cons(x, e, !log); - err - | Ok _ as res -> - x := Done res; - res - | exception e -> - x := Raise e; - raise e - - let backtrack log = - let rec loop = function - | Nil -> () - | Cons(x, e, rest) -> - x := Thunk e; - loop rest - in - loop !log - -end - - module Magic_number = struct type native_obj_config = { flambda : bool; @@ -1188,7 +1147,7 @@ module Magic_number = struct (* a header is "truncated" if it starts like a valid magic number, that is if its longest segment of length at most [kind_length] is a prefix of [raw_kind kind] for some kind [kind] *) - let sub_length = min kind_length (String.length s) in + let sub_length = Int.min kind_length (String.length s) in let starts_as kind = String.sub s 0 sub_length = String.sub (raw_kind kind) 0 sub_length in diff --git a/ocaml/utils/misc.mli b/ocaml/utils/misc.mli index 0abb5bba39c..2b2250e381a 100644 --- a/ocaml/utils/misc.mli +++ b/ocaml/utils/misc.mli @@ -156,12 +156,10 @@ module Stdlib : sig module Array : sig val exists2 : ('a -> 'b -> bool) -> 'a array -> 'b array -> bool - (* Same as [Array.exists], but for a two-argument predicate. Raise - Invalid_argument if the two arrays are determined to have - different lengths. *) + (** Same as [Array.exists2] from the standard library. *) val for_alli : (int -> 'a -> bool) -> 'a array -> bool - (** Same as {!Array.for_all}, but the + (** Same as [Array.for_all] from the standard library, but the function is applied with the index of the element as first argument, and the element itself as second argument. *) @@ -186,6 +184,16 @@ module Stdlib : sig (** Splits on the last occurrence of the given character. *) val split_last_exn : string -> split_on:char -> string * string + + val starts_with : prefix:string -> string -> bool + val ends_with : suffix:string -> string -> bool + end + + module Int : sig + include module type of Int + + val min : t -> t -> t + val max : t -> t -> t end external compare : 'a -> 'a -> int = "%compare" @@ -364,6 +372,12 @@ val cut_at : string -> char -> string * string @since 4.01 *) +val ordinal_suffix : int -> string +(** [ordinal_suffix n] is the appropriate suffix to append to the numeral [n] as + an ordinal number: [1] -> ["st"], [2] -> ["nd"], [3] -> ["rd"], + [4] -> ["th"], and so on. Handles larger numbers (e.g., [42] -> ["nd"]) and + the numbers 11--13 (which all get ["th"]) correctly. *) + (* Color handling *) module Color : sig type color = @@ -383,6 +397,8 @@ module Color : sig | Bold | Reset + type Format.stag += Style of style list + val ansi_of_style_l : style list -> string (* ANSI escape sequence for the given style *) @@ -473,11 +489,6 @@ val print_if : type filepath = string -(* CR-someday lmaurer: Retire [modname] in favor of [Compilation_unit.Name.t] - and alter [crcs] accordingly (move it into [Compilation_unit] somewhere?). *) -type modname = string -type crcs = (modname * Digest.t option) list - type alerts = string Stdlib.String.Map.t module Bitmap : sig @@ -489,30 +500,6 @@ module Bitmap : sig val iter : (int -> unit) -> t -> unit end -module EnvLazy: sig - type ('a,'b) t - - type log - - val force : ('a -> 'b) -> ('a,'b) t -> 'b - val create : 'a -> ('a,'b) t - val get_arg : ('a,'b) t -> 'a option - val get_contents : ('a,'b) t -> ('a,'b) Either.t - val create_forced : 'b -> ('a, 'b) t - val create_failed : exn -> ('a, 'b) t - - (* [force_logged log f t] is equivalent to [force f t] but if [f] - returns [Error _] then [t] is recorded in [log]. [backtrack log] - will then reset all the recorded [t]s back to their original - state. *) - val log : unit -> log - val force_logged : - log -> ('a -> ('b, 'c) result) -> ('a,('b, 'c) result) t -> ('b, 'c) result - val backtrack : log -> unit - -end - - module Magic_number : sig (** a typical magic number is "Caml1999I011"; it is formed of an alphanumeric prefix, here Caml1990I, followed by a version, diff --git a/ocaml/utils/profile.ml b/ocaml/utils/profile.ml index fdf397a89fb..44a0648aac3 100644 --- a/ocaml/utils/profile.ml +++ b/ocaml/utils/profile.ml @@ -20,6 +20,8 @@ type file = string external time_include_children: bool -> float = "caml_sys_time_include_children" let cpu_time () = time_include_children true +module Int = Misc.Stdlib.Int + module Measure = struct type t = { time : float; @@ -255,7 +257,7 @@ let rows_of_hierarchy hierarchy measure_diff initial_measure columns timings_pre let max_by_column ~n_columns rows = let a = Array.make n_columns 0. in let rec loop (R (_, values, rows)) = - List.iteri (fun i (v, _) -> a.(i) <- max a.(i) v) values; + List.iteri (fun i (v, _) -> a.(i) <- Float.max a.(i) v) values; List.iter loop rows in List.iter loop rows; @@ -266,7 +268,7 @@ let width_by_column ~n_columns ~display_cell rows = let rec loop (R (_, values, rows)) = List.iteri (fun i cell -> let _, str = display_cell i cell ~width:0 in - a.(i) <- max a.(i) (String.length str) + a.(i) <- Int.max a.(i) (String.length str) ) values; List.iter loop rows; in diff --git a/ocaml/utils/strongly_connected_components.ml b/ocaml/utils/strongly_connected_components.ml index 52d4666cc1e..396138ea87d 100644 --- a/ocaml/utils/strongly_connected_components.ml +++ b/ocaml/utils/strongly_connected_components.ml @@ -187,11 +187,6 @@ module Make (Id : Id) = struct set) dependencies - type numbering = { - back : int Id.Map.t; - forth : Id.t array; - } - let number graph = let size = Id.Map.cardinal graph in let bindings = Id.Map.bindings graph in @@ -218,7 +213,7 @@ module Make (Id : Id) = struct v :: acc) dests []) in - { back; forth }, integer_graph + forth, integer_graph let rec int_list_mem x xs = match xs with @@ -226,7 +221,7 @@ module Make (Id : Id) = struct | x' :: xs -> if Int.equal x x' then true else int_list_mem x xs let component_graph graph = - let numbering, integer_graph = number graph in + let forth, integer_graph = number graph in let { Kosaraju. sorted_connected_components; component_edges } = Kosaraju.component_graph integer_graph @@ -236,11 +231,11 @@ module Make (Id : Id) = struct | [] -> assert false | [node] -> (if int_list_mem node integer_graph.(node) - then Has_loop [numbering.forth.(node)] - else No_loop numbering.forth.(node)), + then Has_loop [forth.(node)] + else No_loop forth.(node)), component_edges.(component) | _::_ -> - (Has_loop (List.map (fun node -> numbering.forth.(node)) nodes)), + (Has_loop (List.map (fun node -> forth.(node)) nodes)), component_edges.(component)) sorted_connected_components diff --git a/ocaml/utils/symbol.ml b/ocaml/utils/symbol.ml index b0f993a5d28..0982015f3de 100644 --- a/ocaml/utils/symbol.ml +++ b/ocaml/utils/symbol.ml @@ -61,8 +61,6 @@ let linkage_name_for_ocamlobjinfo t = let compilation_unit t = t.compilation_unit -let with_compilation_unit t compilation_unit = { t with compilation_unit } - (* CR-someday lmaurer: Would be nicer to have some of this logic in [Linkage_name]; among other things, we could then define [Linkage_name.for_current_unit] *) @@ -81,26 +79,15 @@ let linkage_name_for_compilation_unit comp_unit = caml_symbol_prefix ^ suffix |> Linkage_name.of_string -let for_global_or_predef_ident pack_prefix id = - assert (Ident.is_global_or_predef id); - let linkage_name, compilation_unit = - if Ident.is_predef id then - "caml_exn_" ^ Ident.name id |> Linkage_name.of_string, CU.predef_exn - else - let compilation_unit = - Compilation_unit.create pack_prefix - (Ident.name id |> Compilation_unit.Name.of_string) - in - linkage_name_for_compilation_unit compilation_unit, compilation_unit - in +let for_predef_ident id = + assert (Ident.is_predef id); + let linkage_name = "caml_exn_" ^ Ident.name id |> Linkage_name.of_string in + let compilation_unit = CU.predef_exn in { compilation_unit; linkage_name; hash = Hashtbl.hash linkage_name; } -let for_predef_ident id = - for_global_or_predef_ident Compilation_unit.Prefix.empty id - let unsafe_create compilation_unit linkage_name = { compilation_unit; linkage_name; @@ -132,10 +119,6 @@ let for_compilation_unit compilation_unit = let for_current_unit () = for_compilation_unit (CU.get_current_exn ()) -let import_for_pack t ~pack = - let compilation_unit = CU.with_for_pack_prefix t.compilation_unit pack in - { t with compilation_unit; } - let const_label = ref 0 let for_new_const_in_current_unit () = diff --git a/ocaml/utils/symbol.mli b/ocaml/utils/symbol.mli index a5d4a7e97be..6c32609cba4 100644 --- a/ocaml/utils/symbol.mli +++ b/ocaml/utils/symbol.mli @@ -20,12 +20,9 @@ type t +(* For predefined exception identifiers. *) val for_predef_ident : Ident.t -> t -(* CR mshinwell: Insist on -for-pack for .mli files; then this function - will not need to take a pack prefix. *) -val for_global_or_predef_ident : Compilation_unit.Prefix.t -> Ident.t -> t - (** It is assumed that the provided [Ident.t] is in the current unit. *) val for_local_ident : Ident.t -> t @@ -38,12 +35,8 @@ val for_compilation_unit : Compilation_unit.t -> t val for_current_unit : unit -> t val for_new_const_in_current_unit : unit -> t -val import_for_pack : t -> pack:Compilation_unit.Prefix.t -> t - val compilation_unit : t -> Compilation_unit.t -val with_compilation_unit : t -> Compilation_unit.t -> t - val linkage_name : t -> Linkage_name.t (** Linkage names displayed in ocamlobjinfo are formatted differently. *) diff --git a/ocaml/utils/warnings.ml b/ocaml/utils/warnings.ml index df2bb30578e..99291a43253 100644 --- a/ocaml/utils/warnings.ml +++ b/ocaml/utils/warnings.ml @@ -24,6 +24,16 @@ type loc = { loc_ghost: bool; } +type field_usage_warning = + | Unused + | Not_read + | Not_mutated + +type constructor_usage_warning = + | Unused + | Not_constructed + | Only_exported_private + type t = | Comment_start (* 1 *) | Comment_not_end (* 2 *) @@ -61,8 +71,8 @@ type t = | Unused_type_declaration of string (* 34 *) | Unused_for_index of string (* 35 *) | Unused_ancestor of string (* 36 *) - | Unused_constructor of string * bool * bool (* 37 *) - | Unused_extension of string * bool * bool * bool (* 38 *) + | Unused_constructor of string * constructor_usage_warning (* 37 *) + | Unused_extension of string * bool * constructor_usage_warning (* 38 *) | Unused_rec_flag (* 39 *) | Name_out_of_scope of string * string list * bool (* 40 *) | Ambiguous_name of string list * string list * bool * string (* 41 *) @@ -93,6 +103,10 @@ type t = | Unused_open_bang of string (* 66 *) | Unused_functor_parameter of string (* 67 *) | Match_on_mutable_state_prevent_uncurry (* 68 *) + | Unused_field of string * field_usage_warning (* 69 *) + | Missing_mli (* 70 *) + | Unused_tmc_attribute (* 71 *) + | Tmc_breaks_tailcall (* 72 *) ;; (* If you remove a warning, leave a hole in the numbering. NEVER change @@ -171,174 +185,274 @@ let number = function | Unused_open_bang _ -> 66 | Unused_functor_parameter _ -> 67 | Match_on_mutable_state_prevent_uncurry -> 68 + | Unused_field _ -> 69 + | Missing_mli -> 70 + | Unused_tmc_attribute -> 71 + | Tmc_breaks_tailcall -> 72 ;; -let last_warning_number = 68 +let last_warning_number = 72 ;; -(* Third component of each tuple is the list of names for each warning. The - first element of the list is the current name, any following ones are - deprecated. The current name should always be derived mechanically from the - constructor name. *) - -let descriptions = - [ - 1, "Suspicious-looking start-of-comment mark.", - ["comment-start"]; - 2, "Suspicious-looking end-of-comment mark.", - ["comment-not-end"]; - 3, "Deprecated synonym for the 'deprecated' alert.", - []; - 4, "Fragile pattern matching: matching that will remain complete even\n\ - \ if additional constructors are added to one of the variant types\n\ - \ matched.", - ["fragile-match"]; - 5, "Partially applied function: expression whose result has function\n\ - \ type and is ignored.", - ["ignored-partial-application"]; - 6, "Label omitted in function application.", - ["labels-omitted"]; - 7, "Method overridden.", - ["method-override"]; - 8, "Partial match: missing cases in pattern-matching.", - ["partial-match"]; - 9, "Missing fields in a record pattern.", - ["missing-record-field-pattern"]; - 10, - "Expression on the left-hand side of a sequence that doesn't have type\n\ - \ \"unit\" (and that is not a function, see warning number 5).", - ["non-unit-statement"]; - 11, "Redundant case in a pattern matching (unused match case).", - ["redundant-case"]; - 12, "Redundant sub-pattern in a pattern-matching.", - ["redundant-subpat"]; - 13, "Instance variable overridden.", - ["instance-variable-override"]; - 14, "Illegal backslash escape in a string constant.", - ["illegal-backslash"]; - 15, "Private method made public implicitly.", - ["implicit-public-methods"]; - 16, "Unerasable optional argument.", - ["unerasable-optional-argument"]; - 17, "Undeclared virtual method.", - ["undeclared-virtual-method"]; - 18, "Non-principal type.", - ["not-principal"]; - 19, "Type without principality.", - ["non-principal-labels"]; - 20, "Unused function argument.", - ["ignored-extra-argument"]; - 21, "Non-returning statement.", - ["nonreturning-statement"]; - 22, "Preprocessor warning.", - ["preprocessor"]; - 23, "Useless record \"with\" clause.", - ["useless-record-with"]; - 24, - "Bad module name: the source file name is not a valid OCaml module name.", - ["bad-module-name"]; - 25, "Ignored: now part of warning 8.", - []; - 26, +type description = + { number : int; + names : string list; + (* The first element of the list is the current name, any following ones are + deprecated. The current name should always be derived mechanically from + the constructor name. *) + description : string; } + +let descriptions = [ + { number = 1; + names = ["comment-start"]; + description = "Suspicious-looking start-of-comment mark." }; + { number = 2; + names = ["comment-not-end"]; + description = "Suspicious-looking end-of-comment mark." }; + { number = 3; + names = []; + description = "Deprecated synonym for the 'deprecated' alert." }; + { number = 4; + names = ["fragile-match"]; + description = + "Fragile pattern matching: matching that will remain complete even\n\ + \ if additional constructors are added to one of the variant types\n\ + \ matched." }; + { number = 5; + names = ["ignored-partial-application"]; + description = + "Partially applied function: expression whose result has function\n\ + \ type and is ignored." }; + { number = 6; + names = ["labels-omitted"]; + description = "Label omitted in function application." }; + { number = 7; + names = ["method-override"]; + description = "Method overridden." }; + { number = 8; + names = ["partial-match"]; + description = "Partial match: missing cases in pattern-matching." }; + { number = 9; + names = ["missing-record-field-pattern"]; + description = "Missing fields in a record pattern." }; + { number = 10; + names = ["non-unit-statement"]; + description = + "Expression on the left-hand side of a sequence that doesn't have type\n\ + \ \"unit\" (and that is not a function, see warning number 5)." }; + { number = 11; + names = ["redundant-case"]; + description = + "Redundant case in a pattern matching (unused match case)." }; + { number = 12; + names = ["redundant-subpat"]; + description = "Redundant sub-pattern in a pattern-matching." }; + { number = 13; + names = ["instance-variable-override"]; + description = "Instance variable overridden." }; + { number = 14; + names = ["illegal-backslash"]; + description = "Illegal backslash escape in a string constant." }; + { number = 15; + names = ["implicit-public-methods"]; + description = "Private method made public implicitly." }; + { number = 16; + names = ["unerasable-optional-argument"]; + description = "Unerasable optional argument." }; + { number = 17; + names = ["undeclared-virtual-method"]; + description = "Undeclared virtual method." }; + { number = 18; + names = ["not-principal"]; + description = "Non-principal type." }; + { number = 19; + names = ["non-principal-labels"]; + description = "Type without principality." }; + { number = 20; + names = ["ignored-extra-argument"]; + description = "Unused function argument." }; + { number = 21; + names = ["nonreturning-statement"]; + description = "Non-returning statement." }; + { number = 22; + names = ["preprocessor"]; + description = "Preprocessor warning." }; + { number = 23; + names = ["useless-record-with"]; + description = "Useless record \"with\" clause." }; + { number = 24; + names = ["bad-module-name"]; + description = + "Bad module name: the source file name is not a valid OCaml module name."}; + { number = 25; + names = []; + description = "Ignored: now part of warning 8." }; + { number = 26; + names = ["unused-var"]; + description = "Suspicious unused variable: unused variable that is bound\n\ \ with \"let\" or \"as\", and doesn't start with an underscore (\"_\")\n\ - \ character.", - ["unused-var"]; - 27, "Innocuous unused variable: unused variable that is not bound with\n\ - \ \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\ - \ character.", - ["unused-var-strict"]; - 28, "Wildcard pattern given as argument to a constant constructor.", - ["wildcard-arg-to-constant-constr"]; - 29, "Unescaped end-of-line in a string constant (non-portable code).", - ["eol-in-string"]; - 30, "Two labels or constructors of the same name are defined in two\n\ - \ mutually recursive types.", - ["duplicate-definitions"]; - 31, "A module is linked twice in the same executable.", - ["module-linked-twice"]; - 32, "Unused value declaration.", - ["unused-value-declaration"]; - 33, "Unused open statement.", - ["unused-open"]; - 34, "Unused type declaration.", - ["unused-type-declaration"]; - 35, "Unused for-loop index.", - ["unused-for-index"]; - 36, "Unused ancestor variable.", - ["unused-ancestor"]; - 37, "Unused constructor.", - ["unused-constructor"]; - 38, "Unused extension constructor.", - ["unused-extension"]; - 39, "Unused rec flag.", - ["unused-rec-flag"]; - 40, "Constructor or label name used out of scope.", - ["name-out-of-scope"]; - 41, "Ambiguous constructor or label name.", - ["ambiguous-name"]; - 42, "Disambiguated constructor or label name (compatibility warning).", - ["disambiguated-name"]; - 43, "Nonoptional label applied as optional.", - ["nonoptional-label"]; - 44, "Open statement shadows an already defined identifier.", - ["open-shadow-identifier"]; - 45, "Open statement shadows an already defined label or constructor.", - ["open-shadow-label-constructor"]; - 46, "Error in environment variable.", - ["bad-env-variable"]; - 47, "Illegal attribute payload.", - ["attribute-payload"]; - 48, "Implicit elimination of optional arguments.", - ["eliminated-optional-arguments"]; - 49, "Absent cmi file when looking up module alias.", - ["no-cmi-file"]; - 50, "Unexpected documentation comment.", - ["unexpected-docstring"]; - 51, "Function call annotated with an incorrect @tailcall attribute", - ["wrong-tailcall-expectation"]; - 52, "Fragile constant pattern.", - ["fragile-literal-pattern"]; - 53, "Attribute cannot appear in this context.", - ["misplaced-attribute"]; - 54, "Attribute used more than once on an expression.", - ["duplicated-attribute"]; - 55, "Inlining impossible.", - ["inlining-impossible"]; - 56, "Unreachable case in a pattern-matching (based on type information).", - ["unreachable-case"]; - 57, "Ambiguous or-pattern variables under guard.", - ["ambiguous-var-in-pattern-guard"]; - 58, "Missing cmx file.", - ["no-cmx-file"]; - 59, "Assignment to non-mutable value.", - ["flambda-assignment-to-non-mutable-value"]; - 60, "Unused module declaration.", - ["unused-module"]; - 61, "Unboxable type in primitive declaration.", - ["unboxable-type-in-prim-decl"]; - 62, "Type constraint on GADT type declaration.", - ["constraint-on-gadt"]; - 63, "Erroneous printed signature.", - ["erroneous-printed-signature"]; - 64, "-unsafe used with a preprocessor returning a syntax tree.", - ["unsafe-array-syntax-without-parsing"]; - 65, "Type declaration defining a new '()' constructor.", - ["redefining-unit"]; - 66, "Unused open! statement.", - ["unused-open-bang"]; - 67, "Unused functor parameter.", - ["unused-functor-parameter"]; - 68, "Pattern-matching depending on mutable state prevents the remaining \ - arguments from being uncurried.", - ["match-on-mutable-state-prevent-uncurry"]; - ] + \ character." }; + { number = 27; + names = ["unused-var-strict"]; + description = + "Innocuous unused variable: unused variable that is not bound with\n\ + \ \"let\" nor \"as\", and doesn't start with an underscore (\"_\")\n\ + \ character." }; + { number = 28; + names = ["wildcard-arg-to-constant-constr"]; + description = + "Wildcard pattern given as argument to a constant constructor." }; + { number = 29; + names = ["eol-in-string"]; + description = + "Unescaped end-of-line in a string constant (non-portable code)." }; + { number = 30; + names = ["duplicate-definitions"]; + description = + "Two labels or constructors of the same name are defined in two\n\ + \ mutually recursive types." }; + { number = 31; + names = ["module-linked-twice"]; + description = "A module is linked twice in the same executable." }; + { number = 32; + names = ["unused-value-declaration"]; + description = "Unused value declaration." }; + { number = 33; + names = ["unused-open"]; + description = "Unused open statement." }; + { number = 34; + names = ["unused-type-declaration"]; + description = "Unused type declaration." }; + { number = 35; + names = ["unused-for-index"]; + description = "Unused for-loop index." }; + { number = 36; + names = ["unused-ancestor"]; + description = "Unused ancestor variable." }; + { number = 37; + names = ["unused-constructor"]; + description = "Unused constructor." }; + { number = 38; + names = ["unused-extension"]; + description = "Unused extension constructor." }; + { number = 39; + names = ["unused-rec-flag"]; + description = "Unused rec flag." }; + { number = 40; + names = ["name-out-of-scope"]; + description = "Constructor or label name used out of scope." }; + { number = 41; + names = ["ambiguous-name"]; + description = "Ambiguous constructor or label name." }; + { number = 42; + names = ["disambiguated-name"]; + description = + "Disambiguated constructor or label name (compatibility warning)." }; + { number = 43; + names = ["nonoptional-label"]; + description = "Nonoptional label applied as optional." }; + { number = 44; + names = ["open-shadow-identifier"]; + description = "Open statement shadows an already defined identifier." }; + { number = 45; + names = ["open-shadow-label-constructor"]; + description = + "Open statement shadows an already defined label or constructor." }; + { number = 46; + names = ["bad-env-variable"]; + description = "Error in environment variable." }; + { number = 47; + names = ["attribute-payload"]; + description = "Illegal attribute payload." }; + { number = 48; + names = ["eliminated-optional-arguments"]; + description = "Implicit elimination of optional arguments." }; + { number = 49; + names = ["no-cmi-file"]; + description = "Absent cmi file when looking up module alias." }; + { number = 50; + names = ["unexpected-docstring"]; + description = "Unexpected documentation comment." }; + { number = 51; + names = ["wrong-tailcall-expectation"]; + description = + "Function call annotated with an incorrect @tailcall attribute" }; + { number = 52; + names = ["fragile-literal-pattern"]; + description = "Fragile constant pattern." }; + { number = 53; + names = ["misplaced-attribute"]; + description = "Attribute cannot appear in this context." }; + { number = 54; + names = ["duplicated-attribute"]; + description = "Attribute used more than once on an expression." }; + { number = 55; + names = ["inlining-impossible"]; + description = "Inlining impossible." }; + { number = 56; + names = ["unreachable-case"]; + description = + "Unreachable case in a pattern-matching (based on type information)." }; + { number = 57; + names = ["ambiguous-var-in-pattern-guard"]; + description = "Ambiguous or-pattern variables under guard." }; + { number = 58; + names = ["no-cmx-file"]; + description = "Missing cmx file." }; + { number = 59; + names = ["flambda-assignment-to-non-mutable-value"]; + description = "Assignment to non-mutable value." }; + { number = 60; + names = ["unused-module"]; + description = "Unused module declaration." }; + { number = 61; + names = ["unboxable-type-in-prim-decl"]; + description = "Unboxable type in primitive declaration." }; + { number = 62; + names = ["constraint-on-gadt"]; + description = "Type constraint on GADT type declaration." }; + { number = 63; + names = ["erroneous-printed-signature"]; + description = "Erroneous printed signature." }; + { number = 64; + names = ["unsafe-array-syntax-without-parsing"]; + description = + "-unsafe used with a preprocessor returning a syntax tree." }; + { number = 65; + names = ["redefining-unit"]; + description = "Type declaration defining a new '()' constructor." }; + { number = 66; + names = ["unused-open-bang"]; + description = "Unused open! statement." }; + { number = 67; + names = ["unused-functor-parameter"]; + description = "Unused functor parameter." }; + { number = 68; + names = ["match-on-mutable-state-prevent-uncurry"]; + description = + "Pattern-matching depending on mutable state prevents the remaining \n\ + \ arguments from being uncurried." }; + { number = 69; + names = ["unused-field"]; + description = "Unused record field." }; + { number = 70; + names = ["missing-mli"]; + description = "Missing interface file." }; + { number = 71; + names = ["unused-tmc-attribute"]; + description = "Unused @tail_mod_cons attribute" }; + { number = 72; + names = ["tmc-breaks-tailcall"]; + description = "A tail call is turned into a non-tail call \ + by the @tail_mod_cons transformation." }; +] ;; let name_to_number = let h = Hashtbl.create last_warning_number in - List.iter (fun (num, _, names) -> - List.iter (fun name -> Hashtbl.add h name num) names + List.iter (fun {number; names; _} -> + List.iter (fun name -> Hashtbl.add h name number) names ) descriptions; fun s -> Hashtbl.find_opt h s ;; @@ -419,20 +533,20 @@ let alert_is_error {kind; _} = let (set, pos) = (!current).alert_errors in Misc.Stdlib.String.Set.mem kind set = pos +let with_state state f = + let prev = backup () in + restore state; + try + let r = f () in + restore prev; + r + with exn -> + restore prev; + raise exn + let mk_lazy f = let state = backup () in - lazy - ( - let prev = backup () in - restore state; - try - let r = f () in - restore prev; - r - with exn -> - restore prev; - raise exn - ) + lazy (with_state state f) let set_alert ~error ~enable s = let upd = @@ -487,26 +601,90 @@ let parse_alert_option s = in scan 0 -let parse_opt error active errflag s = - let flags = if errflag then error else active in - let set i = - if i = 3 then set_alert ~error:errflag ~enable:true "deprecated" - else flags.(i) <- true +type modifier = + | Set (** +a *) + | Clear (** -a *) + | Set_all (** @a *) + +type token = + | Letter of char * modifier option + | Num of int * int * modifier + +let ghost_loc_in_file name = + let pos = { Lexing.dummy_pos with pos_fname = name } in + { loc_start = pos; loc_end = pos; loc_ghost = true } + +let letter_alert tokens = + let print_warning_char ppf c = + let lowercase = Char.lowercase_ascii c = c in + Format.fprintf ppf "%c%c" + (if lowercase then '-' else '+') c in - let clear i = - if i = 3 then set_alert ~error:errflag ~enable:false "deprecated" - else flags.(i) <- false + let print_modifier ppf = function + | Set_all -> Format.fprintf ppf "@" + | Clear -> Format.fprintf ppf "-" + | Set -> Format.fprintf ppf "+" + in + let print_token ppf = function + | Num (a,b,m) -> if a = b then + Format.fprintf ppf "%a%d" print_modifier m a + else + Format.fprintf ppf "%a%d..%d" print_modifier m a b + | Letter(l,Some m) -> Format.fprintf ppf "%a%c" print_modifier m l + | Letter(l,None) -> print_warning_char ppf l in - let set_all i = - if i = 3 then begin - set_alert ~error:false ~enable:true "deprecated"; - set_alert ~error:true ~enable:true "deprecated" - end - else begin - active.(i) <- true; - error.(i) <- true - end + let consecutive_letters = + (* we are tracking sequences of 2 or more consecutive unsigned letters + in warning strings, for instance in '-w "not-principa"'. *) + let commit_chunk l = function + | [] | [ _ ] -> l + | _ :: _ :: _ as chunk -> List.rev chunk :: l + in + let group_consecutive_letters (l,current) = function + | Letter (x, None) -> (l, x::current) + | _ -> (commit_chunk l current, []) + in + let l, on_going = + List.fold_left group_consecutive_letters ([],[]) tokens + in + commit_chunk l on_going in + match consecutive_letters with + | [] -> None + | example :: _ -> + let nowhere = ghost_loc_in_file "_none_" in + let spelling_hint ppf = + let max_seq_len = + List.fold_left (fun l x -> Misc.Stdlib.Int.max l (List.length x)) + 0 consecutive_letters + in + if max_seq_len >= 5 then + Format.fprintf ppf + "@ @[Hint: Did you make a spelling mistake \ + when using a mnemonic name?@]" + else + () + in + let message = + Format.asprintf + "@[@[Setting a warning with a sequence of lowercase \ + or uppercase letters,@ like '%a',@ is deprecated.@]@ \ + @[Use the equivalent signed form:@ %t.@]@ \ + @[Hint: Enabling or disabling a warning by its mnemonic name \ + requires a + or - prefix.@]\ + %t@?@]" + Format.(pp_print_list ~pp_sep:(fun _ -> ignore) pp_print_char) example + (fun ppf -> List.iter (print_token ppf) tokens) + spelling_hint + in + Some { + kind="ocaml_deprecated_cli"; + use=nowhere; def=nowhere; + message + } + + +let parse_warnings s = let error () = raise (Arg.Bad "Ill-formed list of warnings") in let rec get_num n i = if i >= String.length s then i, n @@ -523,65 +701,94 @@ let parse_opt error active errflag s = else i, n1, n1 in - let rec loop i = - if i >= String.length s then () else + let rec loop tokens i = + if i >= String.length s then List.rev tokens else match s.[i] with - | 'A' .. 'Z' -> - List.iter set (letter (Char.lowercase_ascii s.[i])); - loop (i+1) - | 'a' .. 'z' -> - List.iter clear (letter s.[i]); - loop (i+1) - | '+' -> loop_letter_num set (i+1) - | '-' -> loop_letter_num clear (i+1) - | '@' -> loop_letter_num set_all (i+1) + | 'A' .. 'Z' | 'a' .. 'z' -> + loop (Letter(s.[i],None)::tokens) (i+1) + | '+' -> loop_letter_num tokens Set (i+1) + | '-' -> loop_letter_num tokens Clear (i+1) + | '@' -> loop_letter_num tokens Set_all (i+1) | _ -> error () - and loop_letter_num myset i = + and loop_letter_num tokens modifier i = if i >= String.length s then error () else match s.[i] with | '0' .. '9' -> let i, n1, n2 = get_range i in - for n = n1 to min n2 last_warning_number do myset n done; - loop i - | 'A' .. 'Z' -> - List.iter myset (letter (Char.lowercase_ascii s.[i])); - loop (i+1) - | 'a' .. 'z' -> - List.iter myset (letter s.[i]); - loop (i+1) + loop (Num(n1,n2,modifier)::tokens) i + | 'A' .. 'Z' | 'a' .. 'z' -> + loop (Letter(s.[i],Some modifier)::tokens) (i+1) | _ -> error () in - match name_to_number s with - | Some n -> set n + loop [] 0 + +let parse_opt error active errflag s = + let flags = if errflag then error else active in + let action modifier i = match modifier with + | Set -> + if i = 3 then set_alert ~error:errflag ~enable:true "deprecated" + else flags.(i) <- true + | Clear -> + if i = 3 then set_alert ~error:errflag ~enable:false "deprecated" + else flags.(i) <- false + | Set_all -> + if i = 3 then begin + set_alert ~error:false ~enable:true "deprecated"; + set_alert ~error:true ~enable:true "deprecated" + end + else begin + active.(i) <- true; + error.(i) <- true + end + in + let eval = function + | Letter(c, m) -> + let lc = Char.lowercase_ascii c in + let modifier = match m with + | None -> if c = lc then Clear else Set + | Some m -> m + in + List.iter (action modifier) (letter lc) + | Num(n1,n2,modifier) -> + for n = n1 to Misc.Stdlib.Int.min n2 last_warning_number do action modifier n done + in + let parse_and_eval s = + let tokens = parse_warnings s in + List.iter eval tokens; + letter_alert tokens + in + match name_to_number s with + | Some n -> action Set n; None | None -> - if s = "" then loop 0 + if s = "" then parse_and_eval s else begin let rest = String.sub s 1 (String.length s - 1) in match s.[0], name_to_number rest with - | '+', Some n -> set n - | '-', Some n -> clear n - | '@', Some n -> set_all n - | _ -> loop 0 + | '+', Some n -> action Set n; None + | '-', Some n -> action Clear n; None + | '@', Some n -> action Set_all n; None + | _ -> parse_and_eval s end ;; let parse_options errflag s = let error = Array.copy (!current).error in let active = Array.copy (!current).active in - parse_opt error active errflag s; - current := {(!current) with error; active} + let alerts = parse_opt error active errflag s in + current := {(!current) with error; active}; + alerts (* If you change these, don't forget to change them in man/ocamlc.m *) -let defaults_w = "+a-4-6-7-9-27-29-30-32..42-44-45-48-50-60-66-67-68";; +let defaults_w = "+a-4-7-9-27-29-30-32..42-44-45-48-50-60-66..70";; let defaults_warn_error = "-a+31";; -let () = parse_options false defaults_w;; -let () = parse_options true defaults_warn_error;; +let () = ignore @@ parse_options false defaults_w;; +let () = ignore @@ parse_options true defaults_warn_error;; let ref_manual_explanation () = (* manual references are checked a posteriori by the manual cross-reference consistency check in manual/tests*) - let[@manual.ref "s:comp-warnings"] chapter, section = 9, 5 in + let[@manual.ref "s:comp-warnings"] chapter, section = 11, 5 in Printf.sprintf "(See manual section %d.%d)" chapter section let message = function @@ -622,13 +829,11 @@ let message = function | Redundant_case -> "this match case is unused." | Redundant_subpat -> "this sub-pattern is unused." | Instance_variable_override [lab] -> - "the instance variable " ^ lab ^ " is overridden.\n" ^ - "The behaviour changed in ocaml 3.10 (previous behaviour was hiding.)" + "the instance variable " ^ lab ^ " is overridden." | Instance_variable_override (cname :: slist) -> String.concat " " ("the following instance variables are overridden by the class" - :: cname :: ":\n " :: slist) ^ - "\nThe behaviour changed in ocaml 3.10 (previous behaviour was hiding.)" + :: cname :: ":\n " :: slist) | Instance_variable_override [] -> assert false | Illegal_backslash -> "illegal backslash escape in string." | Implicit_public_methods l -> @@ -668,26 +873,26 @@ let message = function | Unused_type_declaration s -> "unused type " ^ s ^ "." | Unused_for_index s -> "unused for-loop index " ^ s ^ "." | Unused_ancestor s -> "unused ancestor variable " ^ s ^ "." - | Unused_constructor (s, false, false) -> "unused constructor " ^ s ^ "." - | Unused_constructor (s, true, _) -> + | Unused_constructor (s, Unused) -> "unused constructor " ^ s ^ "." + | Unused_constructor (s, Not_constructed) -> "constructor " ^ s ^ " is never used to build values.\n\ (However, this constructor appears in patterns.)" - | Unused_constructor (s, false, true) -> + | Unused_constructor (s, Only_exported_private) -> "constructor " ^ s ^ " is never used to build values.\n\ Its type is exported as a private type." - | Unused_extension (s, is_exception, cu_pattern, cu_privatize) -> + | Unused_extension (s, is_exception, complaint) -> let kind = if is_exception then "exception" else "extension constructor" in let name = kind ^ " " ^ s in - begin match cu_pattern, cu_privatize with - | false, false -> "unused " ^ name - | true, _ -> + begin match complaint with + | Unused -> "unused " ^ name + | Not_constructed -> name ^ " is never used to build values.\n\ (However, this constructor appears in patterns.)" - | false, true -> + | Only_exported_private -> name ^ " is never used to build values.\n\ It is exported or rebound as a private extension." @@ -764,17 +969,24 @@ let message = function | Inlining_impossible reason -> Printf.sprintf "Cannot inline: %s" reason | Ambiguous_var_in_pattern_guard vars -> - let msg = - let vars = List.sort String.compare vars in + let vars = List.sort String.compare vars in + let vars_explanation = + let in_different_places = + "in different places in different or-pattern alternatives" + in match vars with | [] -> assert false - | [x] -> "variable " ^ x + | [x] -> "variable " ^ x ^ " appears " ^ in_different_places | _::_ -> - "variables " ^ String.concat "," vars in + let vars = String.concat ", " vars in + "variables " ^ vars ^ " appear " ^ in_different_places + in Printf.sprintf "Ambiguous or-pattern variables under guard;\n\ - %s may match different arguments. %t" - msg ref_manual_explanation + %s.\n\ + Only the first match will be used to evaluate the guard expression.\n\ + %t" + vars_explanation ref_manual_explanation | No_cmx_file name -> Printf.sprintf "no cmx file was found in path for module %s, \ @@ -815,6 +1027,27 @@ let message = function "This pattern depends on mutable state.\n\ It prevents the remaining arguments from being uncurried, which will \ cause additional closure allocations." + | Unused_field (s, Unused) -> "unused record field " ^ s ^ "." + | Unused_field (s, Not_read) -> + "record field " ^ s ^ + " is never read.\n\ + (However, this field is used to build or mutate values.)" + | Unused_field (s, Not_mutated) -> + "mutable record field " ^ s ^ + " is never mutated." + | Missing_mli -> + "Cannot find interface file." + | Unused_tmc_attribute -> + "This function is marked @tail_mod_cons\n\ + but is never applied in TMC position." + | Tmc_breaks_tailcall -> + "This call\n\ + is in tail-modulo-cons positionin a TMC function,\n\ + but the function called is not itself specialized for TMC,\n\ + so the call will not be transformed into a tail call.\n\ + Please either mark the called function with the [@tail_mod_cons]\n\ + attribute, or mark this call with the [@tailcall false] attribute\n\ + to make its non-tailness explicit." ;; let nerrors = ref 0;; @@ -828,8 +1061,8 @@ type reporting_information = let id_name w = let n = number w in - match List.find_opt (fun (m, _, _) -> m = n) descriptions with - | Some (_, _, s :: _) -> + match List.find_opt (fun {number; _} -> number = n) descriptions with + | Some {names = s :: _; _} -> Printf.sprintf "%d [%s]" n s | _ -> string_of_int n @@ -890,13 +1123,13 @@ let check_fatal () = let help_warnings () = List.iter - (fun (i, s, names) -> + (fun {number; description; names} -> let name = match names with | s :: _ -> " [" ^ s ^ "]" | [] -> "" in - Printf.printf "%3i%s %s\n" i name s) + Printf.printf "%3i%s %s\n" number name description) descriptions; print_endline " A all warnings"; for i = Char.code 'b' to Char.code 'z' do diff --git a/ocaml/utils/warnings.mli b/ocaml/utils/warnings.mli index c94ea72f678..acfd4d27556 100644 --- a/ocaml/utils/warnings.mli +++ b/ocaml/utils/warnings.mli @@ -26,6 +26,19 @@ type loc = { loc_ghost: bool; } +val ghost_loc_in_file : string -> loc +(** Return an empty ghost range located in a given file *) + +type field_usage_warning = + | Unused + | Not_read + | Not_mutated + +type constructor_usage_warning = + | Unused + | Not_constructed + | Only_exported_private + type t = | Comment_start (* 1 *) | Comment_not_end (* 2 *) @@ -63,8 +76,8 @@ type t = | Unused_type_declaration of string (* 34 *) | Unused_for_index of string (* 35 *) | Unused_ancestor of string (* 36 *) - | Unused_constructor of string * bool * bool (* 37 *) - | Unused_extension of string * bool * bool * bool (* 38 *) + | Unused_constructor of string * constructor_usage_warning (* 37 *) + | Unused_extension of string * bool * constructor_usage_warning (* 38 *) | Unused_rec_flag (* 39 *) | Name_out_of_scope of string * string list * bool (* 40 *) | Ambiguous_name of string list * string list * bool * string (* 41 *) @@ -95,11 +108,15 @@ type t = | Unused_open_bang of string (* 66 *) | Unused_functor_parameter of string (* 67 *) | Match_on_mutable_state_prevent_uncurry (* 68 *) + | Unused_field of string * field_usage_warning (* 69 *) + | Missing_mli (* 70 *) + | Unused_tmc_attribute (* 71 *) + | Tmc_breaks_tailcall (* 72 *) ;; type alert = {kind:string; message:string; def:loc; use:loc} -val parse_options : bool -> string -> unit;; +val parse_options : bool -> string -> alert option;; val parse_alert_option: string -> unit (** Disable/enable alerts based on the parameter to the -alert @@ -136,6 +153,14 @@ val help_warnings: unit -> unit type state val backup: unit -> state val restore: state -> unit +val with_state : state -> (unit -> 'a) -> 'a val mk_lazy: (unit -> 'a) -> 'a Lazy.t (** Like [Lazy.of_fun], but the function is applied with the warning/alert settings at the time [mk_lazy] is called. *) + +type description = + { number : int; + names : string list; + description : string; } + +val descriptions : description list diff --git a/ocaml/yacc/Makefile b/ocaml/yacc/Makefile index 641a425af6f..d75719c75b1 100644 --- a/ocaml/yacc/Makefile +++ b/ocaml/yacc/Makefile @@ -35,18 +35,16 @@ ocamlyacc_SOURCES := $(addsuffix .c,\ ocamlyacc_OBJECTS := $(ocamlyacc_SOURCES:.c=.$(O)) -generated_files := ocamlyacc$(EXE) $(ocamlyacc_OBJECTS) version.h +generated_files := ocamlyacc$(EXE) $(ocamlyacc_OBJECTS) all: ocamlyacc$(EXE) ocamlyacc$(EXE): $(ocamlyacc_OBJECTS) $(MKEXE) -o $@ $^ $(EXTRALIBS) -version.h : $(ROOTDIR)/VERSION - echo "#define OCAML_VERSION \"`sed -e 1q $< | tr -d '\r'`\"" > $@ - +.PHONY: clean clean: - rm -f ocamlyacc ocamlyacc.exe wstr.o wstr.obj version.h \ + rm -f ocamlyacc ocamlyacc.exe wstr.o wstr.obj \ $(ocamlyacc_SOURCES:.c=.o) $(ocamlyacc_SOURCES:.c=.obj) depend: @@ -55,7 +53,7 @@ closure.$(O): defs.h error.$(O): defs.h lalr.$(O): defs.h lr0.$(O): defs.h -main.$(O): defs.h version.h +main.$(O): defs.h mkpar.$(O): defs.h output.$(O): defs.h reader.$(O): defs.h diff --git a/ocaml/yacc/defs.h b/ocaml/yacc/defs.h index 1fd3dc680c7..1e9bbfc4996 100644 --- a/ocaml/yacc/defs.h +++ b/ocaml/yacc/defs.h @@ -30,6 +30,7 @@ #include "caml/config.h" #include "caml/mlvalues.h" #include "caml/osdeps.h" +#include "caml/misc.h" #define caml_stat_strdup strdup diff --git a/ocaml/yacc/main.c b/ocaml/yacc/main.c index a60f4676253..873ce9e6911 100644 --- a/ocaml/yacc/main.c +++ b/ocaml/yacc/main.c @@ -22,7 +22,7 @@ #include #endif -#include "version.h" +#include "caml/version.h" char lflag; char rflag; @@ -183,10 +183,10 @@ void getargs(int argc, char_os **argv) case 'v': if (!strcmp_os (argv[i], T("-version"))){ printf ("The OCaml parser generator, version " - OCAML_VERSION "\n"); + OCAML_VERSION_STRING "\n"); exit (0); }else if (!strcmp_os (argv[i], T("-vnum"))){ - printf (OCAML_VERSION "\n"); + printf (OCAML_VERSION_STRING "\n"); exit (0); }else{ vflag = 1; @@ -420,11 +420,7 @@ void open_files(void) open_error(interface_file_name); } -#ifdef _WIN32 -int wmain(int argc, wchar_t **argv) -#else -int main(int argc, char **argv) -#endif +int main_os(int argc, char_os **argv) { set_signals(); getargs(argc, argv); diff --git a/printer/printast_with_mappings.ml b/printer/printast_with_mappings.ml index 3dd1e48abdf..a7853f044e2 100644 --- a/printer/printast_with_mappings.ml +++ b/printer/printast_with_mappings.ml @@ -148,6 +148,9 @@ let arg_label i ppf = function | Labelled s -> line i ppf "Labelled \"%s\"\n" s ;; +let typevars ppf vs = + List.iter (fun x -> fprintf ppf " %a" Pprintast.tyvar x.txt) vs + let rec core_type i ppf x = with_location_mapping ~loc:x.ptyp_loc ppf (fun () -> line i ppf "core_type %a\n" fmt_location x.ptyp_loc; @@ -228,7 +231,11 @@ and pattern i ppf x = list i pattern ppf l; | Ppat_construct (li, po) -> line i ppf "Ppat_construct %a\n" fmt_longident_loc li; - option i pattern ppf po; + option i + (fun i ppf (vl, p) -> + list i string_loc ppf vl; + pattern i ppf p) + ppf po | Ppat_variant (l, po) -> line i ppf "Ppat_variant \"%s\"\n" l; option i pattern ppf po; @@ -498,8 +505,9 @@ and extension_constructor i ppf x = and extension_constructor_kind i ppf x = match x with - Pext_decl(a, r) -> + Pext_decl(v, a, r) -> line i ppf "Pext_decl\n"; + if v <> [] then line (i+1) ppf "vars%a\n" typevars v; constructor_arguments (i+1) ppf a; option (i+1) core_type ppf r; | Pext_rebind li -> @@ -756,6 +764,10 @@ and signature_item i ppf x = line i ppf "Psig_modtype %a\n" fmt_string_loc x.pmtd_name; attributes i ppf x.pmtd_attributes; modtype_declaration i ppf x.pmtd_type + | Psig_modtypesubst x -> + line i ppf "Psig_modtypesubst %a\n" fmt_string_loc x.pmtd_name; + attributes i ppf x.pmtd_attributes; + modtype_declaration i ppf x.pmtd_type | Psig_open od -> line i ppf "Psig_open %a %a\n" fmt_override_flag od.popen_override fmt_longident_loc od.popen_expr; @@ -798,6 +810,14 @@ and with_constraint i ppf x = line i ppf "Pwith_modsubst %a = %a\n" fmt_longident_loc lid1 fmt_longident_loc lid2; + | Pwith_modtype (lid1, mty) -> + line i ppf "Pwith_modtype %a\n" + fmt_longident_loc lid1; + module_type (i+1) ppf mty + | Pwith_modtypesubst (lid1, mty) -> + line i ppf "Pwith_modtypesubst %a\n" + fmt_longident_loc lid1; + module_type (i+1) ppf mty and module_expr i ppf x = with_location_mapping ~loc:x.pmod_loc ppf (fun () -> diff --git a/tests/backend/checkmach/dune b/tests/backend/checkmach/dune index 43f17521add..c214187e71b 100644 --- a/tests/backend/checkmach/dune +++ b/tests/backend/checkmach/dune @@ -100,8 +100,13 @@ (enabled_if (= %{context_name} "main")) (targets test_attribute_error_duplicate.output.corrected) (deps test_attribute_error_duplicate.ml) - (action (with-outputs-to test_attribute_error_duplicate.output.corrected - (run %{bin:ocamlopt.opt} %{deps} -color never -error-style short -c -alloc-check -O3)))) + (action + (with-outputs-to test_attribute_error_duplicate.output.corrected + (pipe-outputs + (with-accepted-exit-codes 2 + (run %{bin:ocamlopt.opt} %{deps} -color never -error-style short -c -alloc-check -O3)) + (run "./filter.sh") + )))) (rule (alias runtest) diff --git a/tests/backend/checkmach/test_attribute_error_duplicate.output b/tests/backend/checkmach/test_attribute_error_duplicate.output index b1ac41ce327..9e1c5ea15cc 100644 --- a/tests/backend/checkmach/test_attribute_error_duplicate.output +++ b/tests/backend/checkmach/test_attribute_error_duplicate.output @@ -5,3 +5,5 @@ Warning 54 [duplicated-attribute]: the "noalloc" attribute is used more than onc File "test_attribute_error_duplicate.ml", line 3, characters 5-12: Warning 47 [attribute-payload]: illegal payload for attribute 'noalloc'. It must be either 'assume' or empty +File "test_attribute_error_duplicate.ml", line 1, characters 30-37: +Error: Annotation check for noalloc failed on function camlTest_attribute_error_duplicate__test1_HIDE_STAMP diff --git a/tests/backend/frame-too-long/dune b/tests/backend/frame-too-long/dune new file mode 100644 index 00000000000..27f36df1188 --- /dev/null +++ b/tests/backend/frame-too-long/dune @@ -0,0 +1,19 @@ +(executable + (name t) + (modules t) + (ocamlopt_flags (:standard -linscan -Oclassic -debug-long-frames-threshold 100))) + +(rule + (enabled_if (= %{context_name} "main")) + (target t.output) + (deps t.exe) + (action (with-outputs-to t.output (run ./t.exe)))) + +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (action (diff t.expected t.output))) + +;; t.ml was created using cinaps +;; (cinaps +;; (files t.ml)) diff --git a/tests/backend/frame-too-long/t.expected b/tests/backend/frame-too-long/t.expected new file mode 100644 index 00000000000..68dcf142f97 --- /dev/null +++ b/tests/backend/frame-too-long/t.expected @@ -0,0 +1 @@ +i=10000 len=2 name=Raised at T.break in file "tests/backend/frame-too-long/t.ml", line 5, characters 2-15 diff --git a/tests/backend/frame-too-long/t.ml b/tests/backend/frame-too-long/t.ml new file mode 100644 index 00000000000..8c869c34814 --- /dev/null +++ b/tests/backend/frame-too-long/t.ml @@ -0,0 +1,86 @@ +let[@inline never] make n = List.init n Fun.id + +exception Exn of int +let[@inline never] break n = + raise (Exn n) + +let[@inline never] check_backtrace n = + try + break n + with + | Exn i -> + let raw_backtrace = Printexc.get_raw_backtrace () in + let len = Printexc.raw_backtrace_length raw_backtrace in + assert (len > 0); + let slot = Printexc.get_raw_backtrace_slot raw_backtrace 0 + |> Printexc.convert_raw_backtrace_slot in + let name = Printexc.Slot.format 0 slot |> Option.get in + Printf.printf "i=%d len=%d name=%s\n" i len name; + () + +let test n = + let l = make n in + (*$ + for i = 1 to Sys.opaque_identity 20 do + Printf.printf "let a%d = Sys.opaque_identity 1 in\n" i + done; + *)let a1 = Sys.opaque_identity 1 in +let a2 = Sys.opaque_identity 1 in +let a3 = Sys.opaque_identity 1 in +let a4 = Sys.opaque_identity 1 in +let a5 = Sys.opaque_identity 1 in +let a6 = Sys.opaque_identity 1 in +let a7 = Sys.opaque_identity 1 in +let a8 = Sys.opaque_identity 1 in +let a9 = Sys.opaque_identity 1 in +let a10 = Sys.opaque_identity 1 in +let a11 = Sys.opaque_identity 1 in +let a12 = Sys.opaque_identity 1 in +let a13 = Sys.opaque_identity 1 in +let a14 = Sys.opaque_identity 1 in +let a15 = Sys.opaque_identity 1 in +let a16 = Sys.opaque_identity 1 in +let a17 = Sys.opaque_identity 1 in +let a18 = Sys.opaque_identity 1 in +let a19 = Sys.opaque_identity 1 in +let a20 = Sys.opaque_identity 1 in +(*$*) + check_backtrace n; + let l = make (List.length l) in + Gc.compact (); + [ + (*$ + for i = 1 to Sys.opaque_identity 20 do + Printf.printf "a%d;\n" i + done; + *)a1; +a2; +a3; +a4; +a5; +a6; +a7; +a8; +a9; +a10; +a11; +a12; +a13; +a14; +a15; +a16; +a17; +a18; +a19; +a20; +(*$*) + ]@l + |> Sys.opaque_identity + + +let () = + Printexc.record_backtrace true; + 10_000 + |> Sys.opaque_identity + |> test + |> ignore diff --git a/tests/backend/polls/dune b/tests/backend/polls/dune new file mode 100644 index 00000000000..4f3d48cc6d6 --- /dev/null +++ b/tests/backend/polls/dune @@ -0,0 +1,5 @@ +(rule + (alias runtest) + (enabled_if (= %{context_name} "main")) + (deps t.ml) + (action (run %{bin:ocamlopt.opt} %{deps} -c -disable-poll-insertion))) diff --git a/tests/backend/polls/t.ml b/tests/backend/polls/t.ml new file mode 100644 index 00000000000..284033ddefe --- /dev/null +++ b/tests/backend/polls/t.ml @@ -0,0 +1,7 @@ +let[@poll error] test n = + let res = ref 0 in + for i = 0 to n do + res := Sys.opaque_identity (i) + !res + done; + !res + diff --git a/testsuite/flambda2-test-list b/testsuite/flambda2-test-list index 2e322c49270..c8236026024 100644 --- a/testsuite/flambda2-test-list +++ b/testsuite/flambda2-test-list @@ -1,19 +1,7 @@ # excluded test | status | reason for not running / failure # ------------------------------------------------------------------------------------------------ tests/asmcomp FAIL - tests/asmgen FAIL tests/backtrace FAIL (FIXME) there is practically no backtrace info -# tests/basic FAIL (FIXME) sets.ml has different bytecodes (ocamlc.byte vs ocamlc.byte) - the digest of the main module differ - tests/basic-modules FAIL (FIXME) PR#8948 not merged yet in trunk - tests/float-unboxing FAIL (FIXME) 'float_subst_boxed_number.ml' see flambdatest/mlexamples/float_unboxing.ml for a simplified error example - tests/gc-roots FAIL (FIXME) test_stdlabels.ml has different bytecodes (ocamlc.byte vs ocamlc.byte) - the digest of the main module differ - tests/int64-unboxing FAIL (FIXME) 'test.ml' (unboxing of recursive continuation parameter) - tests/lib-dynlink-init-info FAIL (FIXME) fails on macOS - tests/lib-dynlink-initializers FAIL (FIXME) temporarily disabled (flambda2) - tests/lib-dynlink-pr4839 FAIL (FIXME) temporarily disabled (flambda2) - tests/lib-hashtbl FAIL (FIXME) htbl.ml has different bytecodes (ocamlc.byte vs ocamlc.byte) - the digest of the main module differ - tests/lib-stdlabels FAIL (FIXME) test_stdlabels.ml has different bytecodes (ocamlc.byte vs ocamlc.byte) - the digest of the main module differ - tests/lib-threads FAIL (FIXME) beat.ml seems to fail under heavy load (macOS box on GitHub CI) - tests/opaque FAIL 'test.ml' (cmx file loading) + tests/float-unboxing FAIL (FIXME) 'float_subst_boxed_number.ml' see flambdatest/mlexamples/float_unboxing.ml for a simplified error example. Should be fixed with unboxing in to_cmm tests/statmemprof FAIL Stack traces differ tests/warnings FAIL 'w55.ml' (@inline attribute), 'w59.ml' (missing warnings when using Obj functions) diff --git a/testsuite/tests/asmcomp/poll_attr_both.compilers.reference b/testsuite/tests/asmcomp/poll_attr_both.compilers.reference new file mode 100644 index 00000000000..11072d1d052 --- /dev/null +++ b/testsuite/tests/asmcomp/poll_attr_both.compilers.reference @@ -0,0 +1,6 @@ +File "poll_attr_both.ml", line 1: +Error: Function with poll-error attribute contains polling points: + allocation at File "poll_attr_both.ml", line 17, characters 29-37 + function call at File "poll_attr_both.ml", line 18, characters 13-16 + (plus compiler-inserted polling point(s) in prologue and/or loop back edges) + diff --git a/testsuite/tests/asmcomp/poll_attr_both.ml b/testsuite/tests/asmcomp/poll_attr_both.ml new file mode 100644 index 00000000000..0bef1f20463 --- /dev/null +++ b/testsuite/tests/asmcomp/poll_attr_both.ml @@ -0,0 +1,22 @@ +(* TEST + * poll-insertion + ** setup-ocamlopt.byte-build-env + *** ocamlopt.byte +ocamlopt_byte_exit_status = "2" + **** check-ocamlopt.byte-output + + ** setup-ocamlopt.opt-build-env + *** ocamlopt.opt +ocamlopt_opt_exit_status = "2" + **** check-ocamlopt.opt-output +*) + +let[@inline never][@local never] v x = x + 1 + +let[@poll error] c x = + let y = Sys.opaque_identity(ref 42) in + let x2 = v x in + for c = 0 to x2 do + ignore(Sys.opaque_identity(42)) + done; + x2 + !y diff --git a/testsuite/tests/asmcomp/poll_attr_inserted.compilers.reference b/testsuite/tests/asmcomp/poll_attr_inserted.compilers.reference new file mode 100644 index 00000000000..826cd527eed --- /dev/null +++ b/testsuite/tests/asmcomp/poll_attr_inserted.compilers.reference @@ -0,0 +1,3 @@ +File "poll_attr_inserted.ml", line 1: +Error: Function with poll-error attribute contains polling points (inserted by the compiler) + diff --git a/testsuite/tests/asmcomp/poll_attr_inserted.ml b/testsuite/tests/asmcomp/poll_attr_inserted.ml new file mode 100644 index 00000000000..ea090f3e61d --- /dev/null +++ b/testsuite/tests/asmcomp/poll_attr_inserted.ml @@ -0,0 +1,17 @@ +(* TEST + * poll-insertion + ** setup-ocamlopt.byte-build-env + *** ocamlopt.byte +ocamlopt_byte_exit_status = "2" + **** check-ocamlopt.byte-output + + ** setup-ocamlopt.opt-build-env + *** ocamlopt.opt +ocamlopt_opt_exit_status = "2" + **** check-ocamlopt.opt-output +*) + +let[@poll error] c x = + for c = 0 to 2 do + ignore(Sys.opaque_identity(42)) + done diff --git a/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference b/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference new file mode 100644 index 00000000000..b8fac05d786 --- /dev/null +++ b/testsuite/tests/asmcomp/poll_attr_prologue.compilers.reference @@ -0,0 +1,5 @@ +File "poll_attr_prologue.ml", line 1: +Error: Function with poll-error attribute contains polling points: + function call at File "poll_attr_prologue.ml", line 17, characters 15-38 + (plus compiler-inserted polling point(s) in prologue and/or loop back edges) + diff --git a/testsuite/tests/asmcomp/poll_attr_prologue.ml b/testsuite/tests/asmcomp/poll_attr_prologue.ml new file mode 100644 index 00000000000..091c7702560 --- /dev/null +++ b/testsuite/tests/asmcomp/poll_attr_prologue.ml @@ -0,0 +1,17 @@ +(* TEST + * poll-insertion + ** setup-ocamlopt.byte-build-env + *** ocamlopt.byte +ocamlopt_byte_exit_status = "2" + **** check-ocamlopt.byte-output + + ** setup-ocamlopt.opt-build-env + *** ocamlopt.opt +ocamlopt_opt_exit_status = "2" + **** check-ocamlopt.opt-output +*) + +let[@poll error] rec c x l = + match l with + | [] -> 0 + | _ :: tl -> (c[@tailcall]) (x+1) tl diff --git a/testsuite/tests/asmcomp/poll_attr_user.compilers.reference b/testsuite/tests/asmcomp/poll_attr_user.compilers.reference new file mode 100644 index 00000000000..0d4319f175d --- /dev/null +++ b/testsuite/tests/asmcomp/poll_attr_user.compilers.reference @@ -0,0 +1,6 @@ +File "poll_attr_user.ml", line 1: +Error: Function with poll-error attribute contains polling points: + allocation at File "poll_attr_user.ml", line 17, characters 29-37 + function call at File "poll_attr_user.ml", line 18, characters 13-16 + allocation at File "poll_attr_user.ml", line 20, characters 34-42 + diff --git a/testsuite/tests/asmcomp/poll_attr_user.ml b/testsuite/tests/asmcomp/poll_attr_user.ml new file mode 100644 index 00000000000..b48709a51a6 --- /dev/null +++ b/testsuite/tests/asmcomp/poll_attr_user.ml @@ -0,0 +1,22 @@ +(* TEST + * poll-insertion + ** setup-ocamlopt.byte-build-env + *** ocamlopt.byte +ocamlopt_byte_exit_status = "2" + **** check-ocamlopt.byte-output + + ** setup-ocamlopt.opt-build-env + *** ocamlopt.opt +ocamlopt_opt_exit_status = "2" + **** check-ocamlopt.opt-output +*) + +let[@inline never][@local never] v x = x + 1 + +let[@poll error] c x = + let y = Sys.opaque_identity(ref 42) in + let x2 = v x in + for c = 0 to x2 do + ignore(Sys.opaque_identity(ref 42)) + done; + x2 + !y diff --git a/testsuite/tests/asmgen/arith.cmm b/testsuite/tests/asmgen/arith.cmm index 4d26aac1f2f..3ba0fd333a6 100644 --- a/testsuite/tests/asmgen/arith.cmm +++ b/testsuite/tests/asmgen/arith.cmm @@ -1,5 +1,5 @@ (* TEST -files = "mainarith.c" +readonly_files = "mainarith.c" arguments = "mainarith.c" * asmgen *) diff --git a/testsuite/tests/asmgen/catch-float.cmm b/testsuite/tests/asmgen/catch-float.cmm index 9d1d1683fe2..c51eb3c37ab 100644 --- a/testsuite/tests/asmgen/catch-float.cmm +++ b/testsuite/tests/asmgen/catch-float.cmm @@ -1,5 +1,5 @@ (* TEST -files = "main.c" +readonly_files = "main.c" arguments = "-DFLOAT_CATCH -DFUN=catch_float main.c" * asmgen *) diff --git a/testsuite/tests/asmgen/catch-multiple.cmm b/testsuite/tests/asmgen/catch-multiple.cmm index 1510fcea089..3887c5b8910 100644 --- a/testsuite/tests/asmgen/catch-multiple.cmm +++ b/testsuite/tests/asmgen/catch-multiple.cmm @@ -1,5 +1,5 @@ (* TEST -files = "main.c" +readonly_files = "main.c" arguments = "-DINT_INT -DFUN=catch_multiple main.c" * asmgen *) diff --git a/testsuite/tests/asmgen/catch-rec-deadhandler.cmm b/testsuite/tests/asmgen/catch-rec-deadhandler.cmm index 34dc8a26c5b..143f880ebcd 100644 --- a/testsuite/tests/asmgen/catch-rec-deadhandler.cmm +++ b/testsuite/tests/asmgen/catch-rec-deadhandler.cmm @@ -1,6 +1,6 @@ (* TEST flags = "-dlive" -files = "main.c" +readonly_files = "main.c" arguments = "-DUNIT_INT -DFUN=catch_rec_deadhandler main.c" * asmgen ** run diff --git a/testsuite/tests/asmgen/catch-rec-deadhandler.run b/testsuite/tests/asmgen/catch-rec-deadhandler.run index bad9f117cd3..cd7b1635ef3 100755 --- a/testsuite/tests/asmgen/catch-rec-deadhandler.run +++ b/testsuite/tests/asmgen/catch-rec-deadhandler.run @@ -2,4 +2,7 @@ exec > "${output}" 2>&1 -grep -E "catch |with\(|and\(|exit\(" "${compiler_output}" +if [ "${REGISTER_ALLOCATOR}" = "irc" ] +then cat "${reference}" +else grep -E "catch |with\(|and\(|exit\(" "${compiler_output}" +fi diff --git a/testsuite/tests/asmgen/catch-rec.cmm b/testsuite/tests/asmgen/catch-rec.cmm index 17f9884a767..51089d32509 100644 --- a/testsuite/tests/asmgen/catch-rec.cmm +++ b/testsuite/tests/asmgen/catch-rec.cmm @@ -1,5 +1,5 @@ (* TEST -files = "main.c" +readonly_files = "main.c" arguments = "-DINT_INT -DFUN=catch_fact main.c" * asmgen *) diff --git a/testsuite/tests/asmgen/catch-try-float.cmm b/testsuite/tests/asmgen/catch-try-float.cmm index b38ea452e70..ef5946e2493 100644 --- a/testsuite/tests/asmgen/catch-try-float.cmm +++ b/testsuite/tests/asmgen/catch-try-float.cmm @@ -1,5 +1,5 @@ (* TEST -files = "main.c" +readonly_files = "main.c" arguments = "-DFLOAT_CATCH -DFUN=catch_try_float main.c" * asmgen *) diff --git a/testsuite/tests/asmgen/catch-try.cmm b/testsuite/tests/asmgen/catch-try.cmm index 68a4aafb5c9..4f0418ffc73 100644 --- a/testsuite/tests/asmgen/catch-try.cmm +++ b/testsuite/tests/asmgen/catch-try.cmm @@ -1,5 +1,5 @@ (* TEST -files = "main.c" +readonly_files = "main.c" arguments = "-DINT_INT -DFUN=catch_exit main.c" * asmgen *) diff --git a/testsuite/tests/asmgen/checkbound.cmm b/testsuite/tests/asmgen/checkbound.cmm index 0b864d5b8c4..616c1edc777 100644 --- a/testsuite/tests/asmgen/checkbound.cmm +++ b/testsuite/tests/asmgen/checkbound.cmm @@ -1,5 +1,5 @@ (* TEST -files = "main.c" +readonly_files = "main.c" arguments = "-DCHECKBOUND main.c" * asmgen *) diff --git a/testsuite/tests/asmgen/even-odd-spill-float.cmm b/testsuite/tests/asmgen/even-odd-spill-float.cmm index 1603aa807d9..dc8169b462d 100644 --- a/testsuite/tests/asmgen/even-odd-spill-float.cmm +++ b/testsuite/tests/asmgen/even-odd-spill-float.cmm @@ -1,5 +1,5 @@ (* TEST -files = "main.c" +readonly_files = "main.c" arguments = "-DINT_FLOAT -DFUN=is_even main.c" * asmgen *) diff --git a/testsuite/tests/asmgen/even-odd-spill.cmm b/testsuite/tests/asmgen/even-odd-spill.cmm index f0b9a70faae..9e392445ce3 100644 --- a/testsuite/tests/asmgen/even-odd-spill.cmm +++ b/testsuite/tests/asmgen/even-odd-spill.cmm @@ -1,5 +1,5 @@ (* TEST -files = "main.c" +readonly_files = "main.c" arguments = "-DINT_INT -DFUN=is_even main.c" * asmgen *) diff --git a/testsuite/tests/asmgen/even-odd.cmm b/testsuite/tests/asmgen/even-odd.cmm index adf0d0b828e..a9e20ad8945 100644 --- a/testsuite/tests/asmgen/even-odd.cmm +++ b/testsuite/tests/asmgen/even-odd.cmm @@ -1,5 +1,5 @@ (* TEST -files= "main.c" +readonly_files = "main.c" arguments = "-DINT_INT -DFUN=is_even main.c" * asmgen *) diff --git a/testsuite/tests/asmgen/fib.cmm b/testsuite/tests/asmgen/fib.cmm index c1a82de2686..b5a0b5673ea 100644 --- a/testsuite/tests/asmgen/fib.cmm +++ b/testsuite/tests/asmgen/fib.cmm @@ -1,5 +1,5 @@ (* TEST -files = "main.c" +readonly_files = "main.c" arguments = "-DINT_INT -DFUN=fib main.c" * asmgen *) diff --git a/testsuite/tests/asmgen/immediates.cmm b/testsuite/tests/asmgen/immediates.cmm index 40fceda45ba..f61de1ae1e8 100644 --- a/testsuite/tests/asmgen/immediates.cmm +++ b/testsuite/tests/asmgen/immediates.cmm @@ -1,5 +1,5 @@ (* TEST -files = "mainimmed.c" +readonly_files = "mainimmed.c" arguments = "-I ${test_source_directory} mainimmed.c" * asmgen *) diff --git a/testsuite/tests/asmgen/integr.cmm b/testsuite/tests/asmgen/integr.cmm index 84a3895c245..92d1cb07360 100644 --- a/testsuite/tests/asmgen/integr.cmm +++ b/testsuite/tests/asmgen/integr.cmm @@ -1,5 +1,5 @@ (* TEST -files = "main.c" +readonly_files = "main.c" arguments = "-DINT_FLOAT -DFUN=test main.c" * skip reason = "This test is currently broken" diff --git a/testsuite/tests/asmgen/main.c b/testsuite/tests/asmgen/main.c index 103e022baf0..975b54833e8 100644 --- a/testsuite/tests/asmgen/main.c +++ b/testsuite/tests/asmgen/main.c @@ -18,6 +18,14 @@ #include #include +/* This stub isn't needed for msvc32, since it's already in asmgen_i386nt.asm */ +#if !defined(_MSC_VER) || !defined(_M_IX86) +void caml_call_gc() +{ + +} +#endif + void caml_ml_array_bound_error(void) { fprintf(stderr, "Fatal error: out-of-bound access in array or string\n"); diff --git a/testsuite/tests/asmgen/mainarith.c b/testsuite/tests/asmgen/mainarith.c index 354ab02d391..ae4d1c50e05 100644 --- a/testsuite/tests/asmgen/mainarith.c +++ b/testsuite/tests/asmgen/mainarith.c @@ -22,6 +22,10 @@ #include #define FMT ARCH_INTNAT_PRINTF_FORMAT +void caml_call_poll() +{ +} + void caml_ml_array_bound_error(void) { fprintf(stderr, "Fatal error: out-of-bound access in array or string\n"); diff --git a/testsuite/tests/asmgen/pgcd.cmm b/testsuite/tests/asmgen/pgcd.cmm index 3bd067c8bcf..74e3c423953 100644 --- a/testsuite/tests/asmgen/pgcd.cmm +++ b/testsuite/tests/asmgen/pgcd.cmm @@ -1,5 +1,5 @@ (* TEST -files = "main.c" +readonly_files = "main.c" arguments = "-DINT_INT -DFUN=pgcd_30030 main.c" * asmgen *) diff --git a/testsuite/tests/asmgen/quicksort.cmm b/testsuite/tests/asmgen/quicksort.cmm index 5ac97a41289..58029cd16de 100644 --- a/testsuite/tests/asmgen/quicksort.cmm +++ b/testsuite/tests/asmgen/quicksort.cmm @@ -1,5 +1,5 @@ (* TEST -files = "main.c" +readonly_files = "main.c" arguments = "-DSORT -DFUN=quicksort main.c" * asmgen *) diff --git a/testsuite/tests/asmgen/quicksort2.cmm b/testsuite/tests/asmgen/quicksort2.cmm index b5822eca34a..5c07a7cf5b3 100644 --- a/testsuite/tests/asmgen/quicksort2.cmm +++ b/testsuite/tests/asmgen/quicksort2.cmm @@ -1,5 +1,5 @@ (* TEST -files = "main.c" +readonly_files = "main.c" arguments = "-DSORT -DFUN=quicksort main.c" * asmgen *) diff --git a/testsuite/tests/asmgen/soli.cmm b/testsuite/tests/asmgen/soli.cmm index e80381f0cd7..568765116ba 100644 --- a/testsuite/tests/asmgen/soli.cmm +++ b/testsuite/tests/asmgen/soli.cmm @@ -1,5 +1,5 @@ (* TEST -files = "main.c" +readonly_files = "main.c" arguments = "-DUNIT_INT -DFUN=solitaire main.c" * asmgen *) diff --git a/testsuite/tests/asmgen/tagged-fib.cmm b/testsuite/tests/asmgen/tagged-fib.cmm index b9b96152deb..a2da4487b69 100644 --- a/testsuite/tests/asmgen/tagged-fib.cmm +++ b/testsuite/tests/asmgen/tagged-fib.cmm @@ -1,5 +1,5 @@ (* TEST -files = "main.c" +readonly_files = "main.c" arguments = "-DINT_INT -DFUN=fib main.c" * asmgen *) diff --git a/testsuite/tests/asmgen/tagged-integr.cmm b/testsuite/tests/asmgen/tagged-integr.cmm index 8903405f6a9..453e73543ad 100644 --- a/testsuite/tests/asmgen/tagged-integr.cmm +++ b/testsuite/tests/asmgen/tagged-integr.cmm @@ -1,5 +1,5 @@ (* TEST -files = "main.c" +readonly_files = "main.c" arguments = "-DINT_FLOAT -DFUN=test main.c" * asmgen *) diff --git a/testsuite/tests/asmgen/tagged-quicksort.cmm b/testsuite/tests/asmgen/tagged-quicksort.cmm index 631dd6aa1a8..8ba8e74497b 100644 --- a/testsuite/tests/asmgen/tagged-quicksort.cmm +++ b/testsuite/tests/asmgen/tagged-quicksort.cmm @@ -1,5 +1,5 @@ (* TEST -files = "main.c" +readonly_files = "main.c" arguments = "-DSORT -DFUN=quicksort main.c" * asmgen *) diff --git a/testsuite/tests/asmgen/tagged-tak.cmm b/testsuite/tests/asmgen/tagged-tak.cmm index 3ff6ea4f2e8..8bb28a0ee02 100644 --- a/testsuite/tests/asmgen/tagged-tak.cmm +++ b/testsuite/tests/asmgen/tagged-tak.cmm @@ -1,5 +1,5 @@ (* TEST -files = "main.c" +readonly_files = "main.c" arguments = "-DUNIT_INT -DFUN=takmain main.c" * asmgen *) diff --git a/testsuite/tests/asmgen/tak.cmm b/testsuite/tests/asmgen/tak.cmm index 1835ef66a53..3e8430b5c32 100644 --- a/testsuite/tests/asmgen/tak.cmm +++ b/testsuite/tests/asmgen/tak.cmm @@ -1,5 +1,5 @@ (* TEST -files = "main.c" +readonly_files = "main.c" arguments = "-DUNIT_INT -DFUN=takmain main.c" * asmgen *) diff --git a/testsuite/tools/Makefile b/testsuite/tools/Makefile index 059b2118d43..86697b640de 100644 --- a/testsuite/tools/Makefile +++ b/testsuite/tools/Makefile @@ -14,25 +14,30 @@ .NOTPARALLEL: -TOPDIR = ../.. +ROOTDIR = ../.. -COMPILERLIBSDIR = $(TOPDIR)/compilerlibs +COMPILERLIBSDIR = $(ROOTDIR)/compilerlibs RUNTIME_VARIANT ?= ASPPFLAGS ?= -include $(TOPDIR)/Makefile.tools +include $(ROOTDIR)/Makefile.common +include $(ROOTDIR)/Makefile.best_binaries + +STDLIBFLAGS = -nostdlib -I $(ROOTDIR)/stdlib +OCAMLC ?= $(BEST_OCAMLC) $(STDLIBFLAGS) +OCAMLOPT ?= $(BEST_OCAMLOPT) $(STDLIBFLAGS) expect_MAIN=expect_test expect_PROG=$(expect_MAIN)$(EXE) expect_DIRS = parsing utils driver typing toplevel -expect_OCAMLFLAGS = $(addprefix -I $(TOPDIR)/,$(expect_DIRS)) +expect_OCAMLFLAGS = $(addprefix -I $(ROOTDIR)/,$(expect_DIRS)) expect_LIBS := $(addprefix $(COMPILERLIBSDIR)/,\ ocamlcommon ocamlbytecomp ocamltoplevel) codegen_PROG = codegen$(EXE) codegen_DIRS = parsing utils typing middle_end bytecomp lambda asmcomp -codegen_OCAMLFLAGS = $(addprefix -I $(TOPDIR)/, $(codegen_DIRS)) -w +40 -g +codegen_OCAMLFLAGS = $(addprefix -I $(ROOTDIR)/, $(codegen_DIRS)) -w +40 -g codegen_LIBS = unix bigarray $(addprefix $(COMPILERLIBSDIR)/,\ ocamlcommon \ @@ -64,7 +69,7 @@ $(codegen_PROG): COMPFLAGS = $(codegen_OCAMLFLAGS) codegen_main.cmo: parsecmm.cmo $(codegen_PROG): $(codegen_OBJECTS) - $(OCAMLC) -o $@ $(codegen_LIBS:=.cma) $^ + $(OCAMLC) -o $@ $(COMPFLAGS) $(codegen_LIBS:=.cma) $^ parsecmm.mli parsecmm.ml: parsecmm.mly $(OCAMLYACC) -q parsecmm.mly @@ -83,13 +88,13 @@ asmgen_i386.obj: asmgen_i386nt.asm $(ASM) $@ $^ | tail -n +2 %.cmi: %.mli - $(OCAMLC) -c $< + $(OCAMLC) $(COMPFLAGS) -c $< %.cmo: %.ml - $(OCAMLC) -c $< + $(OCAMLC) $(COMPFLAGS) -c $< %.cmx: %.ml - $(OCAMLOPT) -c $< + $(OCAMLOPT) $(COMPFLAGS) -c $< %.$(O): %.S $(ASPP) $(ASPPFLAGS) -DSYS_$(SYSTEM) -DMODEL_$(MODEL) -o $@ $< diff --git a/testsuite/tools/codegen_main.ml b/testsuite/tools/codegen_main.ml index 33808595aac..426f0e74656 100644 --- a/testsuite/tools/codegen_main.ml +++ b/testsuite/tools/codegen_main.ml @@ -21,12 +21,9 @@ let compile_file filename = let out_name = Filename.chop_extension filename ^ ".s" in Emitaux.output_channel := open_out out_name end; (* otherwise, stdout *) - let compilation_unit = - Compilation_unit.create Compilation_unit.Prefix.empty - ("test" |> Compilation_unit.Name.of_string) - in + let compilation_unit = "test" |> Compilation_unit.of_string in Compilenv.reset compilation_unit; - Emit.begin_assembly ~init_dwarf:(fun () -> ()); + Emit.begin_assembly (module Unix : Compiler_owee.Unix_intf.S); let ic = open_in filename in let lb = Lexing.from_channel ic in lb.Lexing.lex_curr_p <- Lexing.{ lb.lex_curr_p with pos_fname = filename }; @@ -37,7 +34,7 @@ let compile_file filename = done with End_of_file -> - close_in ic; Emit.end_assembly None; + close_in ic; Emit.end_assembly (); if !write_asm_file then close_out !Emitaux.output_channel | Lexcmm.Error msg -> close_in ic; Lexcmm.report_error lb msg diff --git a/testsuite/tools/expect_test.ml b/testsuite/tools/expect_test.ml index fed821fc5a1..386397b6e83 100644 --- a/testsuite/tools/expect_test.ml +++ b/testsuite/tools/expect_test.ml @@ -139,19 +139,19 @@ let collect_formatters buf pps ~f = let ppb = Format.formatter_of_buffer buf in let out_functions = Format.pp_get_formatter_out_functions ppb () in - List.iter (fun pp -> Format.pp_print_flush pp ()) pps; + List.iter ~f:(fun pp -> Format.pp_print_flush pp ()) pps; let save = - List.map (fun pp -> Format.pp_get_formatter_out_functions pp ()) pps + List.map ~f:(fun pp -> Format.pp_get_formatter_out_functions pp ()) pps in let restore () = List.iter2 - (fun pp out_functions -> + ~f:(fun pp out_functions -> Format.pp_print_flush pp (); Format.pp_set_formatter_out_functions pp out_functions) pps save in List.iter - (fun pp -> Format.pp_set_formatter_out_functions pp out_functions) + ~f:(fun pp -> Format.pp_set_formatter_out_functions pp out_functions) pps; match f () with | x -> restore (); x @@ -234,7 +234,7 @@ let eval_expect_file _fname ~file_contents = acc && let snap = Btype.snapshot () in try - exec_phrase ppf phrase + Sys.with_async_exns (fun () -> exec_phrase ppf phrase) with exn -> let bt = Printexc.get_raw_backtrace () in begin try Location.report_exception ppf exn @@ -336,7 +336,8 @@ let main fname = end; Compmisc.init_path (); Toploop.initialize_toplevel_env (); - Sys.interactive := false; + (* We are in interactive mode and should record directive error on stdout *) + Sys.interactive := true; process_expect_file fname; exit 0 diff --git a/testsuite/tools/parsecmm.mly b/testsuite/tools/parsecmm.mly index f7d9567e649..7bb491b23ca 100644 --- a/testsuite/tools/parsecmm.mly +++ b/testsuite/tools/parsecmm.mly @@ -182,6 +182,7 @@ fundecl: No_CSE; ] else [ Reduce_code_size ]; + fun_poll = Lambda.Default_poll; fun_dbg = debuginfo ()} } ; fun_name: diff --git a/tools/.ocamlformat b/tools/.ocamlformat index e1bfbf6dac9..dee3936e8b0 100644 --- a/tools/.ocamlformat +++ b/tools/.ocamlformat @@ -6,10 +6,11 @@ doc-comments=before dock-collection-brackets=false exp-grouping=preserve if-then-else=keyword-first +module-item-spacing=sparse parens-tuple=multi-line-only sequence-blank-line=compact space-around-lists=false space-around-variants=false type-decl=sparse wrap-comments=true -version=0.19.0 +version=0.24.1 diff --git a/tools/flambda_backend_objinfo.ml b/tools/flambda_backend_objinfo.ml index ce53bae2afd..0ec6aebcb13 100644 --- a/tools/flambda_backend_objinfo.ml +++ b/tools/flambda_backend_objinfo.ml @@ -15,18 +15,25 @@ (* *) (**************************************************************************) -(* Dump info on .cmi, .cmo, .cmx, .cma, .cmxa, .cmxs files - and on bytecode executables. *) +(* CR-someday lmaurer: This file should do no parsing or low-level binary I/O + _whatsoever_. No magic numbers, no sections, and _especially_ no + [input_value]. Any such code here is necessarily duplicated code, and worse, + particularly fiddly duplicated code that segfaults rather than producing + compile-time errors. *) + +(* Dump info on .cmi, .cmo, .cmx, .cma, .cmxa, .cmxs files and on bytecode + executables. *) open Printf open Misc open Cmo_format -(* Command line options to prevent printing approximation, - function code and CRC - *) +(* Command line options to prevent printing approximation, function code and + CRC *) let no_approx = ref false + let no_code = ref false + let no_crc = ref false module Magic_number = Misc.Magic_number @@ -35,55 +42,65 @@ module String = Misc.Stdlib.String let input_stringlist ic len = let get_string_list sect len = let rec fold s e acc = - if e != len then - if sect.[e] = '\000' then - fold (e+1) (e+1) (String.sub sect s (e-s) :: acc) - else fold s (e+1) acc + if e != len + then + if sect.[e] = '\000' + then fold (e + 1) (e + 1) (String.sub sect s (e - s) :: acc) + else fold s (e + 1) acc else acc - in fold 0 0 [] + in + fold 0 0 [] in let sect = really_input_string ic len in get_string_list sect len let dummy_crc = String.make 32 '-' + let null_crc = String.make 32 '0' let string_of_crc crc = if !no_crc then null_crc else Digest.to_hex crc -let print_name_crc (name, crco) = +let print_name_crc name crco = let crc = - match crco with - None -> dummy_crc - | Some crc -> string_of_crc crc + match crco with None -> dummy_crc | Some crc -> string_of_crc crc in - printf "\t%s\t%s\n" crc name + printf "\t%s\t%a\n" crc Compilation_unit.Name.output name + +(* CR-someday mshinwell: consider moving to [Import_info.print] *) + +let print_intf_import import = + let name = Import_info.name import in + let crco = Import_info.crc import in + print_name_crc name crco -let print_line name = - printf "\t%s\n" name +let print_impl_import import = + let unit = Import_info.cu import in + let crco = Import_info.crc import in + print_name_crc (Compilation_unit.name unit) crco + +let print_line name = printf "\t%s\n" name let print_name_line cu = printf "\t%a\n" Compilation_unit.Name.output (Compilation_unit.name cu) -let print_required_global id = - printf "\t%s\n" (Ident.name id) +let print_required_global id = printf "\t%a\n" Compilation_unit.output id let print_cmo_infos cu = - printf "Unit name: %a\n" Compilation_unit.Name.output cu.cu_name; + printf "Unit name: %a\n" Compilation_unit.output cu.cu_name; print_string "Interfaces imported:\n"; - List.iter print_name_crc cu.cu_imports; + Array.iter print_intf_import cu.cu_imports; print_string "Required globals:\n"; List.iter print_required_global cu.cu_required_globals; printf "Uses unsafe features: "; (match cu.cu_primitives with - | [] -> printf "no\n" - | l -> - printf "YES\n"; - printf "Primitives declared in this module:\n"; - List.iter print_line l); + | [] -> printf "no\n" + | l -> + printf "YES\n"; + printf "Primitives declared in this module:\n"; + List.iter print_line l); printf "Force link: %s\n" (if cu.cu_force_link then "YES" else "no") -let print_spaced_string s = - printf " %s" s +let print_spaced_string s = printf " %s" s let print_cma_infos (lib : Cmo_format.library) = printf "Force custom: %s\n" (if lib.lib_custom then "YES" else "no"); @@ -99,17 +116,17 @@ let print_cma_infos (lib : Cmo_format.library) = List.iter print_cmo_infos lib.lib_units let print_cmi_infos name crcs = - printf "Unit name: %s\n" name; + printf "Unit name: %a\n" Compilation_unit.output name; printf "Interfaces imported:\n"; - List.iter print_name_crc crcs + Array.iter print_intf_import crcs let print_cmt_infos cmt = let open Cmt_format in - printf "Cmt unit name: %s\n" cmt.cmt_modname; + printf "Cmt unit name: %a\n" Compilation_unit.output cmt.cmt_modname; print_string "Cmt interfaces imported:\n"; - List.iter print_name_crc cmt.cmt_imports; + Array.iter print_intf_import cmt.cmt_imports; printf "Source file: %s\n" - (match cmt.cmt_sourcefile with None -> "(none)" | Some f -> f); + (match cmt.cmt_sourcefile with None -> "(none)" | Some f -> f); printf "Compilation flags:"; Array.iter print_spaced_string cmt.cmt_args; printf "\nLoad path:"; @@ -117,8 +134,8 @@ let print_cmt_infos cmt = printf "\n"; printf "cmt interface digest: %s\n" (match cmt.cmt_interface_digest with - | None -> "" - | Some crc -> string_of_crc crc) + | None -> "" + | Some crc -> string_of_crc crc) let print_general_infos print_name name crc defines iter_cmi iter_cmx = printf "Name: %a\n" print_name name; @@ -126,15 +143,13 @@ let print_general_infos print_name name crc defines iter_cmi iter_cmx = printf "Globals defined:\n"; List.iter print_name_line defines; printf "Interfaces imported:\n"; - iter_cmi print_name_crc; + iter_cmi print_intf_import; printf "Implementations imported:\n"; - iter_cmx print_name_crc + iter_cmx print_impl_import let print_global_table table = printf "Globals defined:\n"; - Symtable.iter_global_map - (fun id _ -> print_line (Ident.name id)) - table + Symtable.iter_global_map (fun id _ -> print_line (Ident.name id)) table open Cmx_format open Cmxs_format @@ -142,52 +157,59 @@ open Cmxs_format let print_generic_fns gfns = let pr_afuns _ fns = let mode = function Lambda.Alloc_heap -> "" | Lambda.Alloc_local -> "L" in - List.iter (fun (arity,m) -> printf " %d%s" arity (mode m)) fns in + List.iter (fun (arity, m) -> printf " %d%s" arity (mode m)) fns + in let pr_cfuns _ fns = - List.iter (function - | (Lambda.Curried {nlocal},a) -> printf " %dL%d" a nlocal - | (Lambda.Tupled, a) -> printf " -%d" a) fns in + List.iter + (function + | Lambda.Curried { nlocal }, a -> printf " %dL%d" a nlocal + | Lambda.Tupled, a -> printf " -%d" a) + fns + in printf "Currying functions:%a\n" pr_cfuns gfns.curry_fun; printf "Apply functions:%a\n" pr_afuns gfns.apply_fun; printf "Send functions:%a\n" pr_afuns gfns.send_fun - -let print_cmx_infos (ui, crc) = - print_general_infos Compilation_unit.output ui.ui_unit crc ui.ui_defines - (fun f -> List.iter f ui.ui_imports_cmi) - (fun f -> List.iter f ui.ui_imports_cmx); - begin match ui.ui_export_info with - | Clambda approx -> - if not !no_approx then begin - printf "Clambda approximation:\n"; - Format.fprintf Format.std_formatter " %a@." Printclambda.approx approx - end else - Format.printf "Clambda unit@."; - | Flambda1 export -> - if not !no_approx || not !no_code then - printf "Flambda export information:\n" - else - printf "Flambda unit\n"; - if not !no_approx then begin - Compilation_unit.set_current ui.ui_unit; - let root_symbols = List.map Symbol.for_compilation_unit ui.ui_defines in - Format.printf "approximations@ %a@.@." - Export_info.print_approx (export, root_symbols) - end; - if not !no_code then - Format.printf "functions@ %a@.@." - Export_info.print_functions export - | Flambda2 None -> - printf "Flambda 2 unit (with no export information)\n" - | Flambda2 (Some cmx) -> - printf "Flambda 2 export information:\n"; - flush stdout; - Format.printf "%a\n%!" Flambda2_cmx.Flambda_cmx_format.print cmx +let print_cmx_infos (uir, sections, crc) = + print_general_infos Compilation_unit.output uir.uir_unit crc uir.uir_defines + (fun f -> Array.iter f uir.uir_imports_cmi) + (fun f -> Array.iter f uir.uir_imports_cmx); + begin + match uir.uir_export_info with + | Clambda_raw approx -> + if not !no_approx + then begin + printf "Clambda approximation:\n"; + Format.fprintf Format.std_formatter " %a@." Printclambda.approx approx + end + else Format.printf "Clambda unit@." + | Flambda1_raw export -> + if (not !no_approx) || not !no_code + then printf "Flambda export information:\n" + else printf "Flambda unit\n"; + if not !no_approx + then begin + Compilation_unit.set_current (Some uir.uir_unit); + let root_symbols = + List.map Symbol.for_compilation_unit uir.uir_defines + in + Format.printf "approximations@ %a@.@." Export_info.print_approx + (export, root_symbols) + end; + if not !no_code + then Format.printf "functions@ %a@.@." Export_info.print_functions export + | Flambda2_raw None -> + printf "Flambda 2 unit (with no export information)\n" + | Flambda2_raw (Some cmx) -> + printf "Flambda 2 export information:\n"; + flush stdout; + let cmx = Flambda2_cmx.Flambda_cmx_format.from_raw cmx ~sections in + Format.printf "%a\n%!" Flambda2_cmx.Flambda_cmx_format.print cmx end; - print_generic_fns ui.ui_generic_fns; - printf "Force link: %s\n" (if ui.ui_force_link then "YES" else "no"); + print_generic_fns uir.uir_generic_fns; + printf "Force link: %s\n" (if uir.uir_force_link then "YES" else "no"); printf "Functions with neither allocations nor indirect calls:\n"; - String.Set.iter print_line ui.ui_checks.ui_noalloc_functions + String.Set.iter print_line uir.uir_checks.ui_noalloc_functions let print_cmxa_infos (lib : Cmx_format.library_infos) = printf "Extra C object files:"; @@ -197,37 +219,32 @@ let print_cmxa_infos (lib : Cmx_format.library_infos) = printf "\n"; print_generic_fns lib.lib_generic_fns; let module B = Misc.Bitmap in - lib.lib_units |> List.iter (fun u -> - print_general_infos Compilation_unit.output u.li_name u.li_crc u.li_defines - (fun f -> B.iter (fun i -> f lib.lib_imports_cmi.(i)) u.li_imports_cmi) - (fun f -> B.iter (fun i -> f lib.lib_imports_cmx.(i)) u.li_imports_cmx); - printf "Force link: %s\n" (if u.li_force_link then "YES" else "no")) + lib.lib_units + |> List.iter (fun u -> + print_general_infos Compilation_unit.output u.li_name u.li_crc + u.li_defines + (fun f -> + B.iter (fun i -> f lib.lib_imports_cmi.(i)) u.li_imports_cmi) + (fun f -> + B.iter (fun i -> f lib.lib_imports_cmx.(i)) u.li_imports_cmx); + printf "Force link: %s\n" (if u.li_force_link then "YES" else "no")) let print_cmxs_infos header = List.iter (fun ui -> - print_general_infos - Compilation_unit.Name.output - ui.dynu_name - ui.dynu_crc - ui.dynu_defines - (fun f -> List.iter f ui.dynu_imports_cmi) - (fun f -> List.iter f ui.dynu_imports_cmx)) + print_general_infos Compilation_unit.output ui.dynu_name ui.dynu_crc + ui.dynu_defines + (fun f -> Array.iter f ui.dynu_imports_cmi) + (fun f -> Array.iter f ui.dynu_imports_cmx)) header.dynu_units let p_title title = printf "%s:\n" title -let p_section title = function - | [] -> () - | l -> - p_title title; - List.iter print_name_crc l - let p_list title print = function | [] -> () | l -> - p_title title; - List.iter print l + p_title title; + List.iter print l let dump_byte ic = Bytesections.read_toc ic; @@ -235,187 +252,180 @@ let dump_byte ic = let toc = List.sort Stdlib.compare toc in List.iter (fun (section, _) -> - try - let len = Bytesections.seek_section ic section in - if len > 0 then match section with - | "CRCS" -> - p_section - "Imported units" - (input_value ic : (string * Digest.t option) list) - | "DLLS" -> - p_list - "Used DLLs" - print_line - (input_stringlist ic len) - | "DLPT" -> - p_list - "Additional DLL paths" - print_line - (input_stringlist ic len) - | "PRIM" -> - p_list - "Primitives used" - print_line - (input_stringlist ic len) - | "SYMB" -> - print_global_table (input_value ic) - | _ -> () - with _ -> () - ) + try + let len = Bytesections.seek_section ic section in + if len > 0 + then + match section with + | "CRCS" -> + p_list "Imported units" print_intf_import + ((input_value ic : Import_info.t array) |> Array.to_list) + | "DLLS" -> p_list "Used DLLs" print_line (input_stringlist ic len) + | "DLPT" -> + p_list "Additional DLL paths" print_line (input_stringlist ic len) + | "PRIM" -> + p_list "Primitives used" print_line (input_stringlist ic len) + | "SYMB" -> print_global_table (input_value ic) + | _ -> () + with _ -> ()) toc let find_dyn_offset filename = match Binutils.read filename with - | Ok t -> - Binutils.symbol_offset t "caml_plugin_header" - | Error _ -> - None + | Ok t -> Binutils.symbol_offset t "caml_plugin_header" + | Error _ -> None + +let exit_err msg = + print_endline msg; + exit 2 -let exit_err msg = print_endline msg; exit 2 let exit_errf fmt = Printf.ksprintf exit_err fmt let exit_magic_msg msg = exit_errf - "Wrong magic number:\n\ - this tool only supports object files produced by compiler version\n\ - \t%s\n\ - %s" + "Wrong magic number:\n\ + this tool only supports object files produced by compiler version\n\ + \t%s\n\ + %s" Sys.ocaml_version msg let exit_magic_error ~expected_kind err = - exit_magic_msg Magic_number.(match err with - | Parse_error err -> explain_parse_error expected_kind err - | Unexpected_error err -> explain_unexpected_error err) - -(* assume that 'ic' is already positioned at the right place - depending on the format (usually right after the magic number, - but Exec and Cmxs differ) *) + exit_magic_msg + Magic_number.( + match err with + | Parse_error err -> explain_parse_error expected_kind err + | Unexpected_error err -> explain_unexpected_error err) + +(* assume that 'ic' is already positioned at the right place depending on the + format (usually right after the magic number, but Exec and Cmxs differ) *) let dump_obj_by_kind filename ic obj_kind = let open Magic_number in match obj_kind with - | Cmo -> - let cu_pos = input_binary_int ic in - seek_in ic cu_pos; - let cu = input_value ic in - close_in ic; - print_cmo_infos cu - | Cma -> - let toc_pos = input_binary_int ic in - seek_in ic toc_pos; - let toc = (input_value ic : library) in - close_in ic; - print_cma_infos toc - | Cmi | Cmt -> - close_in ic; - let cmi, cmt = Cmt_format.read filename in - begin match cmi with - | None -> () - | Some cmi -> - print_cmi_infos cmi.Cmi_format.cmi_name cmi.Cmi_format.cmi_crcs - end; - begin match cmt with - | None -> () - | Some cmt -> print_cmt_infos cmt - end - | Cmx _config -> - let ui = (input_value ic : unit_infos) in - let crc = Digest.input ic in - close_in ic; - print_cmx_infos (ui, crc) - | Cmxa _config -> - let li = (input_value ic : library_infos) in - close_in ic; - print_cmxa_infos li - | Exec -> - (* no assumptions on [ic] position, - [dump_byte] will seek at the right place *) - dump_byte ic; - close_in ic - | Cmxs -> - (* we assume we are at the offset of the dynamic information, - as returned by [find_dyn_offset]. *) - let header = (input_value ic : dynheader) in - close_in ic; - print_cmxs_infos header; - | Ast_impl | Ast_intf -> - exit_errf "The object file type %S \ - is currently unsupported by this tool." - (human_name_of_kind obj_kind) + | Cmo -> + let cu_pos = input_binary_int ic in + seek_in ic cu_pos; + let cu = input_value ic in + close_in ic; + print_cmo_infos cu + | Cma -> + let toc_pos = input_binary_int ic in + seek_in ic toc_pos; + let toc = (input_value ic : library) in + close_in ic; + print_cma_infos toc + | Cmi | Cmt -> + close_in ic; + let cmi, cmt = Cmt_format.read filename in + begin + match cmi with + | None -> () + | Some cmi -> + print_cmi_infos cmi.Cmi_format.cmi_name cmi.Cmi_format.cmi_crcs + end; + begin + match cmt with None -> () | Some cmt -> print_cmt_infos cmt + end + | Cmx _config -> + let uir = (input_value ic : unit_infos_raw) in + let first_section_offset = pos_in ic in + seek_in ic (first_section_offset + uir.uir_sections_length); + let crc = Digest.input ic in + (* This consumes ic *) + let sections = Flambda_backend_utils.File_sections.create + uir.uir_section_toc filename ic ~first_section_offset in + print_cmx_infos (uir, sections, crc) + | Cmxa _config -> + let li = (input_value ic : library_infos) in + close_in ic; + print_cmxa_infos li + | Exec -> + (* no assumptions on [ic] position, [dump_byte] will seek at the right + place *) + dump_byte ic; + close_in ic + | Cmxs -> + (* we assume we are at the offset of the dynamic information, as returned by + [find_dyn_offset]. *) + let header = (input_value ic : dynheader) in + close_in ic; + print_cmxs_infos header + | Ast_impl | Ast_intf -> + exit_errf "The object file type %S is currently unsupported by this tool." + (human_name_of_kind obj_kind) let dump_obj filename = let open Magic_number in let dump_standard ic = match read_current_info ~expected_kind:None ic with - | Error ((Unexpected_error _) as err) -> - exit_magic_error ~expected_kind:None err - | Ok { kind; version = _ } -> - dump_obj_by_kind filename ic kind; - Ok () - | Error (Parse_error head_error) -> - Error head_error + | Error (Unexpected_error _ as err) -> + exit_magic_error ~expected_kind:None err + | Ok { kind; version = _ } -> + dump_obj_by_kind filename ic kind; + Ok () + | Error (Parse_error head_error) -> Error head_error and dump_exec ic = let pos_trailer = in_channel_length ic - Magic_number.magic_length in let _ = seek_in ic pos_trailer in let expected_kind = Some Exec in match read_current_info ~expected_kind ic with - | Error ((Unexpected_error _) as err) -> - exit_magic_error ~expected_kind err - | Ok _ -> - dump_obj_by_kind filename ic Exec; - Ok () - | Error (Parse_error _) -> - Error () + | Error (Unexpected_error _ as err) -> exit_magic_error ~expected_kind err + | Ok _ -> + dump_obj_by_kind filename ic Exec; + Ok () + | Error (Parse_error _) -> Error () and dump_cmxs ic = flush stdout; match find_dyn_offset filename with - | None -> - exit_errf "Unable to read info on %s %s." - (human_name_of_kind Cmxs) filename - | Some offset -> - LargeFile.seek_in ic offset; - let header = (input_value ic : dynheader) in - let expected_kind = Some Cmxs in - match parse header.dynu_magic with - | Error err -> - exit_magic_error ~expected_kind (Parse_error err) - | Ok info -> - match check_current Cmxs info with - | Error err -> - exit_magic_error ~expected_kind (Unexpected_error err) - | Ok () -> - LargeFile.seek_in ic offset; - dump_obj_by_kind filename ic Cmxs; - () + | None -> + exit_errf "Unable to read info on %s %s." (human_name_of_kind Cmxs) + filename + | Some offset -> ( + LargeFile.seek_in ic offset; + let header = (input_value ic : dynheader) in + let expected_kind = Some Cmxs in + match parse header.dynu_magic with + | Error err -> exit_magic_error ~expected_kind (Parse_error err) + | Ok info -> ( + match check_current Cmxs info with + | Error err -> exit_magic_error ~expected_kind (Unexpected_error err) + | Ok () -> + LargeFile.seek_in ic offset; + dump_obj_by_kind filename ic Cmxs; + ())) in printf "File %s\n" filename; let ic = open_in_bin filename in match dump_standard ic with - | Ok () -> () - | Error head_error -> - match dump_exec ic with + | Ok () -> () + | Error head_error -> ( + match dump_exec ic with | Ok () -> () | Error () -> - if Filename.check_suffix filename ".cmxs" - then dump_cmxs ic - else exit_magic_error ~expected_kind:None (Parse_error head_error) - -let arg_list = [ - "-no-approx", Arg.Set no_approx, - " Do not print module approximation information"; - "-no-code", Arg.Set no_code, - " Do not print code from exported flambda functions"; - "-null-crc", Arg.Set no_crc, " Print a null CRC for imported interfaces"; - "-args", Arg.Expand Arg.read_arg, - " Read additional newline separated command line arguments \n\ - \ from "; - "-args0", Arg.Expand Arg.read_arg0, - " Read additional NUL separated command line arguments from \n\ - \ "; -] + if Filename.check_suffix filename ".cmxs" + then dump_cmxs ic + else exit_magic_error ~expected_kind:None (Parse_error head_error)) + +let arg_list = + [ ( "-no-approx", + Arg.Set no_approx, + " Do not print module approximation information" ); + ( "-no-code", + Arg.Set no_code, + " Do not print code from exported flambda functions" ); + "-null-crc", Arg.Set no_crc, " Print a null CRC for imported interfaces"; + ( "-args", + Arg.Expand Arg.read_arg, + " Read additional newline separated command line arguments \n\ + \ from " ); + ( "-args0", + Arg.Expand Arg.read_arg0, + " Read additional NUL separated command line arguments from \n\ + \ " ) ] + let arg_usage = - Printf.sprintf "%s [OPTIONS] FILES : give information on files" Sys.argv.(0) + Printf.sprintf "%s [OPTIONS] FILES : give information on files" Sys.argv.(0) -let main() = +let main () = Arg.parse_expand arg_list dump_obj arg_usage; exit 0 diff --git a/tools/merge_archives.ml b/tools/merge_archives.ml index 30c4327f407..e86a37f2fc6 100644 --- a/tools/merge_archives.ml +++ b/tools/merge_archives.ml @@ -64,23 +64,25 @@ let merge_cmxa0 ~archives = cmxa_list |> List.iter (fun (lib : Cmx_format.library_infos) -> lib.lib_imports_cmi - |> Array.iter (fun (name, crc) -> + |> Array.iter (fun import -> + let name = Import_info.name import in if not (Hashtbl.mem cmi_table name) then begin - Hashtbl.add cmi_table name (crc, !ncmis); + Hashtbl.add cmi_table name (import, !ncmis); incr ncmis end); lib.lib_imports_cmx - |> Array.iter (fun (name, crc) -> - if not (Hashtbl.mem cmx_table name) + |> Array.iter (fun import -> + let cu = Import_info.cu import in + if not (Hashtbl.mem cmx_table cu) then begin - Hashtbl.add cmx_table name (crc, !ncmxs); + Hashtbl.add cmx_table cu (import, !ncmxs); incr ncmxs end)); - let cmis = Array.make !ncmis ("", None) in - Hashtbl.iter (fun name (crc, i) -> cmis.(i) <- name, crc) cmi_table; - let cmxs = Array.make !ncmxs ("", None) in - Hashtbl.iter (fun name (crc, i) -> cmxs.(i) <- name, crc) cmx_table; + let cmis = Array.make !ncmis Import_info.dummy in + Hashtbl.iter (fun name (import, i) -> cmis.(i) <- import) cmi_table; + let cmxs = Array.make !ncmxs Import_info.dummy in + Hashtbl.iter (fun name (import, i) -> cmxs.(i) <- import) cmx_table; let genfns = Cmm_helpers.Generic_fns_tbl.make () in let _, lib_units, lib_ccobjs, lib_ccopts = List.fold_left @@ -99,11 +101,12 @@ let merge_cmxa0 ~archives = then failwith "Archives contain multiply-defined units"; Cmm_helpers.Generic_fns_tbl.add genfns cmxa.lib_generic_fns; let lib_names = Compilation_unit.Set.union new_lib_names lib_names in - let remap oldarr newarr tbl oldb = + let remap oldarr newarr tbl oldb ~get_key = let module B = Misc.Bitmap in let b = B.make (Array.length newarr) in oldb - |> B.iter (fun i -> B.set b (snd (Hashtbl.find tbl (fst oldarr.(i))))); + |> B.iter (fun i -> + B.set b (snd (Hashtbl.find tbl (get_key oldarr.(i))))); b in let new_units = @@ -111,9 +114,11 @@ let merge_cmxa0 ~archives = (fun (li : Cmx_format.lib_unit_info) -> { li with li_imports_cmi = - remap cmxa.lib_imports_cmi cmis cmi_table li.li_imports_cmi; + remap cmxa.lib_imports_cmi cmis cmi_table li.li_imports_cmi + ~get_key:Import_info.name; li_imports_cmx = remap cmxa.lib_imports_cmx cmxs cmx_table li.li_imports_cmx + ~get_key:Import_info.cu }) cmxa.lib_units in diff --git a/utils/.ocamlformat b/utils/.ocamlformat new file mode 100644 index 00000000000..448b8f3be1a --- /dev/null +++ b/utils/.ocamlformat @@ -0,0 +1,15 @@ +# Please make a pull request to change this file. +# Keep this file in sync with other .ocamlformat files in this repo. +assignment-operator=begin-line +cases-exp-indent=2 +doc-comments=before +dock-collection-brackets=false +if-then-else=keyword-first +module-item-spacing=sparse +parens-tuple=multi-line-only +sequence-blank-line=compact +space-around-lists=false +space-around-variants=false +type-decl=sparse +wrap-comments=true +version=0.24.1 diff --git a/utils/dune b/utils/dune new file mode 100644 index 00000000000..24c62b121a2 --- /dev/null +++ b/utils/dune @@ -0,0 +1,7 @@ +(include_subdirs unqualified) + +(library + (name flambda_backend_utils) + (ocamlopt_flags + (:standard -O3)) + (libraries ocamlcommon)) diff --git a/utils/file_sections.ml b/utils/file_sections.ml new file mode 100644 index 00000000000..acbd9e17475 --- /dev/null +++ b/utils/file_sections.ml @@ -0,0 +1,129 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, Nathanaëlle Courant, OCamlPro *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2022 OCamlPro SAS *) +(* Copyright 2022 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +type section = + | Loaded of Obj.t + | Pending of { byte_offset_in_file : int } + +module File_lru_cache = Lru.Make (struct + type cached = in_channel + + type uncached = string + + let load = open_in_bin + + let unload _ ic = close_in ic +end) + +let file_lru = File_lru_cache.create ~capacity:128 + +let () = at_exit (fun () -> File_lru_cache.unload_all file_lru) + +type t = + | From_file of + { channel : File_lru_cache.slot; + sections : section array + } + | In_memory of Obj.t array + | Cat of int * t * t +(* For efficient concatenation *) + +let create section_toc file channel ~first_section_offset = + if Array.length section_toc = 0 + then ( + close_in channel; + In_memory [||]) + else + let channel = File_lru_cache.add_slot file channel file_lru in + let sections = + Array.map + (fun offset -> + Pending { byte_offset_in_file = offset + first_section_offset }) + section_toc + in + From_file { channel; sections } + +let empty = In_memory [||] + +let length = function + | From_file { sections; _ } -> Array.length sections + | In_memory sections -> Array.length sections + | Cat (length, _, _) -> length + +let read_section sections channel index = + match sections.(index) with + | Loaded section_contents -> section_contents + | Pending { byte_offset_in_file } -> + let channel = File_lru_cache.load_slot channel file_lru in + seek_in channel byte_offset_in_file; + let section_contents : Obj.t = input_value channel in + sections.(index) <- Loaded section_contents; + section_contents + +let rec unsafe_get t index = + match t with + | From_file { sections; channel } -> read_section sections channel index + | In_memory sections -> sections.(index) + | Cat (_, t1, t2) -> + let n = length t1 in + if index < n then unsafe_get t1 index else unsafe_get t2 (index - n) + +let get t index = + let len = length t in + if index < 0 || index >= len + then + Misc.fatal_errorf + "File_sections.get index out of bounds: index is %d, but length is %d" + index len; + unsafe_get t index + +let rec unsafe_blit_to_array t dest start_index = + match t with + | From_file { sections; channel } -> + for i = 0 to Array.length sections - 1 do + dest.(start_index + i) <- read_section sections channel i + done + | In_memory sections -> + Array.blit sections 0 dest start_index (Array.length sections) + | Cat (_, t1, t2) -> + unsafe_blit_to_array t1 dest start_index; + unsafe_blit_to_array t2 dest (start_index + length t1) + +let to_array t = + let dest = Array.make (length t) (Obj.repr 0) in + unsafe_blit_to_array t dest 0; + dest + +let from_array t = In_memory (Array.copy t) + +let concat t1 t2 = Cat (length t1 + length t2, t1, t2) + +let compute_toc serialized_sections = + let toc = Array.make (Array.length serialized_sections) 0 in + let length = ref 0 in + for i = 0 to Array.length serialized_sections - 1 do + toc.(i) <- !length; + length := !length + String.length serialized_sections.(i) + done; + toc, !length + +let serialize t = + let sections = to_array t in + let serialized_sections = + Array.map (fun section -> Marshal.to_string section []) sections + in + let toc, total_length = compute_toc serialized_sections in + serialized_sections, toc, total_length diff --git a/utils/file_sections.mli b/utils/file_sections.mli new file mode 100644 index 00000000000..8f58605a0df --- /dev/null +++ b/utils/file_sections.mli @@ -0,0 +1,35 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Pierre Chambart, Nathanaëlle Courant, OCamlPro *) +(* Mark Shinwell, Jane Street Europe *) +(* *) +(* Copyright 2022 OCamlPro SAS *) +(* Copyright 2022 Jane Street Group LLC *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** file sections cache *) + +type t + +val create : int array -> string -> in_channel -> first_section_offset:int -> t + +val empty : t + +val length : t -> int + +val get : t -> int -> Obj.t + +val to_array : t -> Obj.t array + +val serialize : t -> string array * int array * int + +val from_array : Obj.t array -> t + +val concat : t -> t -> t diff --git a/utils/lru.ml b/utils/lru.ml new file mode 100644 index 00000000000..74f93e61fb1 --- /dev/null +++ b/utils/lru.ml @@ -0,0 +1,136 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nathanaëlle Courant, OCamlPro *) +(* *) +(* Copyright 2022 OCamlPro SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +module type Lru_slot = sig + type uncached + + type cached + + val load : uncached -> cached + + val unload : uncached -> cached -> unit +end + +module type S = sig + type t + + type slot + + type uncached + + type cached + + val create : capacity:int -> t + + val add_slot : uncached -> cached -> t -> slot + + val load_slot : slot -> t -> cached + + val unload_all : t -> unit +end + +module Make (Slot : Lru_slot) : + S with type uncached = Slot.uncached and type cached = Slot.cached = struct + type cached = Slot.cached + + type uncached = Slot.uncached + + type slot = + { mutable previous : slot; + mutable next : slot; + data : uncached option; + mutable cached_data : cached option + } + + type t = + { mutable remaining_slots : int; + sentinel : slot + } + + let create ~capacity = + assert (capacity > 0); + let rec sentinel = + { previous = sentinel; next = sentinel; data = None; cached_data = None } + in + { remaining_slots = capacity; sentinel } + + let insert_after ~slot ~to_insert = + let slot2 = slot.next in + to_insert.previous <- slot; + to_insert.next <- slot2; + slot.next <- to_insert; + slot2.previous <- to_insert + + let extract slot = + slot.previous.next <- slot.next; + slot.next.previous <- slot.previous; + slot.previous <- slot; + slot.next <- slot + + let load_if_needed slot = + match slot.cached_data with + | Some cached_data -> cached_data + | None -> ( + match slot.data with + | Some data -> + let cached_data = Slot.load data in + slot.cached_data <- Some cached_data; + cached_data + | None -> Misc.fatal_error "lru.load_if_needed called on sentinel") + + let unload slot = + match slot.data, slot.cached_data with + | Some data, Some cached_data -> + Slot.unload data cached_data; + slot.cached_data <- None + | Some _, None -> () + | None, _ -> Misc.fatal_error "lru.unload called on sentinel" + + let unload_one t = + t.remaining_slots <- t.remaining_slots + 1; + let slot = t.sentinel.previous in + extract slot; + unload slot + + let make_room t = if t.remaining_slots = 0 then unload_one t + + let add_slot uncached cached t = + make_room t; + t.remaining_slots <- t.remaining_slots - 1; + let new_slot = + { previous = t.sentinel; + next = t.sentinel.next; + data = Some uncached; + cached_data = Some cached + } + in + t.sentinel.next.previous <- new_slot; + t.sentinel.next <- new_slot; + new_slot + + let load_slot slot t = + if slot.next == slot + then ( + (* This slot is currently outside the cache *) + make_room t; + t.remaining_slots <- t.remaining_slots - 1) + else extract slot; + insert_after ~slot:t.sentinel ~to_insert:slot; + load_if_needed slot + + let unload_all t = + while t.sentinel.previous != t.sentinel do + unload_one t + done +end diff --git a/utils/lru.mli b/utils/lru.mli new file mode 100644 index 00000000000..5b7a3dea9be --- /dev/null +++ b/utils/lru.mli @@ -0,0 +1,49 @@ +(**************************************************************************) +(* *) +(* OCaml *) +(* *) +(* Nathanaëlle Courant, OCamlPro *) +(* *) +(* Copyright 2022 OCamlPro SAS *) +(* *) +(* All rights reserved. This file is distributed under the terms of *) +(* the GNU Lesser General Public License version 2.1, with the *) +(* special exception on linking described in the file LICENSE. *) +(* *) +(**************************************************************************) + +(** Implementation of an LRU cache. Each slot of the cache is specified by an + [uncached] type and a [cached] type. The [uncached] type corresponds to the + information from which the [cached] information is derived. The cache + ensures that at most [capacity] slots are loaded at each point in time. *) + +module type Lru_slot = sig + type uncached + + type cached + + val load : uncached -> cached + + val unload : uncached -> cached -> unit +end + +module type S = sig + type t + + type slot + + type uncached + + type cached + + val create : capacity:int -> t + + val add_slot : uncached -> cached -> t -> slot + + val load_slot : slot -> t -> cached + + val unload_all : t -> unit +end + +module Make (Slot : Lru_slot) : + S with type uncached = Slot.uncached and type cached = Slot.cached