diff --git a/.github/workflows/ci-cheri.yml b/.github/workflows/ci-cheri.yml new file mode 100644 index 000000000..479694e01 --- /dev/null +++ b/.github/workflows/ci-cheri.yml @@ -0,0 +1,58 @@ +name: CHERI + +on: + pull_request: + push: + branches: + - master + - cheri-tests + +env: + CERBERUS_IMAGE_ID: ghcr.io/rems-project/cerberus/cn:release + +# cancel in-progress job when a new push is performed +concurrency: + group: ci-${{ github.workflow }}-${{ github.ref }} + cancel-in-progress: true + +jobs: + build: + strategy: + matrix: + # version: [4.12.0, 4.14.1] + version: [4.14.1] + + + runs-on: ubuntu-22.04 + + steps: + - uses: actions/checkout@v3 + + - name: System dependencies (ubuntu) + run: | + sudo apt-get install build-essential libgmp-dev opam + + - name: Restore cached opam + id: cache-opam-restore + uses: actions/cache/restore@v4 + with: + path: ~/.opam + key: ${{ matrix.version }} + fail-on-cache-miss: true + + - name: Install Cerberus-CHERI + if: ${{ matrix.version == '4.14.1' }} + run: | + opam switch with_coq + eval $(opam env --switch=with_coq) + opam pin --yes --no-action add cerberus-lib . + opam pin --yes --no-action add cerberus-cheri . + opam install --yes cerberus-cheri + + - name: Run Cerberus-CHERI CI tests + if: ${{ matrix.version == '4.14.1' }} + run: | + opam switch with_coq + eval $(opam env --switch=with_coq) + cd tests; USE_OPAM='' ./run-cheri.sh + cd .. diff --git a/.github/workflows/ci-bench.yml b/.github/workflows/ci-cn-bench.yml similarity index 62% rename from .github/workflows/ci-bench.yml rename to .github/workflows/ci-cn-bench.yml index 557390545..d7111a663 100644 --- a/.github/workflows/ci-bench.yml +++ b/.github/workflows/ci-cn-bench.yml @@ -1,4 +1,4 @@ -name: CI Benchmarks +name: CN Benchmarks on: push: @@ -35,7 +35,7 @@ jobs: - name: System dependencies (ubuntu) run: | - sudo apt install build-essential libgmp-dev z3 opam cmake jq + sudo apt-get install build-essential libgmp-dev z3 opam jq - name: Restore cached opam id: cache-opam-restore @@ -43,28 +43,7 @@ jobs: with: path: ~/.opam key: ${{ matrix.version }} - - - name: Setup opam - if: steps.cache-opam-restore.outputs.cache-hit != 'true' - run: | - opam init --yes --no-setup --shell=sh --compiler=${{ matrix.version }} - opam install --deps-only --yes ./cerberus-lib.opam - opam switch create with_coq ${{ matrix.version }} - eval $(opam env --switch=with_coq) - opam repo add --yes --this-switch coq-released https://coq.inria.fr/opam/released - opam pin --yes -n coq-struct-tact https://github.com/uwplse/StructTact.git - opam repo add --yes --this-switch iris-dev https://gitlab.mpi-sws.org/iris/opam.git - opam pin --yes -n coq-sail-stdpp https://github.com/rems-project/coq-sail.git#f319aad - opam pin --yes -n coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git - opam install --deps-only --yes ./cerberus-lib.opam ./cerberus-cheri.opam - - - name: Save cached opam - if: steps.cache-opam-restore.outputs.cache-hit != 'true' - id: cache-opam-save - uses: actions/cache/save@v4 - with: - path: ~/.opam - key: ${{ steps.cache-opam-restore.outputs.cache-primary-key }} + fail-on-cache-miss: true - name: Install Cerberus run: | @@ -78,14 +57,14 @@ jobs: uses: robinraju/release-downloader@v1 with: repository: cvc5/cvc5 - tag: cvc5-1.1.2 - fileName: cvc5-Linux-static.zip + tag: cvc5-1.2.0 + fileName: cvc5-Linux-x86_64-static.zip - name: Unzip and install cvc5 run: | - unzip cvc5-Linux-static.zip - chmod +x cvc5-Linux-static/bin/cvc5 - sudo cp cvc5-Linux-static/bin/cvc5 /usr/local/bin/ + unzip cvc5-Linux-x86_64-static.zip + chmod +x cvc5-Linux-x86_64-static/bin/cvc5 + sudo cp cvc5-Linux-x86_64-static/bin/cvc5 /usr/local/bin/ - name: Install CN run: | diff --git a/.github/workflows/ci-runtime.yml b/.github/workflows/ci-cn-spec-testing.yml similarity index 60% rename from .github/workflows/ci-runtime.yml rename to .github/workflows/ci-cn-spec-testing.yml index b193008a4..0bcdb4d74 100644 --- a/.github/workflows/ci-runtime.yml +++ b/.github/workflows/ci-cn-spec-testing.yml @@ -1,11 +1,10 @@ -name: CI (CN runtime checks) +name: CN Spec Testing on: pull_request: push: branches: - master - - cheri-tests env: CERBERUS_IMAGE_ID: ghcr.io/rems-project/cerberus/cn:release @@ -32,7 +31,7 @@ jobs: - name: System dependencies (ubuntu) run: | - sudo apt install build-essential libgmp-dev z3 opam cmake + sudo apt-get install build-essential libgmp-dev z3 opam cmake lcov - name: Restore cached opam id: cache-opam-restore @@ -40,28 +39,7 @@ jobs: with: path: ~/.opam key: ${{ matrix.version }} - - - name: Setup opam - if: steps.cache-opam-restore.outputs.cache-hit != 'true' - run: | - opam init --yes --no-setup --shell=sh --compiler=${{ matrix.version }} - opam install --deps-only --yes ./cerberus-lib.opam - opam switch create with_coq ${{ matrix.version }} - eval $(opam env --switch=with_coq) - opam repo add --yes --this-switch coq-released https://coq.inria.fr/opam/released - opam pin --yes -n coq-struct-tact https://github.com/uwplse/StructTact.git - opam repo add --yes --this-switch iris-dev https://gitlab.mpi-sws.org/iris/opam.git - opam pin --yes -n coq-sail-stdpp https://github.com/rems-project/coq-sail.git#f319aad - opam pin --yes -n coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git - opam install --deps-only --yes ./cerberus-lib.opam ./cerberus-cheri.opam - - - name: Save cached opam - if: steps.cache-opam-restore.outputs.cache-hit != 'true' - id: cache-opam-save - uses: actions/cache/save@v4 - with: - path: ~/.opam - key: ${{ steps.cache-opam-restore.outputs.cache-primary-key }} + fail-on-cache-miss: true - name: Install Cerberus run: | @@ -97,3 +75,10 @@ jobs: eval $(opam env --switch=${{ matrix.version }}) cd cn-tutorial; ./runtime-test.sh cd .. + + - name: Run CN-Test-Gen CI tests + run: | + opam switch ${{ matrix.version }} + eval $(opam env --switch=${{ matrix.version }}) + cd tests; ./run-cn-test-gen.sh + diff --git a/.github/workflows/ci-cn.yml b/.github/workflows/ci-cn.yml new file mode 100644 index 000000000..01d91eec8 --- /dev/null +++ b/.github/workflows/ci-cn.yml @@ -0,0 +1,98 @@ +name: CN Proof + +on: + pull_request: + push: + branches: + - master + +env: + CERBERUS_IMAGE_ID: ghcr.io/rems-project/cerberus/cn:release + +# cancel in-progress job when a new push is performed +concurrency: + group: ci-${{ github.workflow }}-${{ github.ref }} + cancel-in-progress: true + +jobs: + build: + strategy: + matrix: + # version: [4.12.0, 4.14.1] + version: [4.14.1] + + + runs-on: ubuntu-22.04 + + steps: + - uses: actions/checkout@v3 + + - name: System dependencies (ubuntu) + run: | + sudo apt-get install build-essential libgmp-dev z3 opam + + - name: Restore cached opam + id: cache-opam-restore + uses: actions/cache/restore@v4 + with: + path: ~/.opam + key: ${{ matrix.version }} + fail-on-cache-miss: true + + - name: Install Cerberus + run: | + opam switch ${{ matrix.version }} + eval $(opam env --switch=${{ matrix.version }}) + opam pin --yes --no-action add cerberus-lib . + opam pin --yes --no-action add cerberus . + opam install --yes cerberus + + - name: Download cvc5 release + uses: robinraju/release-downloader@v1 + with: + repository: cvc5/cvc5 + tag: cvc5-1.2.0 + fileName: cvc5-Linux-x86_64-static.zip + + - name: Unzip and install cvc5 + run: | + unzip cvc5-Linux-x86_64-static.zip + chmod +x cvc5-Linux-x86_64-static/bin/cvc5 + sudo cp cvc5-Linux-x86_64-static/bin/cvc5 /usr/local/bin/ + + - name: Install CN + run: | + opam switch ${{ matrix.version }} + eval $(opam env --switch=${{ matrix.version }}) + opam pin --yes --no-action add cn . + opam install --yes cn ocamlformat.0.26.2 + + - name: Check CN code formatting + run: | + opam switch ${{ matrix.version }} + eval $(opam env --switch=${{ matrix.version }}) + cd backend/cn && dune build @fmt + + - name: Checkout cn-tutorial + uses: actions/checkout@v4 + with: + repository: rems-project/cn-tutorial + path: cn-tutorial + + - name: Run CN tests + run: | + opam switch ${{ matrix.version }} + eval $(opam env --switch=${{ matrix.version }}) + ./tests/diff-prog.py cn tests/cn/verify.json 2> diff.patch || (cat diff.patch; exit 1) + + - name: Run CN Tutorial tests + run: | + opam switch ${{ matrix.version }} + eval $(opam env --switch=${{ matrix.version }}) + tests/run-cn-tutorial-ci.sh cn-tutorial + + - name: Run CN VIP tests + run: | + opam switch ${{ matrix.version }} + eval $(opam env --switch=${{ matrix.version }}) + tests/run-cn-vip.sh diff --git a/.github/workflows/ci-pr-bench.yml.disabled b/.github/workflows/ci-pr-bench.yml.disabled index aef43678c..866ba4a68 100644 --- a/.github/workflows/ci-pr-bench.yml.disabled +++ b/.github/workflows/ci-pr-bench.yml.disabled @@ -45,28 +45,7 @@ jobs: with: path: ~/.opam key: ${{ matrix.version }} - - - name: Setup opam - if: steps.cache-opam-restore.outputs.cache-hit != 'true' - run: | - opam init --yes --no-setup --shell=sh --compiler=${{ matrix.version }} - opam install --deps-only --yes ./cerberus-lib.opam - opam switch create with_coq ${{ matrix.version }} - eval $(opam env --switch=with_coq) - opam repo add --yes --this-switch coq-released https://coq.inria.fr/opam/released - opam pin --yes -n coq-struct-tact https://github.com/uwplse/StructTact.git - opam repo add --yes --this-switch iris-dev https://gitlab.mpi-sws.org/iris/opam.git - opam pin --yes -n coq-sail-stdpp https://github.com/rems-project/coq-sail.git#f319aad - opam pin --yes -n coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git - opam install --deps-only --yes ./cerberus-lib.opam ./cerberus-cheri.opam - - - name: Save cached opam - if: steps.cache-opam-restore.outputs.cache-hit != 'true' - id: cache-opam-save - uses: actions/cache/save@v4 - with: - path: ~/.opam - key: ${{ steps.cache-opam-restore.outputs.cache-primary-key }} + fail-on-cache-miss: true - name: Install python dependencies run: pip install tabulate @@ -83,14 +62,14 @@ jobs: uses: robinraju/release-downloader@v1 with: repository: cvc5/cvc5 - tag: cvc5-1.1.2 - fileName: cvc5-Linux-static.zip + tag: cvc5-1.2.0 + fileName: cvc5-Linux-x86_64-static.zip - name: Unzip and install cvc5 run: | - unzip cvc5-Linux-static.zip - chmod +x cvc5-Linux-static/bin/cvc5 - sudo cp cvc5-Linux-static/bin/cvc5 /usr/local/bin/ + unzip cvc5-Linux-x86_64-static.zip + chmod +x cvc5-Linux-x86_64-static/bin/cvc5 + sudo cp cvc5-Linux-x86_64-static/bin/cvc5 /usr/local/bin/ - name: Install CN run: | @@ -111,7 +90,7 @@ jobs: run: | opam switch ${{ matrix.version }} eval $(opam env --switch=${{ matrix.version }}) - cd tests; USE_OPAM='' ./run-ci-benchmarks.sh + cd tests; ./run-ci-benchmarks.sh mv benchmark-data.json ${{ env.PR_DATA }} cd .. @@ -138,7 +117,7 @@ jobs: run: | opam switch ${{ matrix.version }} eval $(opam env --switch=${{ matrix.version }}) - cd tests; USE_OPAM='' ./run-ci-benchmarks.sh; mv benchmark-data.json ${{ env.BASE_DATA }} + cd tests; ./run-ci-benchmarks.sh; mv benchmark-data.json ${{ env.BASE_DATA }} cd .. - name: Compare results diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 1af812990..7a6086bfb 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -30,7 +30,7 @@ jobs: - name: System dependencies (ubuntu) run: | - sudo apt install build-essential libgmp-dev z3 opam cmake + sudo apt-get install build-essential libgmp-dev z3 opam cmake - name: Restore cached opam id: cache-opam-restore @@ -50,7 +50,7 @@ jobs: opam pin --yes -n coq-struct-tact https://github.com/uwplse/StructTact.git opam repo add --yes --this-switch iris-dev https://gitlab.mpi-sws.org/iris/opam.git opam pin --yes -n coq-sail-stdpp https://github.com/rems-project/coq-sail.git#f319aad - opam pin --yes -n coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git + opam pin --yes -n coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git#2f02c44ad061d4da30136dc9dbc06c142c94fdaf opam install --deps-only --yes ./cerberus-lib.opam ./cerberus-cheri.opam - name: Save cached opam @@ -74,80 +74,3 @@ jobs: opam switch ${{ matrix.version }} eval $(opam env --switch=${{ matrix.version }}) cd tests; USE_OPAM='' ./run-ci.sh - cd .. - - - name: Download cvc5 release - uses: robinraju/release-downloader@v1 - with: - repository: cvc5/cvc5 - tag: cvc5-1.1.2 - fileName: cvc5-Linux-static.zip - - - name: Unzip and install cvc5 - run: | - unzip cvc5-Linux-static.zip - chmod +x cvc5-Linux-static/bin/cvc5 - sudo cp cvc5-Linux-static/bin/cvc5 /usr/local/bin/ - - - name: Install CN - run: | - opam switch ${{ matrix.version }} - eval $(opam env --switch=${{ matrix.version }}) - opam pin --yes --no-action add cn . - opam install --yes cn ocamlformat.0.26.2 - - - name: Check CN code formatting - run: | - opam switch ${{ matrix.version }} - eval $(opam env --switch=${{ matrix.version }}) - USE_OPAM='' cd backend/cn && dune build @fmt - - - name: Checkout cn-tutorial - uses: actions/checkout@v4 - with: - repository: rems-project/cn-tutorial - path: cn-tutorial - - - name: Run CN CI tests - run: | - opam switch ${{ matrix.version }} - eval $(opam env --switch=${{ matrix.version }}) - cd tests; USE_OPAM='' ./run-cn.sh - - - name: Run CN Tutorial CI tests - run: | - opam switch ${{ matrix.version }} - eval $(opam env --switch=${{ matrix.version }}) - USE_OPAM='' tests/run-cn-tutorial-ci.sh cn-tutorial - - - name: Run CN-Test-Gen CI tests - run: | - opam switch ${{ matrix.version }} - eval $(opam env --switch=${{ matrix.version }}) - cd tests; USE_OPAM='' ./run-cn-test-gen.sh - cd .. - - - name: Run CN VIP CI tests - run: | - opam switch ${{ matrix.version }} - eval $(opam env --switch=${{ matrix.version }}) - cd tests; USE_OPAM='' ./run-cn-vip.sh - cd .. - - - - name: Install Cerberus-CHERI - if: ${{ matrix.version == '4.14.1' }} - run: | - opam switch with_coq - eval $(opam env --switch=with_coq) - opam pin --yes --no-action add cerberus-lib . - opam pin --yes --no-action add cerberus-cheri . - opam install --yes cerberus-cheri - - - name: Run Cerberus-CHERI CI tests - if: ${{ matrix.version == '4.14.1' }} - run: | - opam switch with_coq - eval $(opam env --switch=with_coq) - cd tests; USE_OPAM='' ./run-cheri.sh - cd .. diff --git a/.github/workflows/docker.yml b/.github/workflows/docker.yml index b8c8fd90e..6104a323e 100644 --- a/.github/workflows/docker.yml +++ b/.github/workflows/docker.yml @@ -1,11 +1,17 @@ name: docker on: + # Run this action every day schedule: - cron: '30 18 * * *' + # Run this action any time any dockerfile changes + pull_request: + paths: + - 'Dockerfile.**' + - '**docker.yml' env: - CERBERUS_IMAGE_ID: ghcr.io/rems-project/cerberus/cn:release + CERBERUS_IMAGE_ID: ghcr.io/rems-project/cerberus/cn # Cancelling an in-progress job when a new push is performed causes the CI to # show up as failed: https://github.com/orgs/community/discussions/8336 @@ -15,12 +21,10 @@ concurrency: group: docker-${{ github.workflow }}-${{ github.ref }} cancel-in-progress: false +# Instructions from https://depot.dev/blog/multi-platform-docker-images-in-github-actions jobs: - deploy-docker: + docker-release-ubuntu: runs-on: ubuntu-latest - strategy: - matrix: - platform: [linux/amd64, linux/arm64] permissions: packages: write contents: read @@ -40,11 +44,61 @@ jobs: uses: docker/setup-qemu-action@v3 - name: Set up Docker Buildx uses: docker/setup-buildx-action@v3 - - name: Build the Docker image - run: | - echo "Building ${{env.CERBERUS_IMAGE_ID}}" - PLATFORM=${{ matrix.platform }} make -f Makefile_docker release_cn - docker tag cn:release ${{env.CERBERUS_IMAGE_ID}} - - name: Push the Docker image - run: docker push ${{env.CERBERUS_IMAGE_ID}} + - name: Build multi-platform image + uses: docker/build-push-action@v5 + with: + context: . + platforms: linux/amd64,linux/arm64 + push: ${{ github.event_name != 'pull_request' }} + tags: ${{env.CERBERUS_IMAGE_ID}}:release + file: Dockerfile.ubuntu + github-token: ${{ secrets.GITHUB_TOKEN }} + + docker-release-redhat: + runs-on: ubuntu-latest + permissions: + packages: write + contents: read + attestations: write + id-token: write + steps: + - uses: actions/checkout@v4 + + - name: Login to GitHub Container Registry + uses: docker/login-action@v3 + with: + registry: ghcr.io + username: ${{ github.actor }} + password: ${{ secrets.GITHUB_TOKEN }} + + - name: Set up QEMU + uses: docker/setup-qemu-action@v3 + - name: Set up Docker Buildx + uses: docker/setup-buildx-action@v3 + + - name: Build multi-platform image + uses: docker/build-push-action@v5 + with: + context: . + platforms: linux/amd64,linux/arm64 + push: ${{ github.event_name != 'pull_request' }} + tags: ${{env.CERBERUS_IMAGE_ID}}:release-redhat + file: Dockerfile.redhat + attests: type=sbom + provenance: mode=max + github-token: ${{ secrets.GITHUB_TOKEN }} + + test-docker-images: + runs-on: ubuntu-latest + needs: [docker-release-redhat, docker-release-ubuntu] + strategy: + matrix: + tag: [release, release-redhat] + steps: + - uses: actions/checkout@v4 + + - name: Run CN CI tests + run: | + docker pull ${{env.CERBERUS_IMAGE_ID}}:${{ matrix.tag }} + docker run -v $PWD:/work -w /work ${{env.CERBERUS_IMAGE_ID}}:${{ matrix.tag }} bash tests/run-cn.sh diff --git a/Dockerfile.cheri b/Dockerfile.cheri index edf8e8249..56363687b 100644 --- a/Dockerfile.cheri +++ b/Dockerfile.cheri @@ -12,7 +12,7 @@ RUN opam repo add --yes --this-switch coq-released https://coq.inria.fr/opam/rel && opam repo add --yes --this-switch iris-dev https://gitlab.mpi-sws.org/iris/opam.git \ && opam pin --yes -n coq-struct-tact https://github.com/uwplse/StructTact.git \ && opam pin --yes -n coq-sail-stdpp https://github.com/rems-project/coq-sail.git#f319aad \ - && opam pin --yes -n coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git \ + && opam pin --yes -n coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git#2f02c44ad061d4da30136dc9dbc06c142c94fdaf \ && opam pin add -n --yes cerberus-lib https://github.com/rems-project/cerberus.git \ && opam pin add -n --yes cerberus https://github.com/rems-project/cerberus.git \ && opam pin add -n --yes cerberus-cheri https://github.com/rems-project/cerberus.git diff --git a/Dockerfile.dev-env b/Dockerfile.dev-env deleted file mode 100644 index 3b240c135..000000000 --- a/Dockerfile.dev-env +++ /dev/null @@ -1,15 +0,0 @@ -FROM cerberus:deps - -#COPY --chown=user1 . /home/opam/cerberus/ -#RUN eval `opam env` && \ -# cd /home/opam/cerberus/ && \ -# make && \ -# make install -#COPY --chown=user1 docker_entry_point.sh /home/user1/ -#RUN chmod +x docker_entry_point.sh -#WORKDIR /data - -RUN echo 'export PS1="[\u@docker] \W # "' >> /home/user1/.bashrc -RUN echo 'eval $(opam env)' >> /home/user1/.bashrc - -ENTRYPOINT ["bash"] diff --git a/Dockerfile.redhat b/Dockerfile.redhat new file mode 100644 index 000000000..b0dd7b231 --- /dev/null +++ b/Dockerfile.redhat @@ -0,0 +1,31 @@ +# Build a minimal cerberus release image +FROM redhat/ubi9:9.4 + +# Install system packages +RUN yum update -y && \ + yum install -y xz sudo gcc unzip \ + diffutils patch pkgconfig bzip2 \ + git perl wget ca-certificates \ + mpfr-devel gmp-devel m4 + +# Install OPAM +# See https://opam.ocaml.org/doc/1.2/Install.html +RUN curl -fsSL https://opam.ocaml.org/install.sh | sh + +ENV OPAMCONFIRMLEVEL=unsafe-yes +RUN opam init --disable-sandboxing + +ADD . /opt/cerberus +WORKDIR /opt/cerberus +RUN opam install --deps-only ./cerberus-lib.opam ./cn.opam +RUN opam install z3 + +RUN eval `opam env` \ + && make install_cn + +WORKDIR /opt + +COPY docker_entry_point.sh /opt/docker_entry_point.sh +RUN chmod +x /opt/docker_entry_point.sh +WORKDIR /data +ENTRYPOINT ["/opt/docker_entry_point.sh"] diff --git a/Dockerfile.release b/Dockerfile.release deleted file mode 100644 index 9645a6309..000000000 --- a/Dockerfile.release +++ /dev/null @@ -1,7 +0,0 @@ -FROM cerberus:deps - -RUN rm -rf /opt/cerberus -COPY docker_entry_point.sh /opt/docker_entry_point.sh -RUN chmod +x /opt/docker_entry_point.sh -WORKDIR /data -ENTRYPOINT ["/opt/docker_entry_point.sh"] diff --git a/Dockerfile.deps b/Dockerfile.ubuntu similarity index 56% rename from Dockerfile.deps rename to Dockerfile.ubuntu index 3cf30851c..96d1e8900 100644 --- a/Dockerfile.deps +++ b/Dockerfile.ubuntu @@ -1,18 +1,25 @@ +# Build a minimal cerberus release image FROM ubuntu:22.04 +# Install system packages RUN apt-get update RUN apt-get upgrade -y RUN apt-get install -y opam libgmp-dev libmpfr-dev ENV OPAMCONFIRMLEVEL=unsafe-yes RUN opam init --disable-sandboxing -RUN opam install dune lem ADD . /opt/cerberus WORKDIR /opt/cerberus RUN opam install --deps-only ./cerberus-lib.opam ./cn.opam +RUN opam install z3 + RUN eval `opam env` \ - && make install \ && make install_cn -WORKDIR /opt \ No newline at end of file +WORKDIR /opt + +COPY docker_entry_point.sh /opt/docker_entry_point.sh +RUN chmod +x /opt/docker_entry_point.sh +WORKDIR /data +ENTRYPOINT ["/opt/docker_entry_point.sh"] diff --git a/Makefile_docker b/Makefile_docker deleted file mode 100644 index f809b44a2..000000000 --- a/Makefile_docker +++ /dev/null @@ -1,22 +0,0 @@ -.PHONY: all release dev-env deps - -PLATFORM ?= linux/amd64 -$(info Building for platform $(PLATFORM)) - -all: - @echo 'targets: deps|release|dev-env' - -deps : - docker build --platform $(PLATFORM) --tag cerberus:deps -f Dockerfile.deps . - -release: deps - docker build --platform $(PLATFORM) --tag cerberus:release -f Dockerfile.release . - @echo 'for example: docker run --volume `PWD`:/data/ cerberus:release cerberus tests/tcc/00_assignment.c --pp=core' - -release_cn: deps - docker build --platform $(PLATFORM) --tag cn:release -f Dockerfile.release . - @echo 'for example: docker run --volume `PWD`:/data/ cn:release cerberus tests/tcc/00_assignment.c --pp=core' - -dev-env: deps - docker build --platform $(PLATFORM) --tag cerberus:dev-env -f Dockerfile.dev-env . - @echo 'for example: docker run -ti --volume `PWD`:/home/user1/cerberus/ cerberus:dev-env' diff --git a/README-cheri.md b/README-cheri.md index 087971959..c427e769c 100644 --- a/README-cheri.md +++ b/README-cheri.md @@ -31,7 +31,7 @@ opam repo add --this-switch coq-released https://coq.inria.fr/opam/released opam pin -ny coq-struct-tact https://github.com/uwplse/StructTact.git opam repo add --this-switch iris-dev https://gitlab.mpi-sws.org/iris/opam.git opam pin -ny coq-sail-stdpp https://github.com/rems-project/coq-sail.git#f319aad -opam pin -ny coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git +opam pin -ny coq-cheri-capabilities https://github.com/rems-project/coq-cheri-capabilities.git#2f02c44ad061d4da30136dc9dbc06c142c94fdaf ``` Install the remaining dependencies using opam: diff --git a/README.md b/README.md index 2c3c1bb1e..28c2991a5 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # Cerberus C semantics -[![CI](https://github.com/rems-project/cerberus/actions/workflows/ci.yml/badge.svg)](https://github.com/rems-project/cerberus/actions/workflows/ci.yml) +[![CI](https://github.com/rems-project/cerberus/actions/workflows/ci.yml/badge.svg)](https://github.com/rems-project/cerberus/actions/workflows/ci.yml) [![CI-CN](https://github.com/rems-project/cerberus/actions/workflows/ci-cn.yml/badge.svg)](https://github.com/rems-project/cerberus/actions/workflows/ci-cn.yml) [![CI-CN-specs-testing](https://github.com/rems-project/cerberus/actions/workflows/ci-cn-spec-testing.yml/badge.svg)](https://github.com/rems-project/cerberus/actions/workflows/ci-cn-spec-testing.yml) [![CI-CN-becnhmarks](https://github.com/rems-project/cerberus/actions/workflows/ci-cn-bench.yml/badge.svg)](https://github.com/rems-project/cerberus/actions/workflows/ci-cn-bench.yml) [![CI-CHERI](https://github.com/rems-project/cerberus/actions/workflows/ci-cheri.yml/badge.svg)](https://github.com/rems-project/cerberus/actions/workflows/ci-cheri.yml) [![Docker](https://github.com/rems-project/cerberus/actions/workflows/docker.yml/badge.svg)](https://github.com/rems-project/cerberus/actions/workflows/docker.yml) Web interfaces, papers, and web page @@ -183,10 +183,22 @@ See https://github.com/rems-project/cerberus/blob/master/backend/cn/README.md Docker image ------------ +A pre-build docker image with `cerberus` and `cn` can be downloaded with: + +* For the Ubuntu 22.04 based image (recommended): + ```bash + $ docker pull ghcr.io/rems-project/cerberus/cn:release + ``` +* For Redhat Ubi9 based image: + ```bash + $ docker pull ghcr.io/rems-project/cerberus/cn:release-redhat + ``` + +For a local build, run: ```bash -$ make -f Makefile_docker +$ docker build -t cn:release -f Dockerfile.ubuntu . ``` -creates a Docker image than can be used for example with: +which creates a Docker image than can be used for example with: ```bash $ docker run --volume `PWD`:/data/ cerberus:0.1 tests/tcc/00_assignment.c --pp=core ``` diff --git a/backend/cn/FULMINATE_README.md b/backend/cn/FULMINATE_README.md new file mode 100644 index 000000000..af98cd470 --- /dev/null +++ b/backend/cn/FULMINATE_README.md @@ -0,0 +1,47 @@ +# Fulminate + +Fulminate is a tool for translating CN specifications into C runtime assertions, which can then be checked using concrete test inputs. + +## Installation + +Fulminate is installed as part of the CN toolchain - see [README.md](README.md) for instructions. + +## Running Fulminate + +### Generating executable specifications + +To produce a file instrumented with CN runtime assertions, run: + +```bash +cn instrument .c +``` + +This will produce three files: + +* `-exec.c`, the instrumented source +* `cn.h`, a header file containing various definitions and prototypes, including C struct definitions representing CN datatypes, structs and records, as well as function prototypes for the various translated top-level CN functions and predicates. +* `cn.c`, a file that includes `cn.h` and provides definitions for the aforementioned prototypes + + +These are all produced in the directory the command was run from. Alternatively, one can provide an output directory for these three files (after creating the directory) using the `--output-dir` argument: + + +```bash +cn instrument .c --output-dir +``` + +The translation tool injects the executable precondition right before the source function body, at the start of the given function; the executable postcondition into a label called `cn_epilogue`, which gets jumped to via a `goto` wherever there is a return statement in the source; and the executable assertions inplace, wherever they were defined in the source. + +### Compiling, linking and running executable CN specifications + +To compile and link the output files described in the above section, and also to run these examples on some manually-produced concrete inputs (i.e. via a handwritten `main` function), one can run the following commands: + +```bash +export CHECK_SCRIPT="$OPAM_SWITCH_PREFIX/lib/cn/runtime/libexec/cn-runtime-single-file.sh" +$CHECK_SCRIPT .c +``` + +This runs the `cn-runtime-single-file.sh` script from the CN runtime library on `.c`, which generates the executable specification files, compiles and links these, and then runs the produced binary. This script is configurable with the `-n` option for disabling dynamic ownership checking and/or the `-q` option for running the script in quiet mode. This script can be found in `runtime/libcn/libexec` if you are interested in seeing the compile and link commands. + +The compile command includes the `-g` flag for collecting debug information, which means gdb or lldb can be run on the produced binary for setting breakpoints, stepping in and out of functions in a given run, printing concrete variable values at specific points in the program run, etc. gdb can cause problems on Mac due to some certification-related issues, so for Mac users we recommend you use lldb. + diff --git a/backend/cn/README.md b/backend/cn/README.md index 208ec185a..8a0d1c2a5 100644 --- a/backend/cn/README.md +++ b/backend/cn/README.md @@ -1,47 +1,83 @@ # CN -CN is tool for verifying C code is free of undefined behaviour and meets -user-written specifications. It can also convert those specifications into -assertions to be checked at runtime during test cases. +CN is a tool for verifying that C code is free of undefined behaviour and meets +user-written specifications of its ownership and functional correctness, and for translating those specifications into +C assertions that can be checked at runtime on concrete test cases. -## Installation +## Papers -Below are the installation instructions for installing Cerberus, CN, -and their dependencies. +
    -1. Install a recent version of OCaml (we are using 5.0.0 -- 5.2.0) and the opam -package manager for OCaml, following the instructions at -. (Remember to initialise opam -via `opam init` after the installation of opam.) +
  • + Fulminate: Testing CN Separation-Logic Specifications in C. + Rini Banerjee, Kayvan Memarian, Dhruv Makwana, Christopher Pulte, Neel Krishnaswami, and Peter Sewell. + In POPL 2025. +[ +doi | +pdf +] +
    • -2. Install the GMP and MPFR libraries, and Z3. On a Ubuntu system this is done via `sudo apt install libgmp-dev libmpfr-dev z3` . -3. Install the `dune` OCaml build system and Lem via +
  • + +CN: Verifying systems C code with separation-logic refinement types. + Christopher Pulte, Dhruv C. Makwana, Thomas Sewell, Kayvan Memarian, Peter Sewell, and Neel Krishnaswami. + In POPL 2023. +[ +doi | +project page | +pdf +] +
    • +
- ``` - opam install dune lem - ``` +## Tutorial -4. Obtain a copy of Cerberus (including CN) by running +See the [tutorial documentation](https://rems-project.github.io/cn-tutorial/). - ``` - git clone https://github.com/rems-project/cerberus.git - ``` +## Installation + +Below are the installation instructions for installing Cerberus, CN, +and their dependencies. -5. In the downloaded `cerberus` directory run the following opam - command to install CN's opam-package dependencies. - ``` - opam install --deps-only ./cerberus-lib.opam ./cn.opam - ``` +1. Install make, git, GMP library, pkg-config and either/both Z3 or CVC5. + On an Ubuntu system this is done via + ``` + sudo apt install build-essential libgmp-dev pkg-config z3 + ``` + Note: there is a [known bug with Z3 version + 4.8.13](https://github.com/rems-project/cerberus/issues/663) (the default on + Ubuntu 22.04) so you may wish to install Z3 via opam later for a more + up-to-date version. Z3 that is provided in the docker images is sufficiently up-to-date. -6. then run +2. Install the opam package manager for OCaml: + https://ocaml.org/docs/installing-ocaml#install-opam. + On Ubuntu, `sudo apt install opam`. +3. Initialise opam with a recent version of OCaml (the CI builds with 4.14.1, + CN developers use 5.2.0). ``` - make install_cn + opam init --yes --compiler=5.2.0 + ```` + +4. Clone the Cerberus repo (which includes CN): + ``` + git clone https://github.com/rems-project/cerberus.git + ``` + +5. For CN end users, who don't want to tinker with CN locally: + ``` + opam install --yes ./cerberus.opam ./cerberus-lib.opam ./cn.opam # z3 for a more recent version ``` +6. For CN developers: + ``` + opam install --deps-only ./cerberus.opam ./cerberus-lib.opam ./cn.opam ocamlformat.0.26.2 # one time + make install_cn # after any edits + ``` which installs Cerberus, CN (as both a library and an executable), and dependencies. @@ -53,6 +89,3 @@ for logistics and our [onboarding guide](https://github.com/rems-project/cerberus/blob/master/backend/cn/ONBOARDING.md) for learning the code base. -## Funding Acknowledgements - -TODO (PS?) diff --git a/backend/cn/bin/dune b/backend/cn/bin/dune index 94f3f9550..5ff6a3fbd 100644 --- a/backend/cn/bin/dune +++ b/backend/cn/bin/dune @@ -4,7 +4,7 @@ (public_name cn) (package cn) (flags - (:standard -w -37 -open Monomorphic.Int)) + (:standard -w @60 -open Monomorphic.Int)) (libraries cerb_backend cerb_frontend diff --git a/backend/cn/bin/main.ml b/backend/cn/bin/main.ml index e12ace41a..816fe8743 100644 --- a/backend/cn/bin/main.ml +++ b/backend/cn/bin/main.ml @@ -43,14 +43,7 @@ end open Log -let frontend - ~macros - ~incl_dirs - ~incl_files - astprints - ~do_peval - ~filename - ~magic_comment_char_dollar +let frontend ~macros ~incl_dirs ~incl_files astprints ~filename ~magic_comment_char_dollar = let open CF in Cerb_global.set_cerb_conf @@ -66,18 +59,21 @@ let frontend Ocaml_implementation.set Ocaml_implementation.HafniumImpl.impl; Switches.set ([ "inner_arg_temps"; "at_magic_comments" ] + (* TODO (DCM, VIP) figure out how to support liveness checks for read-only + resources and then switch on "strict_pointer_arith" to elaborate array + shift to the effectful version. "strict_pointer_relationals" is also + assumed, but this does not affect elaboration. *) @ if magic_comment_char_dollar then [ "magic_comment_char_dollar" ] else []); - Core_peval.config_unfold_stdlib := Sym.has_id_with Setup.unfold_stdlib_name; let@ stdlib = load_core_stdlib () in let@ impl = load_core_impl stdlib impl_name in let conf = Setup.conf macros incl_dirs incl_files astprints in let cn_init_scope : Cn_desugaring.init_scope = { predicates = [ Alloc.Predicate.(str, sym, Some loc) ]; functions = List.map (fun (str, sym) -> (str, sym, None)) cn_builtin_fun_names; - idents = [ Alloc.History.(str, sym, Some loc) ] + idents = [ Alloc.History.(str, sym, None) ] } in - let@ _, ail_prog_opt, prog0 = + let@ cabs_tunit_opt, ail_prog_opt, prog0 = c_frontend_and_elaboration ~cn_init_scope (conf, io) (stdlib, impl) ~filename in let@ () = @@ -87,17 +83,16 @@ let frontend else return () in + let cabs_tunit = Option.get cabs_tunit_opt in let markers_env, ail_prog = Option.get ail_prog_opt in Tags.set_tagDefs prog0.Core.tagDefs; let prog1 = Remove_unspecs.rewrite_file prog0 in - let prog2 = if do_peval then Core_peval.rewrite_file prog1 else prog1 in - let prog3 = Milicore.core_to_micore__file Locations.update prog2 in - let prog4 = Milicore_label_inline.rewrite_file prog3 in + let prog2 = Milicore.core_to_micore__file Locations.update prog1 in + let prog3 = Milicore_label_inline.rewrite_file prog2 in let statement_locs = CStatements.search (snd ail_prog) in print_log_file ("original", CORE prog0); print_log_file ("without_unspec", CORE prog1); - print_log_file ("after_peval", CORE prog2); - return (prog4, (markers_env, ail_prog), statement_locs) + return (cabs_tunit, prog3, (markers_env, ail_prog), statement_locs) let handle_frontend_error = function @@ -133,27 +128,26 @@ let with_well_formedness_check ~csv_times ~log_times ~astprints - ~use_peval ~no_inherit_loc ~magic_comment_char_dollar ~(* Callbacks *) handle_error ~(f : + cabs_tunit:CF.Cabs.translation_unit -> prog5:unit Mucore.file -> ail_prog:CF.GenTypes.genTypeCategory A.ail_program -> statement_locs:Cerb_location.t CStatements.LocMap.t -> paused:_ Typing.pause -> - unit Resultat.t) + unit Or_TypeError.t) = check_input_file filename; - let prog4, (markers_env, ail_prog), statement_locs = + let cabs_tunit, prog, (markers_env, ail_prog), statement_locs = handle_frontend_error (frontend ~macros ~incl_dirs ~incl_files astprints - ~do_peval:use_peval ~filename ~magic_comment_char_dollar) in @@ -165,19 +159,19 @@ let with_well_formedness_check | _ -> None); try let result = - let open Resultat in + let open Or_TypeError in let@ prog5 = Core_to_mucore.normalise_file ~inherit_loc:(not no_inherit_loc) (markers_env, snd ail_prog) - prog4 + prog in print_log_file ("mucore", MUCORE prog5); let paused = Typing.run_to_pause Context.empty (Check.check_decls_lemmata_fun_specs prog5) in Result.iter_error handle_error (Typing.pause_to_result paused); - f ~prog5 ~ail_prog ~statement_locs ~paused + f ~cabs_tunit ~prog5 ~ail_prog ~statement_locs ~paused in Pp.maybe_close_times_channel (); Result.fold ~ok:(fun () -> exit 0) ~error:handle_error result @@ -194,13 +188,14 @@ let report_type_error ~(json : bool) ?(output_dir : string option) ?(fn_name : string option) + ?(serialize_json : bool = false) (error : TypeErrors.t) : unit = if json then - TypeErrors.report_json ?output_dir ?fn_name error + TypeErrors.report_json ?output_dir ?fn_name ~serialize_json error else - TypeErrors.report_pretty ?output_dir ?fn_name error + TypeErrors.report_pretty ?output_dir ?fn_name ~serialize_json error (** Generate an appropriate exit code for the provided error. *) @@ -222,8 +217,13 @@ let exit_code_of_errors (errors : TypeErrors.t list) : int option = (** Report the provided error, then exit. *) -let handle_type_error ~(json : bool) ?(output_dir : string option) (error : TypeErrors.t) = - report_type_error ~json ?output_dir error; +let handle_type_error + ~(json : bool) + ?(output_dir : string option) + ?(serialize_json : bool = false) + (error : TypeErrors.t) + = + report_type_error ~json ?output_dir ~serialize_json error; exit (exit_code_of_error error) @@ -233,11 +233,11 @@ let well_formed incl_dirs incl_files json + json_trace output_dir csv_times log_times astprints - use_peval no_inherit_loc magic_comment_char_dollar = @@ -249,11 +249,11 @@ let well_formed ~csv_times ~log_times ~astprints - ~use_peval ~no_inherit_loc ~magic_comment_char_dollar - ~handle_error:(handle_type_error ~json ?output_dir) - ~f:(fun ~prog5:_ ~ail_prog:_ ~statement_locs:_ ~paused:_ -> Resultat.return ()) + ~handle_error:(handle_type_error ~json ?output_dir ~serialize_json:json_trace) + ~f:(fun ~cabs_tunit:_ ~prog5:_ ~ail_prog:_ ~statement_locs:_ ~paused:_ -> + Or_TypeError.return ()) let verify @@ -265,10 +265,9 @@ let verify debug_level print_level print_sym_nums - slow_smt_threshold - slow_smt_dir no_timestamps json + json_trace output_dir diag lemmata @@ -276,7 +275,6 @@ let verify skip csv_times log_times - random_seed solver_logging solver_flags solver_path @@ -284,11 +282,11 @@ let verify astprints dont_use_vip no_use_ity - use_peval fail_fast quiet no_inherit_loc magic_comment_char_dollar + disable_resource_derived_constraints = if json then ( if debug_level > 0 then @@ -301,8 +299,6 @@ let verify Pp.print_level := print_level; CF.Pp_symbol.pp_cn_sym_nums := print_sym_nums; Pp.print_timestamps := not no_timestamps; - Solver.set_slow_smt_settings slow_smt_threshold slow_smt_dir; - Solver.random_seed := random_seed; (match solver_logging with | Some d -> Solver.Logger.to_file := true; @@ -316,6 +312,7 @@ let verify Check.fail_fast := fail_fast; Diagnostics.diag_string := diag; WellTyped.use_ity := not no_use_ity; + Resource.disable_resource_derived_constraints := disable_resource_derived_constraints; with_well_formedness_check (* CLI arguments *) ~filename ~macros @@ -324,17 +321,22 @@ let verify ~csv_times ~log_times ~astprints - ~use_peval ~no_inherit_loc ~magic_comment_char_dollar (* Callbacks *) - ~handle_error:(handle_type_error ~json ?output_dir) - ~f:(fun ~prog5:_ ~ail_prog:_ ~statement_locs:_ ~paused -> - let check (functions, lemmas) = + ~handle_error:(handle_type_error ~json ?output_dir ~serialize_json:json_trace) + ~f:(fun ~cabs_tunit:_ ~prog5:_ ~ail_prog:_ ~statement_locs:_ ~paused -> + let check (functions, global_var_constraints, lemmas) = let open Typing in - let@ errors = Check.time_check_c_functions functions in + let@ errors = Check.time_check_c_functions (global_var_constraints, functions) in if not quiet then List.iter - (fun (fn, err) -> report_type_error ~json ?output_dir ~fn_name:fn err) + (fun (fn, err) -> + report_type_error + ~json + ?output_dir + ~fn_name:fn + ~serialize_json:json_trace + err) errors; Option.fold ~none:() ~some:exit (exit_code_of_errors (List.map snd errors)); Check.generate_lemmas lemmas lemmata @@ -342,6 +344,19 @@ let verify Typing.run_from_pause check paused) +let handle_error_with_user_guidance ~(label : string) (e : exn) : unit = + let msg = Printexc.to_string e in + let stack = Printexc.get_backtrace () in + Printf.eprintf "cn: internal error, uncaught exception:\n %s\n" msg; + let lines = String.split_on_char '\n' stack in + List.iter (fun line -> Printf.eprintf " %s\n" line) lines; + Printf.eprintf + "Issues can be made at https://github.com/rems-project/cerberus/issues.\n"; + Printf.eprintf "Prefix your issue with \"[%s]\". " label; + Printf.eprintf "Check that there isn't already one for this error.\n"; + exit 1 + + let generate_executable_specs filename macros @@ -353,6 +368,7 @@ let generate_executable_specs print_sym_nums no_timestamps json + json_trace output_dir diag only @@ -362,14 +378,13 @@ let generate_executable_specs astprints dont_use_vip no_use_ity - use_peval fail_fast no_inherit_loc magic_comment_char_dollar (* Executable spec *) output_decorated output_decorated_dir - with_ownership_checking + without_ownership_checking with_test_gen copy_source_dir = @@ -398,24 +413,26 @@ let generate_executable_specs ~csv_times ~log_times ~astprints - ~use_peval ~no_inherit_loc ~magic_comment_char_dollar (* Callbacks *) - ~handle_error:(handle_type_error ~json ?output_dir) - ~f:(fun ~prog5 ~ail_prog ~statement_locs ~paused:_ -> + ~handle_error:(handle_type_error ~json ?output_dir ~serialize_json:json_trace) + ~f:(fun ~cabs_tunit:_ ~prog5 ~ail_prog ~statement_locs ~paused:_ -> Cerb_colour.without_colour (fun () -> - Executable_spec.main - ~with_ownership_checking - ~with_test_gen - ~copy_source_dir - filename - ail_prog - output_decorated - output_decorated_dir - prog5 - statement_locs; - Resultat.return ()) + (try + Executable_spec.main + ~without_ownership_checking + ~with_test_gen + ~copy_source_dir + filename + ail_prog + output_decorated + output_decorated_dir + prog5 + statement_locs + with + | e -> handle_error_with_user_guidance ~label:"CN-Exec" e); + Or_TypeError.return ()) ()) @@ -430,27 +447,43 @@ let run_tests csv_times log_times astprints - use_peval no_inherit_loc magic_comment_char_dollar (* Executable spec *) - with_ownership_checking + without_ownership_checking (* Test Generation *) output_dir + only + skip dont_run + num_samples max_backtracks max_unfolds max_array_length + with_static_hack + input_timeout null_in_every seed logging_level + progress_level interactive + until_timeout + exit_fast + max_stack_depth + allowed_depth_failures + max_generator_size + random_size_splits + allowed_size_split_backtracks + sized_null + coverage + disable_passes = (* flags *) Cerb_debug.debug_level := debug_level; Pp.print_level := print_level; + Check.skip_and_only := (opt_comma_split skip, opt_comma_split only); Sym.executable_spec_enabled := true; - let handle_error (e : TypeErrors.type_error) = + let handle_error (e : TypeErrors.t) = let report = TypeErrors.pp_message e.msg in Pp.error e.loc report.short (Option.to_list report.descr); match e.msg with TypeErrors.Unsupported _ -> exit 2 | _ -> exit 1 @@ -463,50 +496,76 @@ let run_tests ~csv_times ~log_times ~astprints - ~use_peval ~no_inherit_loc ~magic_comment_char_dollar (* Callbacks *) ~handle_error - ~f:(fun ~prog5 ~ail_prog ~statement_locs ~paused:_ -> + ~f:(fun ~cabs_tunit ~prog5 ~ail_prog ~statement_locs ~paused:_ -> + let config : TestGeneration.config = + { num_samples; + max_backtracks; + max_unfolds; + max_array_length; + with_static_hack; + input_timeout; + null_in_every; + seed; + logging_level; + progress_level; + interactive; + until_timeout; + exit_fast; + max_stack_depth; + allowed_depth_failures; + max_generator_size; + random_size_splits; + allowed_size_split_backtracks; + sized_null; + coverage; + disable_passes + } + in + TestGeneration.set_config config; + let _, sigma = ail_prog in + if + List.is_empty + (TestGeneration.functions_under_test ~with_warning:true cabs_tunit sigma prog5) + then ( + print_endline "No testable functions, trivially passing"; + exit 0); + if not (Sys.file_exists output_dir) then ( + print_endline ("Directory \"" ^ output_dir ^ "\" does not exist."); + Sys.mkdir output_dir 0o777; + print_endline ("Created directory \"" ^ output_dir ^ "\" with full permissions.")); Cerb_colour.without_colour (fun () -> - if not (Sys.file_exists output_dir) then ( - print_endline ("Directory \"" ^ output_dir ^ "\" does not exist."); - Sys.mkdir output_dir 0o777; - print_endline - ("Created directory \"" ^ output_dir ^ "\" with full permissions.")); - let _, sigma = ail_prog in - Executable_spec.main - ~with_ownership_checking - ~with_test_gen:true - ~copy_source_dir:false - filename - ail_prog - None - (Some output_dir) - prog5 - statement_locs; - let config : TestGeneration.config = - { max_backtracks; - max_unfolds; - max_array_length; - null_in_every; - seed; - logging_level; - interactive - } - in - TestGeneration.run - ~output_dir - ~filename - ~with_ownership_checking - config - sigma - prog5; + Cn_internal_to_ail.augment_record_map (BaseTypes.Record []); + (try + Executable_spec.main + ~without_ownership_checking + ~with_test_gen:true + ~copy_source_dir:false + filename + ail_prog + None + (Some output_dir) + prog5 + statement_locs + with + | e -> handle_error_with_user_guidance ~label:"CN-Exec" e); + (try + TestGeneration.run + ~output_dir + ~filename + ~without_ownership_checking + cabs_tunit + sigma + prog5 + with + | e -> handle_error_with_user_guidance ~label:"CN-Test-Gen" e); if not dont_run then Unix.execv (Filename.concat output_dir "run_tests.sh") (Array.of_list [])) (); - Resultat.return ()) + Or_TypeError.return ()) open Cmdliner @@ -619,11 +678,6 @@ module Common_flags = struct Arg.(value & flag & info [ "no-use-ity" ] ~doc) - let use_peval = - let doc = "(this switch should go away) run the Core partial evaluation phase" in - Arg.(value & flag & info [ "use-peval" ] ~doc) - - let no_inherit_loc = let doc = "debugging: stop mucore terms inheriting location information from parents" @@ -655,29 +709,11 @@ module Verify_flags = struct Arg.(value & flag & info [ "quiet" ] ~doc) - let slow_smt_threshold = - let doc = "Set the time threshold (in seconds) for logging slow smt queries." in - Arg.(value & opt (some float) None & info [ "slow-smt" ] ~docv:"TIMEOUT" ~doc) - - - let slow_smt_dir = - let doc = - "Set the destination dir for logging slow smt queries (default is in system \ - temp-dir)." - in - Arg.(value & opt (some string) None & info [ "slow-smt-dir" ] ~docv:"FILE" ~doc) - - let diag = let doc = "explore branching diagnostics with key string" in Arg.(value & opt (some string) None & info [ "diag" ] ~doc) - let random_seed = - let doc = "Set the SMT solver random seed (default 1)." in - Arg.(value & opt int 0 & info [ "r"; "random-seed" ] ~docv:"I" ~doc) - - let solver_logging = let doc = "Log solver queries in SMT2 format to a directory." in Arg.(value & opt (some string) None & info [ "solver-logging" ] ~docv:"DIR" ~doc) @@ -722,13 +758,23 @@ module Verify_flags = struct let json = - let doc = "output in json format" in + let doc = "output summary in JSON format" in Arg.(value & flag & info [ "json" ] ~doc) + let json_trace = + let doc = "output state trace files as JSON, in addition to HTML" in + Arg.(value & flag & info [ "json-trace" ] ~doc) + + let output_dir = let doc = "directory in which to output state files" in Arg.(value & opt (some string) None & info [ "output-dir" ] ~docv:"FILE" ~doc) + + + let disable_resource_derived_constraints = + let doc = "disable resource-derived constraints" in + Arg.(value & flag & info [ "disable-resource-derived-constraints" ] ~doc) end module Executable_spec_flags = struct @@ -749,9 +795,9 @@ module Executable_spec_flags = struct Arg.(value & opt (some string) None & info [ "output-decorated" ] ~docv:"FILE" ~doc) - let with_ownership_checking = - let doc = "Enable ownership checking within CN runtime testing" in - Arg.(value & flag & info [ "with-ownership-checking" ] ~doc) + let without_ownership_checking = + let doc = "Disable ownership checking within CN runtime testing" in + Arg.(value & flag & info [ "without-ownership-checking" ] ~doc) let with_test_gen = @@ -784,11 +830,11 @@ let wf_cmd = $ Common_flags.incl_dirs $ Common_flags.incl_files $ Verify_flags.json + $ Verify_flags.json_trace $ Verify_flags.output_dir $ Common_flags.csv_times $ Common_flags.log_times $ Common_flags.astprints - $ Common_flags.use_peval $ Common_flags.no_inherit_loc $ Common_flags.magic_comment_char_dollar in @@ -816,10 +862,9 @@ let verify_t : unit Term.t = $ Common_flags.debug_level $ Common_flags.print_level $ Common_flags.print_sym_nums - $ Verify_flags.slow_smt_threshold - $ Verify_flags.slow_smt_dir $ Common_flags.no_timestamps $ Verify_flags.json + $ Verify_flags.json_trace $ Verify_flags.output_dir $ Verify_flags.diag $ Lemma_flags.lemmata @@ -827,7 +872,6 @@ let verify_t : unit Term.t = $ Verify_flags.skip $ Common_flags.csv_times $ Common_flags.log_times - $ Verify_flags.random_seed $ Verify_flags.solver_logging $ Verify_flags.solver_flags $ Verify_flags.solver_path @@ -835,11 +879,11 @@ let verify_t : unit Term.t = $ Common_flags.astprints $ Verify_flags.dont_use_vip $ Common_flags.no_use_ity - $ Common_flags.use_peval $ Verify_flags.fail_fast $ Verify_flags.quiet $ Common_flags.no_inherit_loc $ Common_flags.magic_comment_char_dollar + $ Verify_flags.disable_resource_derived_constraints let verify_cmd = @@ -858,11 +902,27 @@ module Testing_flags = struct Arg.(required & opt (some string) None & info [ "output-dir" ] ~docv:"FILE" ~doc) - let dont_run_tests = + let only = + let doc = "Only test this function (or comma-separated names)" in + Arg.(value & opt (some string) None & info [ "only" ] ~doc) + + + let skip = + let doc = "Skip testing of this function (or comma-separated names)" in + Arg.(value & opt (some string) None & info [ "skip" ] ~doc) + + + let dont_run = let doc = "Do not run tests, only generate them" in Arg.(value & flag & info [ "no-run" ] ~doc) + let gen_num_samples = + let doc = "Set the number of samples to test" in + Arg.( + value & opt int TestGeneration.default_cfg.num_samples & info [ "num-samples" ] ~doc) + + let gen_backtrack_attempts = let doc = "Set the maximum attempts to satisfy a constraint before backtracking further, \ @@ -877,10 +937,12 @@ module Testing_flags = struct let gen_max_unfolds = let doc = "Set the maximum number of unfolds for recursive generators" in Arg.( - value & opt int TestGeneration.default_cfg.max_unfolds & info [ "max-unfolds" ] ~doc) + value + & opt (some int) TestGeneration.default_cfg.max_unfolds + & info [ "max-unfolds" ] ~doc) - let test_max_array_length = + let max_array_length = let doc = "Set the maximum length for an array generated" in Arg.( value @@ -888,7 +950,23 @@ module Testing_flags = struct & info [ "max-array-length" ] ~doc) - let test_null_in_every = + let with_static_hack = + let doc = + "(HACK) Use an `#include` instead of linking to build testing. Necessary until \ + https://github.com/rems-project/cerberus/issues/784 or equivalent." + in + Arg.(value & flag & info [ "with-static-hack" ] ~doc) + + + let input_timeout = + let doc = "Timeout for discarding a generation attempt (ms)" in + Arg.( + value + & opt (some int) TestGeneration.default_cfg.input_timeout + & info [ "input-timeout" ] ~doc) + + + let null_in_every = let doc = "Set the likelihood of NULL being generated as 1 in every " in Arg.( value @@ -896,12 +974,12 @@ module Testing_flags = struct & info [ "null-in-every" ] ~doc) - let test_seed = + let seed = let doc = "Set the seed for random testing" in Arg.(value & opt (some string) TestGeneration.default_cfg.seed & info [ "seed" ] ~doc) - let test_logging_level = + let logging_level = let doc = "Set the logging level for failing inputs from tests" in Arg.( value @@ -909,11 +987,106 @@ module Testing_flags = struct & info [ "logging-level" ] ~doc) - let interactive_testing = + let progress_level = + let doc = + "Set the level of detail for progress updates (0 = Quiet, 1 = Per function, 2 = \ + Per test case)" + in + Arg.( + value + & opt (some int) TestGeneration.default_cfg.progress_level + & info [ "progress-level" ] ~doc) + + + let interactive = let doc = "Enable interactive features for testing, such as requesting more detailed logs" in Arg.(value & flag & info [ "interactive" ] ~doc) + + + let until_timeout = + let doc = + "Keep rerunning tests until the given timeout (in seconds) has been reached" + in + Arg.( + value + & opt (some int) TestGeneration.default_cfg.until_timeout + & info [ "until-timeout" ] ~doc) + + + let exit_fast = + let doc = "Stop testing upon finding the first failure" in + Arg.(value & flag & info [ "exit-fast" ] ~doc) + + + let max_stack_depth = + let doc = "Maximum stack depth for generators" in + Arg.( + value + & opt (some int) TestGeneration.default_cfg.max_stack_depth + & info [ "max-stack-depth" ] ~doc) + + + let allowed_depth_failures = + let doc = "Maximum stack depth failures before discarding an attempt" in + Arg.( + value + & opt (some int) TestGeneration.default_cfg.allowed_depth_failures + & info [ "allowed-depth-failures" ] ~doc) + + + let max_generator_size = + let doc = "Maximum size for generated values" in + Arg.( + value + & opt (some int) TestGeneration.default_cfg.max_generator_size + & info [ "max-generator-size" ] ~doc) + + + let random_size_splits = + let doc = "Randomly split sizes between recursive generator calls" in + Arg.(value & flag & info [ "random-size-splits" ] ~doc) + + + let allowed_size_split_backtracks = + let doc = + "Set the maximum attempts to split up a generator's size (between recursive calls) \ + before backtracking further, during input generation" + in + Arg.( + value + & opt (some int) TestGeneration.default_cfg.allowed_size_split_backtracks + & info [ "allowed-size-split-backtracks" ] ~doc) + + + let sized_null = + let doc = + "Scale the likelihood of [NULL] proportionally for a desired size (1/n for size n)" + in + Arg.(value & flag & info [ "sized-null" ] ~doc) + + + let coverage = + let doc = "(Experimental) Record coverage of tests via [lcov]" in + Arg.(value & flag & info [ "coverage" ] ~doc) + + + let disable_passes = + let doc = "skip this optimization pass (or comma-separated names)" in + Arg.( + value + & opt + (list + (enum + [ ("reorder", "reorder"); + ("picks", "picks"); + ("flatten", "flatten"); + ("consistency", "consistency"); + ("lift_constraints", "lift_constraints") + ])) + [] + & info [ "disable" ] ~doc) end let testing_cmd = @@ -929,25 +1102,41 @@ let testing_cmd = $ Common_flags.csv_times $ Common_flags.log_times $ Common_flags.astprints - $ Common_flags.use_peval $ Common_flags.no_inherit_loc $ Common_flags.magic_comment_char_dollar - $ Executable_spec_flags.with_ownership_checking + $ Executable_spec_flags.without_ownership_checking $ Testing_flags.output_test_dir - $ Testing_flags.dont_run_tests + $ Testing_flags.only + $ Testing_flags.skip + $ Testing_flags.dont_run + $ Testing_flags.gen_num_samples $ Testing_flags.gen_backtrack_attempts $ Testing_flags.gen_max_unfolds - $ Testing_flags.test_max_array_length - $ Testing_flags.test_null_in_every - $ Testing_flags.test_seed - $ Testing_flags.test_logging_level - $ Testing_flags.interactive_testing + $ Testing_flags.max_array_length + $ Testing_flags.with_static_hack + $ Testing_flags.input_timeout + $ Testing_flags.null_in_every + $ Testing_flags.seed + $ Testing_flags.logging_level + $ Testing_flags.progress_level + $ Testing_flags.interactive + $ Testing_flags.until_timeout + $ Testing_flags.exit_fast + $ Testing_flags.max_stack_depth + $ Testing_flags.allowed_depth_failures + $ Testing_flags.max_generator_size + $ Testing_flags.random_size_splits + $ Testing_flags.allowed_size_split_backtracks + $ Testing_flags.sized_null + $ Testing_flags.coverage + $ Testing_flags.disable_passes in let doc = - "Generates RapidCheck tests for all functions in [FILE] with CN specifications.\n\ + "Generates tests for all functions in [FILE] with CN specifications.\n\ \ The tests use randomized inputs, which are guaranteed to satisfy the CN \ precondition.\n\ - \ A [.cpp] file containing the test harnesses will be placed in [output-dir]." + \ A script [run_tests.sh] for building and running the tests will be placed in \ + [output-dir]." in let info = Cmd.info "test" ~doc in Cmd.v info test_t @@ -967,6 +1156,7 @@ let instrument_cmd = $ Common_flags.print_sym_nums $ Common_flags.no_timestamps $ Verify_flags.json + $ Verify_flags.json_trace $ Verify_flags.output_dir $ Verify_flags.diag $ Verify_flags.only @@ -976,13 +1166,12 @@ let instrument_cmd = $ Common_flags.astprints $ Verify_flags.dont_use_vip $ Common_flags.no_use_ity - $ Common_flags.use_peval $ Verify_flags.fail_fast $ Common_flags.no_inherit_loc $ Common_flags.magic_comment_char_dollar $ Executable_spec_flags.output_decorated $ Executable_spec_flags.output_decorated_dir - $ Executable_spec_flags.with_ownership_checking + $ Executable_spec_flags.without_ownership_checking $ Executable_spec_flags.with_test_gen $ Executable_spec_flags.copy_source_dir in diff --git a/backend/cn/lib/alloc.ml b/backend/cn/lib/alloc.ml index 1edb5c035..3906e9296 100644 --- a/backend/cn/lib/alloc.ml +++ b/backend/cn/lib/alloc.ml @@ -3,36 +3,42 @@ module History = struct let sym = Sym.fresh_named str - let loc = Locations.other __MODULE__ + let here = Locations.other __LOC__ - let base_id = Id.id "base" + let base_id = Id.make here "base" let base_bt = Memory.uintptr_bt - let size_id = Id.id "size" + let size_id = Id.make here "size" let size_bt = Memory.uintptr_bt let value_bt = BaseTypes.Record [ (base_id, base_bt); (size_id, size_bt) ] - let make_value ~base ~size loc' = + let make_value ~base ~size loc = IndexTerms.( - record_ [ (base_id, base); (size_id, num_lit_ (Z.of_int size) size_bt loc') ] loc') + record_ [ (base_id, base); (size_id, num_lit_ (Z.of_int size) size_bt loc) ] loc) let bt = BaseTypes.Map (Alloc_id, value_bt) - let it = IndexTerms.sym_ (sym, bt, loc) + let it loc = IndexTerms.sym_ (sym, bt, loc) + + let lookup_ptr ptr loc = + assert (BaseTypes.(equal (IndexTerms.get_bt ptr) (Loc ()))); + IndexTerms.(map_get_ (it loc) (allocId_ ptr loc) loc) - let lookup_ptr ptr loc' = - assert (BaseTypes.(equal (IndexTerms.bt ptr) (Loc ()))); - IndexTerms.(map_get_ it (allocId_ ptr loc') loc') + type value = + { base : IndexTerms.t; + size : IndexTerms.t + } - let get_base_size ptr loc' = + let split value loc = IndexTerms. - ( recordMember_ ~member_bt:base_bt (ptr, base_id) loc', - recordMember_ ~member_bt:size_bt (ptr, size_id) loc' ) + { base = recordMember_ ~member_bt:base_bt (value, base_id) loc; + size = recordMember_ ~member_bt:size_bt (value, size_id) loc + } let sbt = BaseTypes.Surface.inj bt diff --git a/backend/cn/lib/alloc.mli b/backend/cn/lib/alloc.mli index b4704ad56..924920061 100644 --- a/backend/cn/lib/alloc.mli +++ b/backend/cn/lib/alloc.mli @@ -3,8 +3,6 @@ module History : sig val sym : Sym.t - val loc : Locations.t - val base_id : Id.t val base_bt : BaseTypes.t @@ -19,11 +17,16 @@ module History : sig val bt : BaseTypes.t - val it : IndexTerms.t + val it : Cerb_location.t -> IndexTerms.t val lookup_ptr : IndexTerms.t -> Locations.t -> IndexTerms.t - val get_base_size : IndexTerms.t -> Cerb_location.t -> IndexTerms.t * IndexTerms.t + type value = + { base : IndexTerms.t; + size : IndexTerms.t + } + + val split : IndexTerms.t -> Cerb_location.t -> value val sbt : BaseTypes.Surface.t end diff --git a/backend/cn/lib/argumentTypes.ml b/backend/cn/lib/argumentTypes.ml index dc58f10d1..2025efc6e 100644 --- a/backend/cn/lib/argumentTypes.ml +++ b/backend/cn/lib/argumentTypes.ml @@ -1,10 +1,8 @@ open Locations module BT = BaseTypes module IT = IndexTerms -module LS = LogicalSorts -module RET = ResourceTypes +module Req = Request module LC = LogicalConstraints -module SymSet = Set.Make (Sym) module LAT = LogicalArgumentTypes type 'i t = @@ -29,7 +27,7 @@ and alpha_rename i_subst s t = and suitably_alpha_rename i_subst syms s t = - if SymSet.mem s syms then + if Sym.Set.mem s syms then alpha_rename i_subst s t else (s, t) @@ -82,7 +80,7 @@ let alpha_unique ss = match at with | Computational ((name, bt), info, t) -> let name, t = rename_if ss name t in - let t = f (SymSet.add name ss) t in + let t = f (Sym.Set.add name ss) t in Computational ((name, bt), info, t) | L t -> L (LAT.alpha_unique ss t) in @@ -93,7 +91,8 @@ let binders i_binders i_subst = let rec aux = function | Computational ((s, bt), _, t) -> let s, t = alpha_rename i_subst s t in - (Id.id (Sym.pp_string s), bt) :: aux t + let here = Locations.other __LOC__ in + (Id.make here (Sym.pp_string s), bt) :: aux t | L t -> LAT.binders i_binders i_subst t in aux diff --git a/backend/cn/lib/builtins.ml b/backend/cn/lib/builtins.ml index b83f0ad82..2d826a69d 100644 --- a/backend/cn/lib/builtins.ml +++ b/backend/cn/lib/builtins.ml @@ -1,29 +1,28 @@ module SBT = BaseTypes.Surface -open Resultat +open Or_TypeError +open IndexTerms -open Effectful.Make (Resultat) +let fail_number_args loc ~has ~expect = + fail { loc; msg = WellTyped (Number_arguments { type_ = `Other; has; expect }) } -open TypeErrors -open IndexTerms (* builtin function symbols *) let mk_arg0 mk args loc = match args with | [] -> return (mk loc) - | _ :: _ as xs -> - fail { loc; msg = Number_arguments { has = List.length xs; expect = 0 } } + | _ :: _ as xs -> fail_number_args loc ~has:(List.length xs) ~expect:0 let mk_arg1 mk args loc = match args with | [ x ] -> return (mk x loc) - | xs -> fail { loc; msg = Number_arguments { has = List.length xs; expect = 1 } } + | xs -> fail_number_args loc ~has:(List.length xs) ~expect:1 let mk_arg2_err mk args loc = match args with | [ x; y ] -> mk (x, y) loc - | xs -> fail { loc; msg = Number_arguments { has = List.length xs; expect = 2 } } + | xs -> fail_number_args loc ~has:(List.length xs) ~expect:2 let mk_arg2 mk = mk_arg2_err (fun tup loc -> return (mk tup loc)) @@ -31,7 +30,7 @@ let mk_arg2 mk = mk_arg2_err (fun tup loc -> return (mk tup loc)) let mk_arg3_err mk args loc = match args with | [ x; y; z ] -> mk (x, y, z) loc - | xs -> fail { loc; msg = Number_arguments { has = List.length xs; expect = 3 } } + | xs -> fail_number_args loc ~has:(List.length xs) ~expect:3 let mk_arg3 mk = mk_arg3_err (fun tup loc -> return (mk tup loc)) @@ -39,7 +38,7 @@ let mk_arg3 mk = mk_arg3_err (fun tup loc -> return (mk tup loc)) let mk_arg5 mk args loc = match args with | [ a; b; c; d; e ] -> return (mk (a, b, c, d, e) loc) - | xs -> fail { loc; msg = Number_arguments { has = List.length xs; expect = 5 } } + | xs -> fail_number_args loc ~has:(List.length xs) ~expect:5 let min_bits_def (sign, n) = @@ -51,7 +50,7 @@ let min_bits_def (sign, n) = let name = "MIN" ^ letter ^ Int.to_string n in ( name, Sym.fresh_named name, - mk_arg0 (fun loc -> IT.Surface.inj @@ num_lit_ num (BT.Bits (sign, n)) loc) ) + mk_arg0 (fun loc -> Surface.inj @@ num_lit_ num (BT.Bits (sign, n)) loc) ) let max_bits_def (sign, n) = @@ -63,7 +62,7 @@ let max_bits_def (sign, n) = let name = "MAX" ^ letter ^ Int.to_string n in ( name, Sym.fresh_named name, - mk_arg0 (fun loc -> IT.Surface.inj @@ num_lit_ num (BT.Bits (sign, n)) loc) ) + mk_arg0 (fun loc -> Surface.inj @@ num_lit_ num (BT.Bits (sign, n)) loc) ) let mul_uf_def = ("mul_uf", Sym.fresh_named "mul_uf", mk_arg2 mul_no_smt_) @@ -122,14 +121,15 @@ let array_to_list_def = ( "array_to_list", Sym.fresh_named "array_to_list", mk_arg3_err (fun (arr, i, len) loc -> - match SBT.is_map_bt (IT.bt arr) with + match SBT.is_map_bt (get_bt arr) with | None -> let reason = "map/array operation" in let expected = "map/array" in fail { loc; msg = - Illtyped_it { it = IT.pp arr; has = SBT.pp (IT.bt arr); expected; reason } + WellTyped + (Illtyped_it { it = pp arr; has = SBT.pp (get_bt arr); expected; reason }) } | Some (_, bt) -> return (array_to_list_ (arr, i, len) bt loc)) ) @@ -137,40 +137,36 @@ let array_to_list_def = let is_null_def = ( "is_null", Sym.fresh_named "is_null", - mk_arg1 (fun p loc' -> IT.Surface.inj IT.(eq_ (IT.Surface.proj p, null_ loc') loc')) - ) + mk_arg1 (fun p loc -> Surface.inj (eq_ (Surface.proj p, null_ loc) loc)) ) let has_alloc_id_def = ( "has_alloc_id", Sym.fresh_named "has_alloc_id", - mk_arg1 (fun p loc' -> IT.Surface.inj @@ IT.hasAllocId_ (IT.Surface.proj p) loc') ) + mk_arg1 (fun p loc -> Surface.inj @@ hasAllocId_ (Surface.proj p) loc) ) let ptr_eq_def = ( "ptr_eq", Sym.fresh_named "ptr_eq", - mk_arg2 (fun (p1, p2) loc' -> - IT.(Surface.inj @@ eq_ (Surface.proj p1, Surface.proj p2) loc')) ) + mk_arg2 (fun (p1, p2) loc -> + Surface.inj @@ eq_ (Surface.proj p1, Surface.proj p2) loc) ) let prov_eq_def = ( "prov_eq", Sym.fresh_named "prov_eq", - mk_arg2 (fun (p1, p2) loc' -> - IT.( - Surface.inj - @@ eq_ (allocId_ (Surface.proj p1) loc', allocId_ (Surface.proj p2) loc') loc')) - ) + mk_arg2 (fun (p1, p2) loc -> + Surface.inj + @@ eq_ (allocId_ (Surface.proj p1) loc, allocId_ (Surface.proj p2) loc) loc) ) let addr_eq_def = ( "addr_eq", Sym.fresh_named "addr_eq", - mk_arg2 (fun (p1, p2) loc' -> - IT.( - Surface.inj - @@ eq_ (addr_ (Surface.proj p1) loc', addr_ (Surface.proj p2) loc') loc')) ) + mk_arg2 (fun (p1, p2) loc -> + Surface.inj @@ eq_ (addr_ (Surface.proj p1) loc, addr_ (Surface.proj p2) loc) loc) + ) let max_min_bits = diff --git a/backend/cn/lib/cLogicalFuns.ml b/backend/cn/lib/cLogicalFuns.ml index fa19a6350..6769ff8b3 100644 --- a/backend/cn/lib/cLogicalFuns.ml +++ b/backend/cn/lib/cLogicalFuns.ml @@ -1,17 +1,14 @@ -open TypeErrors -open Typing - -open Effectful.Make (Typing) - -module SymMap = Map.Make (Sym) -module SymSet = Set.Make (Sym) module StringMap = Map.Make (String) module IntMap = Map.Make (Int) module CF = Cerb_frontend module BT = BaseTypes -open Cerb_pp_prelude module Mu = Mucore module IT = IndexTerms +open Cerb_pp_prelude +open TypeErrors +open Typing + +open Effectful.Make (Typing) let fail_n m = fail (fun _ctxt -> m) @@ -47,7 +44,7 @@ type state = type context = { label_defs : (Sym.t, unit Mu.label_def) Pmap.map; (* map from c functions to logical functions which we are building *) - c_fun_pred_map : (Locations.t * Sym.t) SymMap.t; + c_fun_pred_map : (Locations.t * Sym.t) Sym.Map.t; call_funinfo : (Sym.t, Sctypes.c_concrete_sig) Pmap.map } @@ -55,7 +52,7 @@ let init_state = { loc_map = IntMap.empty; next_loc = 1 } let mk_local_ptr state src_loc = let loc_ix = state.next_loc in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let ptr = IT.apply_ local_sym_ptr [ IT.int_ loc_ix here ] BT.(Loc ()) src_loc in let loc_map = IntMap.add loc_ix None state.loc_map in let state = { loc_map; next_loc = loc_ix + 1 } in @@ -83,7 +80,7 @@ let triv_simp_ctxt = Simplify.default Global.empty let simp_const loc lpp it = let it2 = Simplify.IndexTerms.simp triv_simp_ctxt it in - match (IT.is_z it2, IT.bt it2) with + match (IT.is_z it2, IT.get_bt it2) with | Some _z, _ -> return it2 | _, BT.Integer -> fail_n @@ -101,7 +98,7 @@ let do_wrapI loc ct it = match Sctypes.is_integer_type ct with | Some ity -> let ity_bt = Memory.bt_of_sct ct in - if BT.equal ity_bt (IT.bt it) then + if BT.equal ity_bt (IT.get_bt it) then return it else return (IT.wrapI_ (ity, it) loc) @@ -131,7 +128,7 @@ let rec is_const_num = function let rec add_pattern p v var_map = let (Mu.Pattern (loc, _, _, pattern)) = p in match pattern with - | CaseBase (Some s, _) -> return (SymMap.add s v var_map) + | CaseBase (Some s, _) -> return (Sym.Map.add s v var_map) | CaseBase (None, _) -> return var_map | CaseCtor (Ctuple, ps) -> let@ vs = @@ -168,13 +165,13 @@ let signed_int_ity = Sctypes.(IntegerTypes.Signed IntegerBaseTypes.Int_) let signed_int_ty = Memory.bt_of_sct (Sctypes.Integer signed_int_ity) let is_two_pow it = - match IT.term it with + match IT.get_term it with | Terms.Binop (Terms.ExpNoSMT, x, y) when Option.equal Z.equal (IT.get_num_z x) (Some (Z.of_int 2)) -> - Some (`Two_loc (IT.loc x), `Exp y) + Some (`Two_loc (IT.get_loc x), `Exp y) | Terms.Binop (Terms.Exp, x, y) when Option.equal Z.equal (IT.get_num_z x) (Some (Z.of_int 2)) -> - Some (`Two_loc (IT.loc x), `Exp y) + Some (`Two_loc (IT.get_loc x), `Exp y) | _ -> None @@ -220,7 +217,7 @@ let eval_fun f args orig_pexpr = let rec symb_exec_pexpr ctxt var_map pexpr = let (Mu.Pexpr (loc, annots, _, pe)) = pexpr in let opt_bt = - WellTyped.BaseTyping.integer_annot annots + WellTyped.integer_annot annots |> Option.map (fun ity -> Memory.bt_of_sct (Sctypes.Integer ity)) in Pp.debug @@ -245,9 +242,9 @@ let rec symb_exec_pexpr ctxt var_map pexpr = in match pe with | PEsym sym -> - (match SymMap.find_opt sym var_map with + (match Sym.Map.find_opt sym var_map with | Some r -> return r - | _ -> fail_n { loc; msg = Unknown_variable sym }) + | _ -> fail_n { loc; msg = WellTyped (Unknown_variable sym) }) | PEval v -> (match val_to_it loc v with | Some r -> return r @@ -309,13 +306,13 @@ let rec symb_exec_pexpr ctxt var_map pexpr = in (match (op, x_v, is_two_pow y_v) with | OpMul, _, Some (`Two_loc two_loc, `Exp exp) -> - let exp_loc = IT.loc y_v in + let exp_loc = IT.get_loc y_v in return - (IT.mul_ (x_v, IT.exp_ (IT.int_lit_ 2 (IT.bt x_v) two_loc, exp) exp_loc) loc) + (IT.mul_ (x_v, IT.exp_ (IT.int_lit_ 2 (IT.get_bt x_v) two_loc, exp) exp_loc) loc) | OpDiv, _, Some (`Two_loc two_loc, `Exp exp) -> - let exp_loc = IT.loc y_v in + let exp_loc = IT.get_loc y_v in return - (IT.div_ (x_v, IT.exp_ (IT.int_lit_ 2 (IT.bt x_v) two_loc, exp) exp_loc) loc) + (IT.div_ (x_v, IT.exp_ (IT.int_lit_ 2 (IT.get_bt x_v) two_loc, exp) exp_loc) loc) | _, _, _ -> let@ res = simp_const_pe (f x_v y_v) in return res) @@ -362,11 +359,11 @@ let rec symb_exec_pexpr ctxt var_map pexpr = in (match ct with | Sctypes.Integer Sctypes.IntegerTypes.Bool -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in simp_const_pe (bool_ite_1_0 bool_rep_ty - (IT.not_ (IT.eq_ (x, IT.int_lit_ 0 (IT.bt x) here) here) here) + (IT.not_ (IT.eq_ (x, IT.int_lit_ 0 (IT.get_bt x) here) here) here) loc) | _ -> do_wrapI loc ct x) | PEwrapI (act, pe) -> @@ -378,14 +375,14 @@ let rec symb_exec_pexpr ctxt var_map pexpr = | PEbounded_binop (bk, op, pe_x, pe_y) -> let@ x = self var_map pe_x in let@ y = self var_map pe_y in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let it = match op with | IOpAdd -> IT.add_ (x, y) loc | IOpSub -> IT.sub_ (x, y) loc | IOpMul -> IT.mul_ (x, y) loc - | IOpShl -> IT.arith_binop Terms.ShiftLeft (x, IT.cast_ (IT.bt x) y here) loc - | IOpShr -> IT.arith_binop Terms.ShiftRight (x, IT.cast_ (IT.bt x) y here) loc + | IOpShl -> IT.arith_binop Terms.ShiftLeft (x, IT.cast_ (IT.get_bt x) y here) loc + | IOpShr -> IT.arith_binop Terms.ShiftRight (x, IT.cast_ (IT.get_bt x) y here) loc in do_wrapI loc (Mu.bound_kind_act bk).ct it | PEcfunction pe -> @@ -414,7 +411,7 @@ let rec symb_exec_expr ctxt state_vars expr = let state, var_map = state_vars in let (Mu.Expr (loc, annots, _, e)) = expr in let opt_bt = - WellTyped.BaseTyping.integer_annot annots + WellTyped.integer_annot annots |> Option.map (fun ity -> Memory.bt_of_sct (Sctypes.Integer ity)) in Pp.debug @@ -541,26 +538,27 @@ let rec symb_exec_expr ctxt state_vars expr = | None -> fail_fun_it "not a constant function address" | Some (nm, _) -> return nm in - if SymMap.mem nm ctxt.c_fun_pred_map then ( - let loc, l_sym = SymMap.find nm ctxt.c_fun_pred_map in - let@ def = get_logical_function_def loc l_sym in - rcval (IT.apply_ l_sym args_its def.LogicalFunctions.return_bt loc) state) - else if Sym.has_id_with Setup.unfold_stdlib_name nm then ( - let s = Option.get (Sym.has_id nm) in - let wrap_int x = IT.wrapI_ (signed_int_ity, x) in - if String.equal s "ctz_proxy" then - rcval - (wrap_int (IT.arith_unop Terms.BW_CTZ_NoSMT (List.hd args_its) loc) loc) - state - else if List.exists (String.equal s) [ "ffs_proxy"; "ffsl_proxy"; "ffsll_proxy" ] - then - rcval - (wrap_int (IT.arith_unop Terms.BW_FFS_NoSMT (List.hd args_its) loc) loc) - state - else - failwith ("unknown stdlib function: " ^ s)) - else - fail_fun_it "not a function with a pure/logical interpretation" + if Sym.Map.mem nm ctxt.c_fun_pred_map then ( + let loc, l_sym = Sym.Map.find nm ctxt.c_fun_pred_map in + let@ def = Global.get_logical_function_def loc l_sym in + rcval (IT.apply_ l_sym args_its def.Definition.Function.return_bt loc) state) + else ( + let bail = fail_fun_it "not a function with a pure/logical interpretation" in + match Sym.has_id nm with + | None -> bail + | Some s -> + let wrap_int x = IT.wrapI_ (signed_int_ity, x) in + if String.equal s "ctz_proxy" then + rcval + (wrap_int (IT.arith_unop Terms.BW_CTZ_NoSMT (List.hd args_its) loc) loc) + state + else if List.exists (String.equal s) [ "ffs_proxy"; "ffsl_proxy"; "ffsll_proxy" ] + then + rcval + (wrap_int (IT.arith_unop Terms.BW_FFS_NoSMT (List.hd args_its) loc) loc) + state + else + bail) | CN_progs _ -> rcval (IT.unit_ loc) state | _ -> fail_n @@ -577,7 +575,7 @@ let rec filter_syms ss p = let (Mu.Pattern (a, b, c, pat)) = p in let mk pat = Mu.Pattern (a, b, c, pat) in match pat with - | CaseBase (Some s, bt) -> if SymSet.mem s ss then p else mk (CaseBase (None, bt)) + | CaseBase (Some s, bt) -> if Sym.Set.mem s ss then p else mk (CaseBase (None, bt)) | CaseBase (None, _) -> p | CaseCtor (Ctuple, ps) -> let ps = List.map (filter_syms ss) ps in @@ -591,7 +589,7 @@ let rec filter_syms ss p = let rec get_ret_it loc body bt = function | Call_Ret v -> let@ () = - if BT.equal (IT.bt v) bt then + if BT.equal (IT.get_bt v) bt then return () else fail_n @@ -620,9 +618,9 @@ let rec get_ret_it loc body bt = function let c_fun_to_it id_loc glob_context (id : Sym.t) fsym def (fn : 'bty Mu.fun_map_decl) = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let def_args = - def.LogicalFunctions.args + def.Definition.Function.args (* TODO - add location information to binders *) |> List.map (fun (s, bt) -> IndexTerms.sym_ (s, bt, here)) in @@ -643,8 +641,8 @@ let c_fun_to_it id_loc glob_context (id : Sym.t) fsym def (fn : 'bty Mu.fun_map_ let rec mk_var_map acc args_and_body def_args = match (args_and_body, def_args) with | Mu.Computational ((s, bt), _, args_and_body), v :: def_args -> - if BT.equal bt (IT.bt v) then - mk_var_map (SymMap.add s v acc) args_and_body def_args + if BT.equal bt (IT.get_bt v) then + mk_var_map (Sym.Map.add s v acc) args_and_body def_args else fail_n { loc; @@ -652,7 +650,7 @@ let c_fun_to_it id_loc glob_context (id : Sym.t) fsym def (fn : 'bty Mu.fun_map_ Generic Pp.( !^"mismatched arguments:" - ^^^ parens (BT.pp (IT.bt v) ^^^ IT.pp v) + ^^^ parens (BT.pp (IT.get_bt v) ^^^ IT.pp v) ^^^ !^"and" ^^^ parens (BT.pp bt ^^^ Sym.pp s)) } @@ -675,11 +673,11 @@ let c_fun_to_it id_loc glob_context (id : Sym.t) fsym def (fn : 'bty Mu.fun_map_ (fun () -> in_computational_ctxt args_and_body m) | L _ -> m in - let@ arg_map, (body, labels, rt) = mk_var_map SymMap.empty args_and_body def_args in + let@ arg_map, (body, labels, rt) = mk_var_map Sym.Map.empty args_and_body def_args in let@ () = match rt with | ReturnTypes.Computational ((_, bt), _, _) -> - let l_ret_bt = def.LogicalFunctions.return_bt in + let l_ret_bt = def.Definition.Function.return_bt in if BT.equal bt l_ret_bt then return () else @@ -695,15 +693,12 @@ let c_fun_to_it id_loc glob_context (id : Sym.t) fsym def (fn : 'bty Mu.fun_map_ } in let ctxt = { glob_context with label_defs = labels } in - let label_context = WellTyped.WProc.label_context rt labels in + let label_context = WellTyped.label_context rt labels in let@ body = - pure - (in_computational_ctxt - args_and_body - (WellTyped.BaseTyping.infer_expr label_context body)) + pure (in_computational_ctxt args_and_body (WellTyped.infer_expr label_context body)) in let@ r = symb_exec_expr ctxt (init_state, arg_map) body in - let@ it = get_ret_it loc body def.LogicalFunctions.return_bt r in + let@ it = get_ret_it loc body def.Definition.Function.return_bt r in simp_const loc (lazy (Pp_mucore.pp_expr body)) it | _ -> fail_n @@ -713,10 +708,10 @@ let c_fun_to_it id_loc glob_context (id : Sym.t) fsym def (fn : 'bty Mu.fun_map_ let upd_def (loc, sym, def_tm) = - let open LogicalFunctions in - let@ def = get_logical_function_def loc sym in - match def.definition with - | Uninterp -> add_logical_function sym { def with definition = Def def_tm } + let open Definition.Function in + let@ def = Global.get_logical_function_def loc sym in + match def.body with + | Uninterp -> Global.add_logical_function sym { def with body = Def def_tm } | _ -> fail_n { loc; @@ -728,8 +723,8 @@ let upd_def (loc, sym, def_tm) = let add_logical_funs_from_c call_funinfo funs_to_convert funs = let c_fun_pred_map = List.fold_left - (fun m Mu.{ c_fun_sym; loc; l_fun_sym } -> SymMap.add c_fun_sym (loc, l_fun_sym) m) - SymMap.empty + (fun m Mu.{ c_fun_sym; loc; l_fun_sym } -> Sym.Map.add c_fun_sym (loc, l_fun_sym) m) + Sym.Map.empty funs_to_convert in let global_context = @@ -738,11 +733,11 @@ let add_logical_funs_from_c call_funinfo funs_to_convert funs = let@ conv_defs = ListM.mapM (fun Mu.{ c_fun_sym; loc; l_fun_sym } -> - let@ def = get_logical_function_def loc l_fun_sym in + let@ def = Global.get_logical_function_def loc l_fun_sym in let@ fbody = match Pmap.lookup c_fun_sym funs with | Some fbody -> return fbody - | None -> fail_n { loc; msg = Unknown_function c_fun_sym } + | None -> fail_n { loc; msg = Global (Unknown_function c_fun_sym) } in let@ it = c_fun_to_it loc global_context l_fun_sym c_fun_sym def fbody in Pp.debug diff --git a/backend/cn/lib/check.ml b/backend/cn/lib/check.ml index a97bf0915..bfa0383c9 100644 --- a/backend/cn/lib/check.ml +++ b/backend/cn/lib/check.ml @@ -2,12 +2,11 @@ module CF = Cerb_frontend module IT = IndexTerms module BT = BaseTypes module LRT = LogicalReturnTypes +module Req = Request module RT = ReturnTypes module AT = ArgumentTypes module LAT = LogicalArgumentTypes module IdSet = Set.Make (Id) -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) module Loc = Locations module RI = ResourceInference open IT @@ -43,13 +42,16 @@ let rec check_and_match_pattern (Mu.Pattern (loc, _, bty, pattern)) it = match bty with | BT.List item_bt -> return item_bt | _ -> - fail (fun _ -> { loc; msg = Mismatch { has = !^"list"; expect = BT.pp bty } }) + fail (fun _ -> + { loc; msg = WellTyped (Mismatch { has = !^"list"; expect = BT.pp bty }) }) in let@ () = add_c loc (LC.T (eq__ it (nil_ ~item_bt loc) loc)) in return [] | Ccons, [ p1; p2 ] -> - let@ () = ensure_base_type loc ~expect:bty (List (Mu.bt_of_pattern p1)) in - let@ () = ensure_base_type loc ~expect:bty (Mu.bt_of_pattern p2) in + let@ () = + WellTyped.ensure_base_type loc ~expect:bty (List (Mu.bt_of_pattern p1)) + in + let@ () = WellTyped.ensure_base_type loc ~expect:bty (Mu.bt_of_pattern p2) in let item_bt = Mu.bt_of_pattern p1 in let@ a1 = check_and_match_pattern p1 (head_ ~item_bt it loc) in let@ a2 = check_and_match_pattern p2 (tail_ it loc) in @@ -57,7 +59,10 @@ let rec check_and_match_pattern (Mu.Pattern (loc, _, bty, pattern)) it = return (a1 @ a2) | Ctuple, pats -> let@ () = - ensure_base_type loc ~expect:bty (Tuple (List.map Mu.bt_of_pattern pats)) + WellTyped.ensure_base_type + loc + ~expect:bty + (Tuple (List.map Mu.bt_of_pattern pats)) in let@ all_as = ListM.mapiM @@ -78,7 +83,7 @@ let check_computational_bound loc s = if is_bound then return () else - fail (fun _ -> { loc; msg = Unknown_variable s }) + fail (fun _ -> { loc; msg = WellTyped (Unknown_variable s) }) let unsupported loc doc = @@ -86,12 +91,12 @@ let unsupported loc doc = let check_ptrval (loc : Locations.t) ~(expect : BT.t) (ptrval : pointer_value) : IT.t m = - let@ () = ensure_base_type loc ~expect BT.(Loc ()) in + let@ () = WellTyped.ensure_base_type loc ~expect BT.(Loc ()) in CF.Impl_mem.case_ptrval ptrval (fun ct -> let sct = Sctypes.of_ctype_unsafe loc ct in - let@ () = WellTyped.WCT.is_ct loc sct in + let@ () = WellTyped.check_ct loc sct in return (IT.null_ loc)) (function | None -> @@ -100,9 +105,9 @@ let check_ptrval (loc : Locations.t) ~(expect : BT.t) (ptrval : pointer_value) : unsupported loc !^"invalid function pointer" | Some sym -> (* just to make sure it exists *) - let@ _fun_loc, _, _ = get_fun_decl loc sym in + let@ _fun_loc, _, _ = Global.get_fun_decl loc sym in (* the symbol of a function is the same as the symbol of its address *) - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in return (sym_ (sym, BT.(Loc ()), here))) (fun prov p -> let@ alloc_id = @@ -117,7 +122,7 @@ let expect_must_be_map_bt loc ~expect = match expect with | BT.Map (index_bt, item_bt) -> return (index_bt, item_bt) | _ -> - let msg = Mismatch { has = !^"array"; expect = BT.pp expect } in + let msg = WellTyped (Mismatch { has = !^"array"; expect = BT.pp expect }) in fail (fun _ -> { loc; msg }) @@ -125,18 +130,18 @@ let rec check_mem_value (loc : Locations.t) ~(expect : BT.t) (mem : mem_value) : CF.Impl_mem.case_mem_value mem (fun ct -> - let@ () = WellTyped.WCT.is_ct loc (Sctypes.of_ctype_unsafe loc ct) in + let@ () = WellTyped.check_ct loc (Sctypes.of_ctype_unsafe loc ct) in fail (fun _ -> { loc; msg = Unspecified ct })) (fun _ _ -> unsupported loc !^"infer_mem_value: concurrent read case") (fun ity iv -> - let@ () = WellTyped.WCT.is_ct loc (Integer ity) in + let@ () = WellTyped.check_ct loc (Integer ity) in let bt = Memory.bt_of_sct (Integer ity) in let@ () = WellTyped.ensure_base_type loc ~expect bt in return (int_lit_ (Memory.int_of_ival iv) bt loc)) (fun _ft _fv -> unsupported loc !^"floats") (fun ct ptrval -> (* TODO: do anything else with ct? *) - let@ () = WellTyped.WCT.is_ct loc (Sctypes.of_ctype_unsafe loc ct) in + let@ () = WellTyped.check_ct loc (Sctypes.of_ctype_unsafe loc ct) in check_ptrval loc ~expect ptrval) (fun mem_values -> let@ index_bt, item_bt = expect_must_be_map_bt loc ~expect in @@ -144,7 +149,7 @@ let rec check_mem_value (loc : Locations.t) ~(expect : BT.t) (mem : mem_value) : let@ values = ListM.mapM (check_mem_value loc ~expect:item_bt) mem_values in return (make_array_ ~index_bt ~item_bt values loc)) (fun tag mvals -> - let@ () = WellTyped.WCT.is_ct loc (Struct tag) in + let@ () = WellTyped.check_ct loc (Struct tag) in let@ () = WellTyped.ensure_base_type loc ~expect (Struct tag) in let mvals = List.map (fun (id, ct, mv) -> (id, Sctypes.of_ctype_unsafe loc ct, mv)) mvals @@ -159,7 +164,7 @@ and check_struct (member_values : (Id.t * Sctypes.t * mem_value) list) : IT.t m = - let@ layout = get_struct_decl loc tag in + let@ layout = Global.get_struct_decl loc tag in let member_types = Memory.member_types layout in assert ( List.for_all2 @@ -188,7 +193,9 @@ let ensure_bitvector_type (loc : Locations.t) ~(expect : BT.t) : (BT.sign * int) | None -> fail (fun _ -> { loc; - msg = Mismatch { has = !^"(unspecified) bitvector type"; expect = BT.pp expect } + msg = + WellTyped + (Mismatch { has = !^"(unspecified) bitvector type"; expect = BT.pp expect }) }) @@ -215,13 +222,14 @@ let rec check_object_value (loc : Locations.t) (Mu.OV (expect, ov)) : IT.t m = assert (Option.is_some (BT.is_bits_bt index_bt)); let@ () = ListM.iterM - (fun i -> ensure_base_type loc ~expect:item_bt (Mu.bt_of_object_value i)) + (fun i -> + WellTyped.ensure_base_type loc ~expect:item_bt (Mu.bt_of_object_value i)) items in let@ values = ListM.mapM (check_object_value loc) items in return (make_array_ ~index_bt ~item_bt values loc) | OVstruct (tag, fields) -> - let@ () = ensure_base_type loc ~expect (Struct tag) in + let@ () = WellTyped.ensure_base_type loc ~expect (Struct tag) in check_struct loc tag fields | OVunion (tag, id, mv) -> check_union loc tag id mv | OVfloating _iv -> unsupported loc !^"floats" @@ -230,12 +238,12 @@ let rec check_object_value (loc : Locations.t) (Mu.OV (expect, ov)) : IT.t m = let rec check_value (loc : Locations.t) (Mu.V (expect, v)) : IT.t m = match v with | Vobject ov -> - let@ () = ensure_base_type loc ~expect (Mu.bt_of_object_value ov) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_object_value ov) in check_object_value loc ov | Vctype ct -> let@ () = WellTyped.ensure_base_type loc ~expect CType in let ct = Sctypes.of_ctype_unsafe loc ct in - let@ () = WellTyped.WCT.is_ct loc ct in + let@ () = WellTyped.check_ct loc ct in return (IT.const_ctype_ ct loc) | Vunit -> let@ () = WellTyped.ensure_base_type loc ~expect Unit in @@ -247,21 +255,23 @@ let rec check_value (loc : Locations.t) (Mu.V (expect, v)) : IT.t m = let@ () = WellTyped.ensure_base_type loc ~expect Bool in return (IT.bool_ false loc) | Vfunction_addr sym -> - let@ () = ensure_base_type loc ~expect (Loc ()) in + let@ () = WellTyped.ensure_base_type loc ~expect (Loc ()) in (* check it is a valid function address *) - let@ _ = get_fun_decl loc sym in + let@ _ = Global.get_fun_decl loc sym in return (IT.sym_ (sym, BT.(Loc ()), loc)) | Vlist (_item_cbt, vals) -> let item_bt = Mu.bt_of_value (List.hd vals) in let@ () = WellTyped.ensure_base_type loc ~expect (List item_bt) in let@ () = - ListM.iterM (fun i -> ensure_base_type loc ~expect:item_bt (Mu.bt_of_value i)) vals + ListM.iterM + (fun i -> WellTyped.ensure_base_type loc ~expect:item_bt (Mu.bt_of_value i)) + vals in let@ values = ListM.mapM (check_value loc) vals in return (list_ ~item_bt values ~nil_loc:loc) | Vtuple vals -> let item_bts = List.map Mu.bt_of_value vals in - let@ () = ensure_base_type loc ~expect (Tuple item_bts) in + let@ () = WellTyped.ensure_base_type loc ~expect (Tuple item_bts) in let@ values = ListM.mapM (check_value loc) vals in return (tuple_ values loc) @@ -270,8 +280,8 @@ let rec check_value (loc : Locations.t) (Mu.V (expect, v)) : IT.t m = (* try to follow is_representable_integer from runtime/libcore/std.core *) let is_representable_integer arg ity = - let here = Locations.other __FUNCTION__ in - let bt = IT.bt arg in + let here = Locations.other __LOC__ in + let bt = IT.get_bt arg in let arg_bits = Option.get (BT.is_bits_bt bt) in let maxInt = Memory.max_integer_type ity in assert (BT.fits_range arg_bits maxInt); @@ -311,11 +321,10 @@ let try_prove_constant loc expr = fail (fun _ -> { loc; msg = Generic (!^"model constant calculation:" ^^^ !^msg) }) in let fail_on_none msg = function Some m -> return m | None -> fail2 msg in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ m = model_with loc (IT.bool_ true here) in let@ m = fail_on_none "cannot get model" m in - let@ g = get_global () in - let@ y = fail_on_none "cannot eval term" (Solver.eval g (fst m) expr) in + let@ y = fail_on_none "cannot eval term" (Solver.eval (fst m) expr) in let@ _ = fail_on_none "eval to non-constant term" (IT.is_const y) in let eq = IT.eq_ (expr, y) here in let@ provable = provable loc in @@ -327,7 +336,7 @@ let try_prove_constant loc expr = let check_single_ct loc expr = - let@ _pointer = WellTyped.WIT.check loc BT.CType expr in + let@ _pointer = WellTyped.check_term loc BT.CType expr in let@ t = try_prove_constant loc expr in match IT.is_const t with | Some (IT.CType_const ct, _) -> return ct @@ -339,7 +348,7 @@ let check_single_ct loc expr = let is_fun_addr global t = match IT.is_sym t with | Some (s, _) -> - if SymMap.mem s global.Global.fun_decls then + if Global.is_fun_decl global s then Some s else None @@ -353,7 +362,7 @@ let known_function_pointer loc p = match already_known with | Some _ -> (* no need to find more eqs *) return () | None -> - let global_funs = SymMap.bindings global.Global.fun_decls in + let@ global_funs = Global.get_fun_decls () in let fun_addrs = List.map (fun (sym, (loc, _, _)) -> IT.sym_ (sym, BT.(Loc ()), loc)) global_funs in @@ -387,9 +396,9 @@ let check_conv_int loc ~expect ct arg = fail (fun ctxt -> { loc; msg = Int_unrepresentable { value = arg; ict = ct; ctxt; model } }) in - let bt = IT.bt arg in + let bt = IT.get_bt arg in (* TODO: can we (later) optimise this? *) - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ value = match ity with | Bool -> @@ -414,11 +423,9 @@ let check_conv_int loc ~expect ct arg = let check_against_core_bt loc msg2 cbt bt = - Typing.embed_resultat - (CoreTypeChecks.check_against_core_bt - (fun msg -> Resultat.fail { loc; msg = Generic (msg ^^ Pp.hardline ^^ msg2) }) - cbt - bt) + CoreTypeChecks.check_against_core_bt cbt bt + |> Result.map_error (fun msg -> { loc; msg = Generic (msg ^^ Pp.hardline ^^ msg2) }) + |> Typing.lift let check_has_alloc_id loc ptr ub_unspec = @@ -434,29 +441,18 @@ let check_has_alloc_id loc ptr ub_unspec = return () -let check_alloc_bounds loc ~ptr ub_unspec = - if !use_vip then ( - let here = Locations.other __FUNCTION__ in - let base_size = Alloc.History.lookup_ptr ptr here in - let base, size = Alloc.History.get_base_size base_size here in - let addr = addr_ ptr here in - let lower = le_ (base, addr) here in - let upper = le_ (addr, add_ (base, size) here) here in - let constr = and_ [ lower; upper ] here in - let@ provable = provable loc in - match provable @@ LC.T constr with - | `True -> return () - | `False -> - let@ model = model () in - let ub = CF.Undefined.(UB_CERB004_unspecified ub_unspec) in - fail (fun ctxt -> - { loc; msg = Alloc_out_of_bounds { constr; term = ptr; ub; ctxt; model } })) - else - return () +let in_bounds ptr = + let here = Locations.other __LOC__ in + let module H = Alloc.History in + let H.{ base; size } = H.(split (lookup_ptr ptr here) here) in + let addr = addr_ ptr here in + let lower = le_ (base, addr) here in + let upper = le_ (addr, add_ (base, size) here) here in + [ lower; upper ] let check_both_eq_alloc loc arg1 arg2 ub = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let both_alloc = and_ [ hasAllocId_ arg1 here; @@ -473,27 +469,40 @@ let check_both_eq_alloc loc arg1 arg2 ub = | `True -> return () -let check_live_alloc_bounds reason loc arg ub term constr = - let@ base_size = RI.Special.get_live_alloc reason loc arg in - let here = Locations.other __FUNCTION__ in - let base, size = Alloc.History.get_base_size base_size here in - if !use_vip then ( - let constr = constr ~base ~size in +(** If [ptrs] has more than one element, the allocation IDs must be equal *) +let check_live_alloc_bounds ?(skip_live = false) reason loc ub ptrs = + if !use_vip then + let@ () = + if skip_live then + return () + else + RI.Special.check_live_alloc reason loc (List.hd ptrs) + in + let here = Locations.other __LOC__ in + let constr = and_ (List.concat_map in_bounds ptrs) here in let@ provable = provable loc in match provable @@ LC.T constr with | `True -> return () | `False -> let@ model = model () in fail (fun ctxt -> - { loc; msg = Alloc_out_of_bounds { term; constr; ub; ctxt; model } })) + let term = if List.length ptrs = 1 then List.hd ptrs else IT.tuple_ ptrs here in + { loc; msg = Alloc_out_of_bounds { constr; term; ub; ctxt; model } }) else return () +let valid_for_deref loc pointer ct = + RI.Special.has_predicate + loc + (Access Deref) + ({ name = Owned (ct, Uninit); pointer; iargs = [] }, None) + + let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let orig_pe = pe in let (Mu.Pexpr (loc, _, expect, pe_)) = pe in - let@ omodel = model_with loc (bool_ true @@ Locations.other __FUNCTION__) in + let@ omodel = model_with loc (bool_ true @@ Locations.other __LOC__) in let@ () = print_with_ctxt (fun ctxt -> debug 3 (lazy (action "inferring pure expression")); @@ -514,24 +523,26 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let@ () = WellTyped.ensure_base_type loc ~expect bt in k (sym_ (sym, bt, loc)) | Value lvt -> - let@ () = WellTyped.ensure_base_type loc ~expect (IT.bt lvt) in + let@ () = WellTyped.ensure_base_type loc ~expect (IT.get_bt lvt) in k lvt) | PEval v -> - let@ () = ensure_base_type loc ~expect (Mu.bt_of_value v) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_value v) in let@ vt = check_value loc v in k vt | PEconstrained _ -> Cerb_debug.error "todo: PEconstrained" | PEctor (ctor, pes) -> (match (ctor, pes) with | Ctuple, _ -> - let@ () = ensure_base_type loc ~expect (Tuple (List.map Mu.bt_of_pexpr pes)) in + let@ () = + WellTyped.ensure_base_type loc ~expect (Tuple (List.map Mu.bt_of_pexpr pes)) + in check_pexprs pes (fun values -> k (tuple_ values loc)) | Carray, _ -> let@ index_bt, item_bt = expect_must_be_map_bt loc ~expect in assert (Option.is_some (BT.is_bits_bt index_bt)); let@ () = ListM.iterM - (fun i -> ensure_base_type loc ~expect:item_bt (Mu.bt_of_pexpr i)) + (fun i -> WellTyped.ensure_base_type loc ~expect:item_bt (Mu.bt_of_pexpr i)) pes in check_pexprs pes (fun values -> k (make_array_ ~index_bt ~item_bt values loc)) @@ -540,25 +551,33 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = match expect with | List item_bt -> return item_bt | _ -> - let msg = Mismatch { has = !^"list"; expect = BT.pp expect } in + let msg = WellTyped (Mismatch { has = !^"list"; expect = BT.pp expect }) in fail (fun _ -> { loc; msg }) in let@ () = check_against_core_bt loc !^"checking Cnil" item_cbt item_bt in k (nil_ ~item_bt loc) | Cnil _item_bt, _ -> fail (fun _ -> - { loc; msg = Number_arguments { has = List.length pes; expect = 0 } }) + { loc; + msg = + WellTyped + (Number_arguments { type_ = `Other; has = List.length pes; expect = 0 }) + }) | Ccons, [ pe1; pe2 ] -> - let@ () = ensure_base_type loc ~expect (List (Mu.bt_of_pexpr pe1)) in - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.ensure_base_type loc ~expect (List (Mu.bt_of_pexpr pe1)) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun vt1 -> check_pexpr pe2 (fun vt2 -> k (cons_ (vt1, vt2) loc))) | Ccons, _ -> fail (fun _ -> - { loc; msg = Number_arguments { has = List.length pes; expect = 2 } })) + { loc; + msg = + WellTyped + (Number_arguments { type_ = `Other; has = List.length pes; expect = 2 }) + })) | PEbitwise_unop (unop, pe1) -> let@ _ = ensure_bitvector_type loc ~expect in - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in check_pexpr pe1 (fun vt1 -> let unop = match unop with @@ -570,8 +589,8 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = k value) | PEbitwise_binop (binop, pe1, pe2) -> let@ _ = ensure_bitvector_type loc ~expect in - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe2) in let binop = match binop with BW_AND -> BW_And | BW_OR -> BW_Or | BW_XOR -> BW_Xor in @@ -583,39 +602,61 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = | Civfromfloat _ -> unsupported loc !^"floats" | PEarray_shift (pe1, ct, pe2) -> let@ () = WellTyped.ensure_base_type loc ~expect (Loc ()) in - let@ () = WellTyped.WCT.is_ct loc ct in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in + let@ () = WellTyped.check_ct loc ct in + let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun vt1 -> check_pexpr pe2 (fun vt2 -> + (* NOTE: This case should not be present - only PtrArrayShift. The issue + is that the elaboration of create_rdonly uses PtrArrayShift, but right + now we don't have fractional resources to prove that such objects are + live. Might be worth considering a read-only resource as a stop-gap. + But for now, I just skip the liveness check. *) let result = arrayShift_ ~base:vt1 ct ~index:(cast_ Memory.uintptr_bt vt2 loc) loc in - let unspec = CF.Undefined.UB_unspec_pointer_add in - let@ () = check_has_alloc_id loc vt1 unspec in - let@ () = check_alloc_bounds loc ~ptr:result unspec in + let@ has_owned = valid_for_deref loc result ct in + let@ () = + if has_owned then + return () + else ( + let unspec = CF.Undefined.UB_unspec_pointer_add in + let@ () = check_has_alloc_id loc vt1 unspec in + let ub = CF.Undefined.(UB_CERB004_unspecified unspec) in + check_live_alloc_bounds ~skip_live:true `ISO_array_shift loc ub [ result ]) + in k result)) | PEmember_shift (pe, tag, member) -> let@ () = WellTyped.ensure_base_type loc ~expect (Loc ()) in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in check_pexpr pe (fun vt -> - let@ _ = get_struct_member_type loc tag member in + let@ ct = Global.get_struct_member_type loc tag member in let result = memberShift_ (vt, tag, member) loc in - let@ () = check_has_alloc_id loc vt CF.Undefined.UB_unspec_pointer_add in - let unspec = CF.Undefined.UB_unspec_pointer_add in - let@ () = check_has_alloc_id loc vt unspec in - let@ () = check_alloc_bounds loc ~ptr:result unspec in + (* This should only be called after a PtrValidForDeref, so if we + were willing to optimise, we could skip to [k result]. *) + let@ has_owned = valid_for_deref loc result ct in + let@ () = + if has_owned then + return () + else ( + let unspec = CF.Undefined.UB_unspec_pointer_add in + let@ () = check_has_alloc_id loc vt unspec in + let ub = CF.Undefined.(UB_CERB004_unspecified unspec) in + check_live_alloc_bounds `ISO_member_shift loc ub [ result ]) + in k result) | PEnot pe -> let@ () = WellTyped.ensure_base_type loc ~expect Bool in - let@ () = ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe) in check_pexpr pe (fun vt -> k (not_ vt loc)) | PEop (op, pe1, pe2) -> let check_cmp_ty = function | BT.Integer | Bits _ | Real -> return () | ty -> fail (fun _ -> - { loc; msg = Mismatch { has = BT.pp ty; expect = !^"comparable type" } }) + { loc; + msg = WellTyped (Mismatch { has = BT.pp ty; expect = !^"comparable type" }) + }) in let not_yet x = Pp.debug 1 (lazy (Pp.item "not yet restored" (Pp_mucore_ast.pp_pexpr orig_pe))); @@ -630,7 +671,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = check_pexpr pe2 (fun v2 -> let@ provable = provable loc in let v2_bt = Mu.bt_of_pexpr pe2 in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in match provable (LC.T (ne_ (v2, int_lit_ 0 v2_bt here) here)) with | `True -> k (div_ (v1, v2) loc) | `False -> @@ -645,7 +686,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = check_pexpr pe2 (fun v2 -> let@ provable = provable loc in let v2_bt = Mu.bt_of_pexpr pe2 in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in match provable (LC.T (ne_ (v2, int_lit_ 0 v2_bt here) here)) with | `True -> k (rem_ (v1, v2) loc) | `False -> @@ -723,7 +764,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = | PEapply_fun (fun_id, args) -> let@ () = match Mu.fun_return_type fun_id args with - | Some (`Returns_BT bt) -> ensure_base_type loc ~expect bt + | Some (`Returns_BT bt) -> WellTyped.ensure_base_type loc ~expect bt | Some `Returns_Integer -> WellTyped.ensure_bits_type loc expect | None -> fail (fun _ -> @@ -737,14 +778,11 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let@ () = let has = List.length args in let expect = List.length expect_args in - if expect = has then - return () - else - fail (fun _ -> { loc; msg = Number_arguments { has; expect } }) + WellTyped.ensure_same_argument_number loc `Other has ~expect in let@ _ = ListM.map2M - (fun pe expect -> ensure_base_type loc ~expect (Mu.bt_of_pexpr pe)) + (fun pe expect -> WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe)) args expect_args in @@ -752,15 +790,18 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let@ res = CLogicalFuns.eval_fun fun_id args orig_pe in k res) | PEstruct (tag, xs) -> - let@ () = WellTyped.WCT.is_ct loc (Struct tag) in - let@ () = ensure_base_type loc ~expect (Struct tag) in - let@ layout = get_struct_decl loc tag in + let@ () = WellTyped.check_ct loc (Struct tag) in + let@ () = WellTyped.ensure_base_type loc ~expect (Struct tag) in + let@ layout = Global.get_struct_decl loc tag in let member_types = Memory.member_types layout in let@ _ = ListM.map2M (fun (id, ct) (id', pe') -> assert (Id.equal id id'); - ensure_base_type loc ~expect:(Memory.bt_of_sct ct) (Mu.bt_of_pexpr pe')) + WellTyped.ensure_base_type + loc + ~expect:(Memory.bt_of_sct ct) + (Mu.bt_of_pexpr pe')) member_types xs in @@ -769,14 +810,16 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = k (struct_ (tag, members) loc)) | PEunion _ -> Cerb_debug.error "todo: PEunion" | PEcfunction pe2 -> - let@ () = ensure_base_type loc ~expect (Tuple [ CType; List CType; Bool; Bool ]) in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe2) in + let@ () = + WellTyped.ensure_base_type loc ~expect (Tuple [ CType; List CType; Bool; Bool ]) + in + let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe2) in check_pexpr pe2 (fun ptr -> let@ _global = get_global () in (* function vals are just symbols the same as the names of functions *) let@ sym = known_function_pointer loc ptr in (* need to conjure up the characterising 4-tuple *) - let@ _, _, c_sig = get_fun_decl loc sym in + let@ _, _, c_sig = Global.get_fun_decl loc sym in match IT.const_of_c_sig c_sig loc with | Some it -> k it | None -> @@ -785,30 +828,32 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = | PEmemberof _ -> Cerb_debug.error "todo: PEmemberof" | PEbool_to_integer pe -> let@ _ = ensure_bitvector_type loc ~expect in - let@ () = ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> k (ite_ (arg, int_lit_ 1 expect loc, int_lit_ 0 expect loc) loc)) | PEbounded_binop (Bound_Wrap act, iop, pe1, pe2) -> (* in integers, perform this op and round. in bitvector types, just perform the op (for all the ops where wrapping is consistent) *) - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in assert ( match act.ct with | Integer ity when Sctypes.is_unsigned_integer_type ity -> true | _ -> false); - let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct act.ct) in - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in + let@ () = WellTyped.ensure_base_type loc ~expect (Memory.bt_of_sct act.ct) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in let@ () = WellTyped.ensure_bits_type loc expect in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in let@ () = match iop with | IOpShl | IOpShr -> return () - | _ -> ensure_base_type loc ~expect (Mu.bt_of_pexpr pe2) + | _ -> WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun arg1 -> check_pexpr pe2 (fun arg2 -> - let arg1_bt_range = BT.bits_range (Option.get (BT.is_bits_bt (IT.bt arg1))) in - let here = Locations.other __FUNCTION__ in + let arg1_bt_range = + BT.bits_range (Option.get (BT.is_bits_bt (IT.get_bt arg1))) + in + let here = Locations.other __LOC__ in let arg2_bits_lost = IT.not_ (IT.in_z_range arg2 arg1_bt_range here) here in let x = match iop with @@ -819,33 +864,37 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = ite_ ( arg2_bits_lost, IT.int_lit_ 0 expect loc, - arith_binop Terms.ShiftLeft (arg1, cast_ (IT.bt arg1) arg2 loc) loc ) + arith_binop Terms.ShiftLeft (arg1, cast_ (IT.get_bt arg1) arg2 loc) loc + ) loc | IOpShr -> ite_ ( arg2_bits_lost, IT.int_lit_ 0 expect loc, - arith_binop Terms.ShiftRight (arg1, cast_ (IT.bt arg1) arg2 loc) loc ) + arith_binop + Terms.ShiftRight + (arg1, cast_ (IT.get_bt arg1) arg2 loc) + loc ) loc in k x)) | PEbounded_binop (Bound_Except act, iop, pe1, pe2) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in let ity = match act.ct with Integer ity -> ity | _ -> assert false in - let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct act.ct) in - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in + let@ () = WellTyped.ensure_base_type loc ~expect (Memory.bt_of_sct act.ct) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe1) in let@ () = WellTyped.ensure_bits_type loc expect in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in let@ () = match iop with | IOpShl | IOpShr -> return () - | _ -> ensure_base_type loc ~expect (Mu.bt_of_pexpr pe2) + | _ -> WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe2) in let _, bits = Option.get (BT.is_bits_bt expect) in check_pexpr pe1 (fun arg1 -> check_pexpr pe2 (fun arg2 -> let large_bt = BT.Bits (BT.Signed, (2 * bits) + 4) in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let large x = cast_ large_bt x here in let direct_x, via_large_x, premise = match iop with @@ -856,11 +905,11 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = | IOpMul -> (mul_ (arg1, arg2) loc, mul_ (large arg1, large arg2) loc, bool_ true here) | IOpShl -> - ( arith_binop Terms.ShiftLeft (arg1, cast_ (IT.bt arg1) arg2 loc) loc, + ( arith_binop Terms.ShiftLeft (arg1, cast_ (IT.get_bt arg1) arg2 loc) loc, arith_binop Terms.ShiftLeft (large arg1, large arg2) loc, IT.in_z_range arg2 (Z.zero, Z.of_int bits) loc ) | IOpShr -> - ( arith_binop Terms.ShiftRight (arg1, cast_ (IT.bt arg1) arg2 loc) loc, + ( arith_binop Terms.ShiftRight (arg1, cast_ (IT.get_bt arg1) arg2 loc) loc, arith_binop Terms.ShiftRight (large arg1, large arg2) loc, IT.in_z_range arg2 (Z.zero, Z.of_int bits) loc ) in @@ -878,24 +927,24 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = in k direct_x)) | PEconv_int (ct_expr, pe) | PEconv_loaded_int (ct_expr, pe) -> - let@ () = ensure_base_type loc ~expect:CType (Mu.bt_of_pexpr ct_expr) in + let@ () = WellTyped.ensure_base_type loc ~expect:CType (Mu.bt_of_pexpr ct_expr) in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in check_pexpr ct_expr (fun ct_it -> let@ ct = check_single_ct loc ct_it in - let@ () = WellTyped.WCT.is_ct loc ct in - let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct ct) in + let@ () = WellTyped.check_ct loc ct in + let@ () = WellTyped.ensure_base_type loc ~expect (Memory.bt_of_sct ct) in check_pexpr pe (fun lvt -> let@ vt = check_conv_int loc ~expect ct lvt in k vt)) | PEwrapI (act, pe) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> let bt = Memory.bt_of_sct act.ct in let@ () = WellTyped.ensure_bits_type loc bt in k (cast_ bt arg loc)) | PEcatch_exceptional_condition (act, pe) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> let bt = Memory.bt_of_sct act.ct in @@ -909,15 +958,15 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = let ub = CF.Undefined.UB036_exceptional_condition in fail (fun ctxt -> { loc; msg = Undefined_behaviour { ub; ctxt; model } })) | PEis_representable_integer (pe, act) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in let@ () = WellTyped.ensure_base_type loc ~expect Bool in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in let ity = Option.get (Sctypes.is_integer_type act.ct) in check_pexpr pe (fun arg -> k (is_representable_integer arg ity)) | PEif (pe, e1, e2) -> - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr e1) in - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr e2) in - let@ () = ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr e1) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr e2) in + let@ () = WellTyped.ensure_base_type loc ~expect:Bool (Mu.bt_of_pexpr pe) in check_pexpr pe (fun c -> let aux e cond name = let@ () = add_c loc (LC.T cond) in @@ -925,7 +974,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = 5 (lazy (Pp.item ("checking consistency of " ^ name ^ "-branch") (IT.pp cond))); let@ provable = provable loc in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in match provable (LC.T (bool_ false here)) with | `True -> Pp.debug 5 (lazy (Pp.headline "inconsistent, skipping")); @@ -935,12 +984,14 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = check_pexpr e k in let@ () = pure (aux e1 c "then") in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ () = pure (aux e2 (not_ c here) "else") in return ()) | PElet (p, e1, e2) -> - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr e2) in - let@ () = ensure_base_type loc ~expect:(Mu.bt_of_pexpr e1) (Mu.bt_of_pattern p) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr e2) in + let@ () = + WellTyped.ensure_base_type loc ~expect:(Mu.bt_of_pexpr e1) (Mu.bt_of_pattern p) + in check_pexpr e1 (fun v1 -> let@ bound_a = check_and_match_pattern p v1 in check_pexpr e2 (fun lvt -> @@ -948,7 +999,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = k lvt)) | PEundef (loc, ub) -> let@ provable = provable loc in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in (match provable (LC.T (bool_ false here)) with | `True -> return () | `False -> @@ -956,7 +1007,7 @@ let rec check_pexpr (pe : BT.t Mu.pexpr) (k : IT.t -> unit m) : unit m = fail (fun ctxt -> { loc; msg = Undefined_behaviour { ub; ctxt; model } })) | PEerror (err, _pe) -> let@ provable = provable loc in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in (match provable (LC.T (bool_ false here)) with | `True -> return () | `False -> @@ -983,7 +1034,7 @@ module Spine : sig val calltype_lt : Loc.t -> BT.t Mu.pexpr list -> - AT.lt * label_kind -> + AT.lt * Where.label -> (False.t -> unit m) -> unit m @@ -1053,7 +1104,7 @@ end = struct | _ -> let expect = count_computational original_ftyp in let has = List.length original_args in - fail (fun _ -> { loc; msg = Number_arguments { expect; has } }) + WellTyped.ensure_same_argument_number loc `Other has ~expect in fun args ftyp k -> aux [] args ftyp k in @@ -1061,12 +1112,14 @@ end = struct let check_arg_pexpr (pe : BT.t Mu.pexpr) ~expect k = - let@ () = ensure_base_type (Mu.loc_of_pexpr pe) ~expect (Mu.bt_of_pexpr pe) in + let@ () = + WellTyped.ensure_base_type (Mu.loc_of_pexpr pe) ~expect (Mu.bt_of_pexpr pe) + in check_pexpr pe k - let check_arg_it (loc, it_arg) ~(expect : LogicalSorts.t) k = - let@ it_arg = WellTyped.WIT.check loc expect it_arg in + let check_arg_it (loc, it_arg) ~(expect : BT.t) k = + let@ it_arg = WellTyped.check_term loc expect it_arg in k it_arg @@ -1112,9 +1165,8 @@ let all_empty loc _original_resources = match remaining_resources with | [] -> return () | (resource, constr, model) :: _ -> - let@ global = get_global () in let@ simp_ctxt = simp_ctxt () in - RI.debug_constraint_failure_diagnostics 6 model global simp_ctxt constr; + RI.debug_constraint_failure_diagnostics 6 model simp_ctxt constr; fail (fun ctxt -> (* let ctxt = { ctxt with resources = original_resources } in *) { loc; msg = Unused_resource { resource; ctxt; model } }) @@ -1163,7 +1215,7 @@ let _check_used_distinct loc used = Generic (Pp.item "undefined behaviour: concurrent update" - (Resources.pp r + (Resource.pp r ^^^ break 1 ^^^ render_upd h ^^^ break 1 @@ -1182,7 +1234,7 @@ let _check_used_distinct loc used = Generic (Pp.item "undefined behaviour: concurrent read & update" - (Resources.pp r + (Resource.pp r ^^^ break 1 ^^^ render_read h ^^^ break 1 @@ -1192,7 +1244,7 @@ let _check_used_distinct loc used = ListM.iterM check_rd (List.concat (List.map fst used)) -(*type labels = (AT.lt * label_kind) SymMap.t*) +(*type labels = (AT.lt * label_kind) Sym.Map.t*) let load loc pointer ct = let@ value = @@ -1211,17 +1263,17 @@ let load loc pointer ct = let instantiate loc filter arg = let arg_s = Sym.fresh_make_uniq "instance" in - let arg_it = sym_ (arg_s, IT.bt arg, loc) in - let@ () = add_l arg_s (IT.bt arg_it) (loc, lazy (Sym.pp arg_s)) in + let arg_it = sym_ (arg_s, IT.get_bt arg, loc) in + let@ () = add_l arg_s (IT.get_bt arg_it) (loc, lazy (Sym.pp arg_s)) in let@ () = add_c loc (LC.T (eq__ arg_it arg loc)) in let@ constraints = get_cs () in let extra_assumptions1 = List.filter_map (function LC.Forall ((s, bt), t) when filter t -> Some ((s, bt), t) | _ -> None) - (ResourceTypes.LCSet.elements constraints) + (LC.Set.elements constraints) in let extra_assumptions2, type_mismatch = - List.partition (fun ((_, bt), _) -> BT.equal bt (IT.bt arg_it)) extra_assumptions1 + List.partition (fun ((_, bt), _) -> BT.equal bt (IT.get_bt arg_it)) extra_assumptions1 in let extra_assumptions = List.map @@ -1238,7 +1290,7 @@ let instantiate loc filter arg = Pp.warn loc (!^"did not instantiate on basetype mismatch:" - ^^^ Pp.list BT.pp [ bt; IT.bt arg_it ])) + ^^^ Pp.list BT.pp [ bt; IT.get_bt arg_it ])) type_mismatch; add_cs loc extra_assumptions @@ -1273,10 +1325,23 @@ let add_trace_information _labels annots = return () +let bytes_qpred sym size pointer init : Req.QPredicate.t = + let here = Locations.other __LOC__ in + let bt' = WellTyped.default_quantifier_bt in + { q = (sym, bt'); + q_loc = here; + step = IT.num_lit_ Z.one bt' here; + permission = IT.(lt_ (sym_ (sym, bt', here), size) here); + name = Owned (Sctypes.uchar_ct, init); + pointer; + iargs = [] + } + + let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let (Expr (loc, annots, expect, e_)) = e in let@ () = add_trace_information labels annots in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ omodel = model_with loc (bool_ true here) in match omodel with | None -> @@ -1289,12 +1354,16 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = debug 3 (lazy (item "expr" (group (Pp_mucore.pp_expr e)))); debug 3 (lazy (item "ctxt" (Context.pp ctxt)))) in + let bytes_qpred sym ct pointer init : Req.QPredicate.t = + let here = Locations.other __LOC__ in + bytes_qpred sym (sizeOf_ ct here) pointer init + in (match e_ with | Epure pe -> - let@ () = ensure_base_type loc ~expect (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_pexpr pe) in check_pexpr pe (fun lvt -> k lvt) | Ememop memop -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let pointer_eq ?(negate = false) pe1 pe2 = let@ () = WellTyped.ensure_base_type loc ~expect Bool in let k, case, res = @@ -1324,13 +1393,13 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in let@ provable = provable loc in let@ () = - match provable @@ LC.T ambiguous with - | `False -> return () - | `True -> + match provable @@ LC.T (not_ ambiguous here) with + | `True -> return () + | `False -> let msg = Printf.sprintf - "ambiguous pointer %sequality case: addresses equal, but \ - provenances differ" + "Cannot rule out ambiguous pointer %sequality case (addresses \ + equal, but provenances differ)" case in warn loc !^msg; @@ -1365,32 +1434,15 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = here) *))) in - let both_in_bounds ~base ~size arg1 arg2 = - let addr1, addr2 = (addr_ arg1 here, addr_ arg2 here) in - let lower1, lower2 = (le_ (base, addr1) here, le_ (base, addr2) here) in - let upper1, upper2 = - ( le_ (addr1, add_ (base, size) here) here, - le_ (addr2, add_ (base, size) here) here ) - in - and_ [ lower1; lower2; upper1; upper2 ] here - in let pointer_op op pe1 pe2 = let ub = CF.Undefined.UB053_distinct_aggregate_union_pointer_comparison in - let@ () = ensure_base_type loc ~expect Bool in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.ensure_base_type loc ~expect Bool in + let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in + let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun arg1 -> check_pexpr pe2 (fun arg2 -> let@ () = check_both_eq_alloc loc arg1 arg2 ub in - let@ () = - check_live_alloc_bounds - `Ptr_cmp - loc - arg1 - ub - (IT.tuple_ [ arg1; arg2 ] here) - (both_in_bounds arg1 arg2) - in + let@ () = check_live_alloc_bounds `Ptr_cmp loc ub [ arg1; arg2 ] in k (op (arg1, arg2)))) in (match memop with @@ -1401,10 +1453,16 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | PtrLe (pe1, pe2) -> pointer_op (Fun.flip lePointer_ loc) pe1 pe2 | PtrGe (pe1, pe2) -> pointer_op (Fun.flip gePointer_ loc) pe1 pe2 | Ptrdiff (act, pe1, pe2) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in - let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct (Integer Ptrdiff_t)) in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe2) in + let@ () = WellTyped.check_ct act.loc act.ct in + let@ () = + WellTyped.ensure_base_type loc ~expect (Memory.bt_of_sct (Integer Ptrdiff_t)) + in + let@ () = + WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) + in + let@ () = + WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe2) + in check_pexpr pe1 (fun arg1 -> check_pexpr pe2 (fun arg2 -> (* copying and adapting from memory/concrete/impl_mem.ml *) @@ -1417,17 +1475,9 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = check_both_eq_alloc loc arg1 arg2 ub in let ub_unspec = CF.Undefined.UB_unspec_pointer_sub in let ub = CF.Undefined.(UB_CERB004_unspecified ub_unspec) in - let@ () = - check_live_alloc_bounds - `Ptr_diff - loc - arg1 - ub - (IT.tuple_ [ arg1; arg2 ] here) - (both_in_bounds arg1 arg2) - in let ptr_diff_bt = Memory.bt_of_sct (Integer Ptrdiff_t) in - let value = + let@ () = check_live_alloc_bounds `Ptr_diff loc ub [ arg1; arg2 ] in + let result = (* TODO: confirm that the cast from uintptr_t to ptrdiff_t yields the expected result, or signal UB050_pointers_subtraction_not_representable *) @@ -1436,13 +1486,13 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = int_lit_ divisor ptr_diff_bt loc ) loc in - k value)) + k result)) | IntFromPtr (act_from, act_to, pe) -> - let@ () = WellTyped.WCT.is_ct act_from.loc act_from.ct in - let@ () = WellTyped.WCT.is_ct act_to.loc act_to.ct in + let@ () = WellTyped.check_ct act_from.loc act_from.ct in + let@ () = WellTyped.check_ct act_to.loc act_to.ct in assert (match act_to.ct with Integer _ -> true | _ -> false); - let@ () = ensure_base_type loc ~expect (Memory.bt_of_sct act_to.ct) in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.ensure_base_type loc ~expect (Memory.bt_of_sct act_to.ct) in + let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> let actual_value = cast_ (Memory.bt_of_sct act_to.ct) arg loc in (* NOTE: After discussing with Kavyan @@ -1452,7 +1502,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = allocations are exposed. (2) So, the only UB possible is unrepresentable results. *) let@ provable = provable loc in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let lc = LC.T (representable_ (act_to.ct, arg) here) in let@ () = match provable lc with @@ -1465,8 +1515,8 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in k actual_value) | PtrFromInt (act_from, act_to, pe) -> - let@ () = WellTyped.WCT.is_ct act_from.loc act_from.ct in - let@ () = WellTyped.WCT.is_ct act_to.loc act_to.ct in + let@ () = WellTyped.check_ct act_from.loc act_from.ct in + let@ () = WellTyped.check_ct act_to.loc act_to.ct in let@ () = WellTyped.ensure_base_type loc ~expect (Loc ()) in let@ () = WellTyped.ensure_base_type @@ -1478,7 +1528,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = check_pexpr pe (fun arg -> let sym, result = IT.fresh_named (BT.Loc ()) "intToPtr" loc in let@ _ = add_a sym (Loc ()) (here, lazy (Sym.pp sym)) in - let cond = eq_ (arg, int_lit_ 0 (bt arg) here) here in + let cond = eq_ (arg, int_lit_ 0 (get_bt arg) here) here in let null_case = eq_ (result, null_ here) here in (* NOTE: the allocation ID is intentionally left unconstrained *) let alloc_case = @@ -1493,53 +1543,57 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = k result) | PtrValidForDeref (act, pe) -> (* TODO (DCM, VIP) *) - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in let@ () = WellTyped.ensure_base_type loc ~expect Bool in let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in - (* TODO (DCM, VIP): check. Also: this is the same as PtrWellAligned *) + (* TODO (DCM, VIP): error if called on Void or Function Ctype. + return false if resource missing *) check_pexpr pe (fun arg -> - let value = aligned_ (arg, act.ct) loc in - k value) + (* let unspec = CF.Undefined.UB_unspec_pointer_add in *) + (* let@ () = check_has_alloc_id loc arg unspec in *) + (* let index = num_lit_ Z.one Memory.uintptr_bt here in *) + (* let check_this = arrayShift_ ~base:arg ~index act.ct loc in *) + (* let ub = CF.Undefined.(UB_CERB004_unspecified unspec) in *) + (* let@ () = check_live_alloc_bounds `ISO_array_shift loc ub [ check_this ] in *) + let result = aligned_ (arg, act.ct) loc in + k result) | PtrWellAligned (act, pe) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in let@ () = WellTyped.ensure_base_type loc ~expect Bool in let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in - (* TODO (DCM, VIP) check *) + (* TODO (DCM, VIP): error if called on Void or Function Ctype *) check_pexpr pe (fun arg -> - let value = aligned_ (arg, act.ct) loc in - k value) + (* let unspec = CF.Undefined.UB_unspec_pointer_add in *) + (* let@ () = check_has_alloc_id loc arg unspec in *) + let result = aligned_ (arg, act.ct) loc in + k result) | PtrArrayShift (pe1, act, pe2) -> - let@ () = ensure_base_type loc ~expect (Loc ()) in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) in - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.ensure_base_type loc ~expect (Loc ()) in + let@ () = + WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe1) + in + let@ () = WellTyped.check_ct act.loc act.ct in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe2) in check_pexpr pe1 (fun vt1 -> check_pexpr pe2 (fun vt2 -> let result = - arrayShift_ ~base:vt1 ~index:(cast_ Memory.uintptr_bt vt2 loc) act.ct loc + arrayShift_ ~base:vt1 act.ct ~index:(cast_ Memory.uintptr_bt vt2 loc) loc in - let ub_unspec = CF.Undefined.UB_unspec_pointer_add in - let ub = CF.Undefined.(UB_CERB004_unspecified ub_unspec) in - let@ () = check_has_alloc_id loc vt1 ub_unspec in - let here = Locations.other __FUNCTION__ in + let@ has_owned = valid_for_deref loc result act.ct in let@ () = - check_live_alloc_bounds - `ISO_array_shift - loc - vt1 - ub - result - (fun ~base ~size -> - let addr = addr_ result here in - let lower = le_ (base, addr) here in - let upper = le_ (addr, add_ (base, size) here) here in - and_ [ lower; upper ] here) + if has_owned then + k result + else ( + let unspec = CF.Undefined.UB_unspec_pointer_add in + let@ () = check_has_alloc_id loc vt1 unspec in + let ub = CF.Undefined.(UB_CERB004_unspecified unspec) in + check_live_alloc_bounds `ISO_array_shift loc ub [ result ]) in k result)) - | PtrMemberShift (_tag_sym, _memb_ident, _pe) -> - (* FIXME(CHERI merge) *) - (* there is now an effectful variant of the member shift operator (which is UB when creating an out of bound pointer) *) - Cerb_debug.error "todo: PtrMemberShift" + | PtrMemberShift _ -> + unsupported + (Loc.other __LOC__) + !^"PtrMemberShift should be a CHERI only construct" | CopyAllocId (pe1, pe2) -> let@ () = WellTyped.ensure_base_type loc ~expect:Memory.uintptr_bt (Mu.bt_of_pexpr pe1) @@ -1549,21 +1603,17 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in check_pexpr pe1 (fun vt1 -> check_pexpr pe2 (fun vt2 -> + let unspec = CF.Undefined.UB_unspec_copy_alloc_id in + let@ () = check_has_alloc_id loc vt2 unspec in + let ub = CF.Undefined.(UB_CERB004_unspecified unspec) in let result = copyAllocId_ ~addr:vt1 ~loc:vt2 loc in - let ub_unspec = CF.Undefined.UB_unspec_copy_alloc_id in - let@ () = check_has_alloc_id loc vt2 ub_unspec in - let ub = CF.Undefined.(UB_CERB004_unspecified ub_unspec) in - let@ () = - check_live_alloc_bounds `Copy_alloc_id loc vt2 ub vt1 (fun ~base ~size -> - let addr = vt1 in - let lower = le_ (base, addr) here in - let upper = le_ (addr, add_ (base, size) here) here in - and_ [ lower; upper ] here) - in + let@ () = check_live_alloc_bounds `Copy_alloc_id loc ub [ result ] in k result)) - | Memcpy _ (* (asym 'bty * asym 'bty * asym 'bty) *) -> - Cerb_debug.error "todo: Memcpy" - | Memcmp _ (* (asym 'bty * asym 'bty * asym 'bty) *) -> + | Memcpy _ -> + (* should have been intercepted by memcpy_proxy *) + assert false + | Memcmp _ -> + (* TODO (DCM, VIP) *) Cerb_debug.error "todo: Memcmp" | Realloc _ (* (asym 'bty * asym 'bty * asym 'bty) *) -> Cerb_debug.error "todo: Realloc" @@ -1574,7 +1624,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | Eaction (Paction (_pol, Action (_aloc, action_))) -> (match action_ with | Create (pe, act, prefix) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in let@ () = WellTyped.ensure_base_type loc ~expect (Loc ()) in let@ () = WellTyped.ensure_bits_type loc (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> @@ -1590,7 +1640,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = IT.fresh_named (BT.Loc ()) ("&ARG" ^ string_of_int n) loc | _ -> IT.fresh (BT.Loc ()) loc in - let@ () = add_a ret_s (IT.bt ret) (loc, lazy (Pp.string "allocation")) in + let@ () = add_a ret_s (IT.get_bt ret) (loc, lazy (Pp.string "allocation")) in (* let@ () = add_c loc (LC.T (representable_ (Pointer act.ct, ret) loc)) in *) let align_v = cast_ Memory.uintptr_bt arg loc in let@ () = add_c loc (LC.T (alignedI_ ~align:align_v ~t:ret loc)) in @@ -1613,17 +1663,21 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = else return () in - let@ () = add_r loc (P (RET.make_alloc ret), O lookup) in + let@ () = add_r loc (P (Req.make_alloc ret), O lookup) in let@ () = record_action (Create ret, loc) in k ret) | CreateReadOnly (_sym1, _ct, _sym2, _prefix) -> Cerb_debug.error "todo: CreateReadOnly" - | Alloc (_ct, _sym, _prefix) -> Cerb_debug.error "todo: Alloc" - | Kill (Dynamic, _asym) -> Cerb_debug.error "todo: Free" + | Alloc (_ct, _sym, _prefix) -> + (* TODO (DCM, VIP) *) + Cerb_debug.error "todo: Alloc" + | Kill (Dynamic, _asym) -> + (* TODO (DCM, VIP) *) + Cerb_debug.error "todo: Free" | Kill (Static ct, pe) -> - let@ () = WellTyped.WCT.is_ct loc ct in + let@ () = WellTyped.check_ct loc ct in let@ () = WellTyped.ensure_base_type loc ~expect Unit in - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in + let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr pe) in check_pexpr pe (fun arg -> let@ _ = RI.Special.predicate_request @@ -1632,12 +1686,12 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = ({ name = Owned (ct, Uninit); pointer = arg; iargs = [] }, None) in let@ _ = - RI.Special.predicate_request loc (Access Kill) (RET.make_alloc arg, None) + RI.Special.predicate_request loc (Access Kill) (Req.make_alloc arg, None) in let@ () = record_action (Kill arg, loc) in k (unit_ loc)) | Store (_is_locking, act, p_pe, v_pe, _mo) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in let@ () = WellTyped.ensure_base_type loc ~expect Unit in let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr p_pe) @@ -1655,7 +1709,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = representable and done the right thing. Pointers, as I understand, are an exception. *) let@ () = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let in_range_lc = representable_ (act.ct, varg) here in let@ provable = provable loc in let holds = provable (LC.T in_range_lc) in @@ -1684,7 +1738,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = record_action (Write (parg, varg), loc) in k (unit_ loc))) | Load (act, p_pe, _mo) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in let@ () = WellTyped.ensure_base_type loc ~expect (Memory.bt_of_sct act.ct) in let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr p_pe) @@ -1706,7 +1760,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = WellTyped.ensure_base_type loc ~expect Unit in k (unit_ loc) | Eccall (act, f_pe, pes) -> - let@ () = WellTyped.WCT.is_ct act.loc act.ct in + let@ () = WellTyped.check_ct act.loc act.ct in (* copied TS's, from wellTyped.ml *) (* let@ (_ret_ct, _arg_cts) = match act.ct with *) (* | Pointer (Function (ret_v_ct, arg_r_cts, is_variadic)) -> *) @@ -1715,11 +1769,11 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = (* | _ -> fail (fun _ -> {loc; msg = Generic (Pp.item "not a function pointer at call-site" *) (* (Sctypes.pp act.ct))}) *) (* in *) - let@ () = ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr f_pe) in + let@ () = WellTyped.ensure_base_type loc ~expect:(Loc ()) (Mu.bt_of_pexpr f_pe) in check_pexpr f_pe (fun f_it -> let@ _global = get_global () in let@ fsym = known_function_pointer loc f_it in - let@ _loc, opt_ft, _ = get_fun_decl loc fsym in + let@ _loc, opt_ft, _ = Global.get_fun_decl loc fsym in let@ ft = match opt_ft with | Some ft -> return ft @@ -1739,16 +1793,23 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ lvt = bind_return loc members rt in k lvt)) | Eif (c_pe, e1, e2) -> - let@ () = ensure_base_type (Mu.loc_of_expr e1) ~expect (Mu.bt_of_expr e1) in - let@ () = ensure_base_type (Mu.loc_of_expr e2) ~expect (Mu.bt_of_expr e2) in let@ () = - ensure_base_type (Mu.loc_of_pexpr c_pe) ~expect:Bool (Mu.bt_of_pexpr c_pe) + WellTyped.ensure_base_type (Mu.loc_of_expr e1) ~expect (Mu.bt_of_expr e1) + in + let@ () = + WellTyped.ensure_base_type (Mu.loc_of_expr e2) ~expect (Mu.bt_of_expr e2) + in + let@ () = + WellTyped.ensure_base_type + (Mu.loc_of_pexpr c_pe) + ~expect:Bool + (Mu.bt_of_pexpr c_pe) in check_pexpr c_pe (fun carg -> let aux lc _nm e = let@ () = add_c loc (LC.T lc) in let@ provable = provable loc in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in match provable (LC.T (bool_ false here)) with | `True -> return () | `False -> check_expr labels e k @@ -1757,13 +1818,17 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = pure (aux (not_ carg loc) "false" e2) in return ()) | Ebound e -> - let@ () = ensure_base_type (Mu.loc_of_expr e) ~expect (Mu.bt_of_expr e) in + let@ () = + WellTyped.ensure_base_type (Mu.loc_of_expr e) ~expect (Mu.bt_of_expr e) + in check_expr labels e k | End _ -> Cerb_debug.error "todo: End" | Elet (p, e1, e2) -> - let@ () = ensure_base_type (Mu.loc_of_expr e2) ~expect (Mu.bt_of_expr e2) in let@ () = - ensure_base_type + WellTyped.ensure_base_type (Mu.loc_of_expr e2) ~expect (Mu.bt_of_expr e2) + in + let@ () = + WellTyped.ensure_base_type (Mu.loc_of_pattern p) ~expect:(Mu.bt_of_pexpr e1) (Mu.bt_of_pattern p) @@ -1774,7 +1839,9 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = remove_as bound_a in k rt)) | Eunseq es -> - let@ () = ensure_base_type loc ~expect (Tuple (List.map Mu.bt_of_expr es)) in + let@ () = + WellTyped.ensure_base_type loc ~expect (Tuple (List.map Mu.bt_of_expr es)) + in let rec aux es vs prev_used = match es with | e :: es' -> @@ -1789,33 +1856,21 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in aux es [] [] | CN_progs (_, cn_progs) -> - let bytes_pred ct pointer init : RET.predicate_type = + let bytes_pred ct pointer init : Req.Predicate.t = { name = Owned (ct, init); pointer; iargs = [] } in - let bytes_qpred sym ct pointer init : RET.qpredicate_type = - let here = Locations.other __FUNCTION__ in - let bt' = WellTyped.quantifier_bt in - { q = (sym, bt'); - q_loc = here; - step = IT.num_lit_ Z.one bt' here; - permission = IT.(lt_ (sym_ (sym, bt', here), sizeOf_ ct here) here); - name = Owned (Sctypes.uchar_ct, init); - pointer; - iargs = [] - } - in let bytes_constraints ~(value : IT.t) ~(byte_arr : IT.t) (ct : Sctypes.t) = (* FIXME this hard codes big endianness but this should be switchable *) - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in match ct with | Sctypes.Void | Array (_, _) | Struct _ | Function (_, _, _) -> assert false | Integer it -> - let bt = IT.bt value in + let bt = IT.get_bt value in let lhs = value in let rhs = let[@ocaml.warning "-8"] (b :: bytes) = List.init (Memory.size_of_integer_type it) (fun i -> - let index = int_lit_ i WellTyped.quantifier_bt here in + let index = int_lit_ i WellTyped.default_quantifier_bt here in let casted = cast_ bt (map_get_ byte_arr index here) here in let shift_amt = int_lit_ (i * 8) bt here in IT.IT (Binop (ShiftLeft, casted, shift_amt), bt, here)) @@ -1825,7 +1880,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = eq_ (lhs, rhs) here | Pointer _ -> (* FIXME this totally ignores provenances *) - let bt = WellTyped.quantifier_bt in + let bt = WellTyped.default_quantifier_bt in let lhs = cast_ bt value here in let rhs = let[@ocaml.warning "-8"] (b :: bytes) = @@ -1849,7 +1904,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | To_from_bytes ((To | From), { name = PName _; _ }) -> fail (fun _ -> { loc; msg = Byte_conv_needs_owned }) | To_from_bytes (To, { name = Owned (ct, init); pointer; _ }) -> - let@ pointer = WellTyped.WIT.infer pointer in + let@ pointer = WellTyped.infer_term pointer in let@ (_, O value), _ = RI.Special.predicate_request loc @@ -1857,7 +1912,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = (bytes_pred ct pointer init, None) in let q_sym = Sym.fresh_named "to_bytes" in - let bt = WellTyped.quantifier_bt in + let bt = WellTyped.default_quantifier_bt in let map_bt = BT.Map (bt, Memory.bt_of_sct Sctypes.uchar_ct) in let byte_sym, byte_arr = IT.fresh_named map_bt "byte_arr" here in let@ () = add_a byte_sym map_bt (loc, lazy (Pp.string "byte array")) in @@ -1866,7 +1921,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | Uninit -> add_c loc (LC.T (IT.eq_ (byte_arr, default_ map_bt here) here)) | Init -> add_c loc (LC.T (bytes_constraints ~value ~byte_arr ct))) | To_from_bytes (From, { name = Owned (ct, init); pointer; _ }) -> - let@ pointer = WellTyped.WIT.infer pointer in + let@ pointer = WellTyped.infer_term pointer in let q_sym = Sym.fresh_named "from_bytes" in let@ (_, O byte_arr), _ = RI.Special.qpredicate_request @@ -1888,20 +1943,20 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | Uninit -> add_c loc (LC.T (IT.eq_ (value, default_ value_bt here) here)) | Init -> add_c loc (LC.T (bytes_constraints ~value ~byte_arr ct))) | Have lc -> - let@ _lc = WellTyped.WLC.welltyped loc lc in + let@ _lc = WellTyped.logical_constraint loc lc in fail (fun _ -> { loc; msg = Generic !^"todo: 'have' not implemented yet" }) | Instantiate (to_instantiate, it) -> let@ filter = match to_instantiate with | I_Everything -> return (fun _ -> true) | I_Function f -> - let@ _ = get_logical_function_def loc f in + let@ _ = Global.get_logical_function_def loc f in return (IT.mentions_call f) | I_Good ct -> - let@ () = WellTyped.WCT.is_ct loc ct in + let@ () = WellTyped.check_ct loc ct in return (IT.mentions_good ct) in - let@ it = WellTyped.WIT.infer it in + let@ it = WellTyped.infer_term it in instantiate loc filter it | Split_case _ -> assert false | Extract (attrs, to_extract, it) -> @@ -1914,22 +1969,22 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let msg = "'extract' requires a C-type annotation for 'Owned'" in fail (fun _ -> { loc; msg = Generic !^msg }) | E_Pred (CN_owned (Some ct)) -> - let@ () = WellTyped.WCT.is_ct loc ct in - return (ResourceTypes.Owned (ct, Init)) + let@ () = WellTyped.check_ct loc ct in + return (Request.Owned (ct, Init)) | E_Pred (CN_block None) -> let msg = "'extract' requires a C-type annotation for 'Block'" in fail (fun _ -> { loc; msg = Generic !^msg }) | E_Pred (CN_block (Some ct)) -> - let@ () = WellTyped.WCT.is_ct loc ct in - return (ResourceTypes.Owned (ct, Uninit)) + let@ () = WellTyped.check_ct loc ct in + return (Request.Owned (ct, Uninit)) | E_Pred (CN_named pn) -> - let@ _ = get_resource_predicate_def loc pn in - return (ResourceTypes.PName pn) + let@ _ = Global.get_resource_predicate_def loc pn in + return (Request.PName pn) in - let@ it = WellTyped.WIT.infer it in + let@ it = WellTyped.infer_term it in let@ original_rs, _ = all_resources_tagged loc in (* let verbose = List.exists (Id.is_str "verbose") attrs in *) - let quiet = List.exists (Id.is_str "quiet") attrs in + let quiet = List.exists (Id.equal_string "quiet") attrs in let@ () = add_movable_index loc (predicate_name, it) in let@ upd_rs, _ = all_resources_tagged loc in if @@ -1941,22 +1996,19 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = (); return () | Unfold (f, args) -> - let@ def = get_logical_function_def loc f in + let@ def = Global.get_logical_function_def loc f in let has_args, expect_args = (List.length args, List.length def.args) in let@ () = - WellTyped.ensure_same_argument_number - loc - `General - has_args - ~expect:expect_args + WellTyped.ensure_same_argument_number loc `Other has_args ~expect:expect_args in let@ args = ListM.map2M - (fun has_arg (_, def_arg_bt) -> WellTyped.WIT.check loc def_arg_bt has_arg) + (fun has_arg (_, def_arg_bt) -> + WellTyped.check_term loc def_arg_bt has_arg) args def.args in - (match LogicalFunctions.unroll_once def args with + (match Definition.Function.unroll_once def args with | None -> let msg = !^"Cannot unfold definition of uninterpreted function" ^^^ Sym.pp f ^^ dot @@ -1965,7 +2017,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = | Some body -> add_c loc (LC.T (eq_ (apply_ f args def.return_bt loc, body) loc))) | Apply (lemma, args) -> - let@ _loc, lemma_typ = get_lemma loc lemma in + let@ _loc, lemma_typ = Global.get_lemma loc lemma in let args = List.map (fun arg -> (loc, arg)) args in Spine.calltype_lemma loc ~lemma args lemma_typ (fun lrt -> let@ _, members = @@ -1977,15 +2029,14 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = bind_logical_return loc members lrt in return ()) | Assert lc -> - let@ lc = WellTyped.WLC.welltyped loc lc in + let@ lc = WellTyped.logical_constraint loc lc in let@ provable = provable loc in (match provable lc with | `True -> return () | `False -> let@ model = model () in let@ simp_ctxt = simp_ctxt () in - let@ global = get_global () in - RI.debug_constraint_failure_diagnostics 6 model global simp_ctxt lc; + RI.debug_constraint_failure_diagnostics 6 model simp_ctxt lc; let@ () = Diagnostics.investigate model lc in fail (fun ctxt -> { loc; @@ -1995,7 +2046,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = })) | Inline _nms -> return () | Print it -> - let@ it = WellTyped.WIT.infer it in + let@ it = WellTyped.infer_term it in let@ simp_ctxt = simp_ctxt () in let it = Simplify.IndexTerms.simp simp_ctxt it in print stdout (item "printed" (IT.pp it)); @@ -2004,8 +2055,8 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let rec loop = function | [] -> k (unit_ loc) | Cnprog.Let (loc, (sym, { ct; pointer }), cn_prog) :: cn_progs -> - let@ pointer = WellTyped.WIT.check loc (Loc ()) pointer in - let@ () = WellTyped.WCT.is_ct loc ct in + let@ pointer = WellTyped.check_term loc (Loc ()) pointer in + let@ () = WellTyped.check_ct loc ct in let@ value = load loc pointer ct in let subbed = Cnprog.subst (IT.make_subst [ (sym, value) ]) cn_prog in loop (subbed :: cn_progs) @@ -2013,7 +2064,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = (match cn_statement with | Cnprog.Split_case lc -> Pp.debug 5 (lazy (Pp.headline "checking split_case")); - let@ lc = WellTyped.WLC.welltyped loc lc in + let@ lc = WellTyped.logical_constraint loc lc in let@ it = match lc with | T it -> return it @@ -2025,7 +2076,7 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = add_c loc (LC.T it) in debug 5 (lazy (item ("splitting case " ^ nm) (IT.pp it))); let@ provable = provable loc in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in match provable (LC.T (bool_ false here)) with | `True -> Pp.debug 5 (lazy (Pp.headline "inconsistent, skipping")); @@ -2043,9 +2094,9 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = in loop cn_progs | Ewseq (p, e1, e2) | Esseq (p, e1, e2) -> - let@ () = ensure_base_type loc ~expect (Mu.bt_of_expr e2) in + let@ () = WellTyped.ensure_base_type loc ~expect (Mu.bt_of_expr e2) in let@ () = - ensure_base_type + WellTyped.ensure_base_type (Mu.loc_of_pattern p) ~expect:(Mu.bt_of_expr e1) (Mu.bt_of_pattern p) @@ -2056,9 +2107,9 @@ let rec check_expr labels (e : BT.t Mu.expr) (k : IT.t -> unit m) : unit m = let@ () = remove_as bound_a in k it2)) | Erun (label_sym, pes) -> - let@ () = ensure_base_type loc ~expect Unit in + let@ () = WellTyped.ensure_base_type loc ~expect Unit in let@ lt, lkind = - match SymMap.find_opt label_sym labels with + match Sym.Map.find_opt label_sym labels with | None -> fail (fun _ -> { loc; msg = Generic (!^"undefined code label" ^/^ Sym.pp label_sym) }) @@ -2097,7 +2148,7 @@ let check_expr_top loc labels rt e = let bind_arguments (_loc : Locations.t) (full_args : _ Mu.arguments) = let rec aux_l resources = function | Mu.Define ((s, it), ((loc, _) as info), args) -> - let@ () = add_l s (IT.bt it) (fst info, lazy (Sym.pp s)) in + let@ () = add_l s (IT.get_bt it) (fst info, lazy (Sym.pp s)) in let@ () = add_c (fst info) (LC.T (def_ s it loc)) in aux_l resources args | Constraint (lc, info, args) -> @@ -2105,7 +2156,7 @@ let bind_arguments (_loc : Locations.t) (full_args : _ Mu.arguments) = aux_l resources args | Resource ((s, (re, bt)), ((loc, _) as info), args) -> let@ () = add_l s bt (fst info, lazy (Sym.pp s)) in - aux_l (resources @ [ (re, Resources.O (sym_ (s, bt, loc))) ]) args + aux_l (resources @ [ (re, Resource.O (sym_ (s, bt, loc))) ]) args | I i -> return (i, resources) in let rec aux_a = function @@ -2138,7 +2189,7 @@ let check_procedure pure (let@ () = modify_where (Where.set_function fsym) in let@ (body, label_defs, rt), initial_resources = bind_arguments loc args_and_body in - let label_context = WellTyped.WProc.label_context rt label_defs in + let label_context = WellTyped.label_context rt label_defs in let label_defs = Pmap.bindings_list label_defs in let@ (), _mete_pre_state = debug 2 (lazy (headline ("checking function body " ^ Sym.pp_string fsym))); @@ -2156,7 +2207,7 @@ let check_procedure pure (match def with | Mu.Return _loc -> return () - | Label (loc, label_args_and_body, _annots, _) -> + | Label (loc, label_args_and_body, _annots, _, _loop_info) -> debug 2 (lazy @@ -2169,7 +2220,7 @@ let check_procedure bind_arguments loc label_args_and_body in let@ () = add_rs loc label_resources in - let _, label_kind, loc = SymMap.find lsym label_context in + let _, label_kind, loc = Sym.Map.find lsym label_context in let@ () = modify_where Where.(set_section (Label { loc; label = label_kind })) in @@ -2189,8 +2240,8 @@ let record_tagdefs tagDefs = PmapM.iterM (fun tag def -> match def with - | Mu.UnionDef -> unsupported (Loc.other __FUNCTION__) !^"todo: union types" - | StructDef layout -> add_struct_decl tag layout) + | Mu.UnionDef -> unsupported (Loc.other __LOC__) !^"todo: union types" + | StructDef layout -> Global.add_struct_decl tag layout) tagDefs @@ -2199,7 +2250,7 @@ let check_tagdefs tagDefs = (fun _tag def -> let open Memory in match def with - | Mu.UnionDef -> unsupported (Loc.other __FUNCTION__) !^"todo: union types" + | Mu.UnionDef -> unsupported (Loc.other __LOC__) !^"todo: union types" | StructDef layout -> let@ _ = ListM.fold_rightM @@ -2209,7 +2260,7 @@ let check_tagdefs tagDefs = (* this should have been checked earlier by the frontend *) assert false | Some (name, ct) -> - let@ () = WellTyped.WCT.is_ct (Loc.other __FUNCTION__) ct in + let@ () = WellTyped.check_ct (Loc.other __LOC__) ct in return (IdSet.add name have) | None -> return have) layout @@ -2221,7 +2272,7 @@ let check_tagdefs tagDefs = let record_and_check_logical_functions funs = let recursive, _nonrecursive = - List.partition (fun (_, def) -> LogicalFunctions.is_recursive def) funs + List.partition (fun (_, def) -> Definition.Function.is_recursive def) funs in let n_funs = List.length funs in (* Add all recursive functions (without their actual bodies), so that they @@ -2229,8 +2280,8 @@ let record_and_check_logical_functions funs = let@ () = ListM.iterM (fun (name, def) -> - let@ simple_def = WellTyped.WLFD.welltyped { def with definition = Uninterp } in - add_logical_function name simple_def) + let@ simple_def = WellTyped.function_ { def with body = Uninterp } in + Global.add_logical_function name simple_def) recursive in (* Now check all functions in order. *) @@ -2244,8 +2295,8 @@ let record_and_check_logical_functions funs = ^ Pp.of_total i n_funs ^ ": " ^ Sym.pp_string name))); - let@ def = WellTyped.WLFD.welltyped def in - add_logical_function name def) + let@ def = WellTyped.function_ def in + Global.add_logical_function name def) funs @@ -2254,8 +2305,8 @@ let record_and_check_resource_predicates preds = let@ () = ListM.iterM (fun (name, def) -> - let@ simple_def = WellTyped.WRPD.welltyped { def with clauses = None } in - add_resource_predicate name simple_def) + let@ simple_def = WellTyped.predicate { def with clauses = None } in + Global.add_resource_predicate name simple_def) preds in ListM.iteriM @@ -2268,35 +2319,32 @@ let record_and_check_resource_predicates preds = ^ Pp.of_total i (List.length preds) ^ ": " ^ Sym.pp_string name))); - let@ def = WellTyped.WRPD.welltyped def in + let@ def = WellTyped.predicate def in (* add simplified def to the context *) - add_resource_predicate name def) + Global.add_resource_predicate name def) preds -let record_globals : 'bty. (Sym.t * 'bty Mu.globs) list -> unit m = +let record_globals : 'bty. (Sym.t * 'bty Mu.globs) list -> LC.t list m = fun globs -> - (* TODO: check the expressions *) - ListM.iterM - (fun (sym, def) -> + ListM.fold_leftM + (fun acc (sym, def) -> match def with | Mu.GlobalDef (ct, _) | GlobalDecl ct -> - let@ () = WellTyped.WCT.is_ct (Loc.other __FUNCTION__) ct in + let@ () = WellTyped.check_ct (Loc.other __LOC__) ct in let bt = BT.(Loc ()) in - let info = (Loc.other __FUNCTION__, lazy (Pp.item "global" (Sym.pp sym))) in + let info = (Loc.other __LOC__, lazy (Pp.item "global" (Sym.pp sym))) in let@ () = add_a sym bt info in - let here = Locations.other __FUNCTION__ in - let@ () = - add_c here (LC.T (IT.good_pointer ~pointee_ct:ct (sym_ (sym, bt, here)) here)) - in + let here = Locations.other __LOC__ in + let good = LC.T (IT.good_pointer ~pointee_ct:ct (sym_ (sym, bt, here)) here) in let ptr = sym_ (sym, bt, here) in - let@ () = add_c here (LC.T (IT.hasAllocId_ ptr here)) in - let@ () = - if !IT.use_vip then ( - let base_size = Alloc.History.lookup_ptr ptr here in - let base, size = Alloc.History.get_base_size base_size here in + let hasAllocId = LC.T (IT.hasAllocId_ ptr here) in + let range = + if !IT.use_vip then + let module H = Alloc.History in + let H.{ base; size } = H.(split (lookup_ptr ptr here) here) in let addr = addr_ ptr here in - let upper = Resources.upper_bound addr ct here in + let upper = IT.upper_bound addr ct here in let bounds = and_ [ le_ (base, addr) here; @@ -2305,11 +2353,13 @@ let record_globals : 'bty. (Sym.t * 'bty Mu.globs) list -> unit m = ] here in - add_c here (LC.T bounds)) + [ LC.T bounds ] else - return () + [] in - return ()) + (* TODO: check the expressions *) + return (good :: hasAllocId :: (range @ acc))) + [] globs @@ -2347,11 +2397,11 @@ let wf_check_and_record_functions funs call_sigs = match def with | Mu.Proc { loc; args_and_body; trusted = tr; _ } -> welltyped_ping i fsym; - let@ args_and_body = WellTyped.WProc.welltyped loc args_and_body in - let ft = WellTyped.WProc.typ args_and_body in + let@ args_and_body = WellTyped.procedure loc args_and_body in + let ft = WellTyped.to_argument_type args_and_body in debug 6 (lazy (!^"function type" ^^^ Sym.pp fsym)); debug 6 (lazy (CF.Pp_ast.pp_doc_tree (AT.dtree RT.dtree ft))); - let@ () = add_fun_decl fsym (loc, Some ft, Pmap.find fsym call_sigs) in + let@ () = Global.add_fun_decl fsym (loc, Some ft, Pmap.find fsym call_sigs) in (match tr with | Trusted _ -> return ((fsym, (loc, ft)) :: trusted, checked) | Checked -> return (trusted, (fsym, (loc, args_and_body)) :: checked)) @@ -2361,10 +2411,10 @@ let wf_check_and_record_functions funs call_sigs = match oft with | None -> return None | Some ft -> - let@ ft = WellTyped.WFT.welltyped "function" loc ft in + let@ ft = WellTyped.function_type "function" loc ft in return (Some ft) in - let@ () = add_fun_decl fsym (loc, oft, Pmap.find fsym call_sigs) in + let@ () = Global.add_fun_decl fsym (loc, oft, Pmap.find fsym call_sigs) in return (trusted, checked)) funs ([], []) @@ -2378,24 +2428,27 @@ let c_function_name ((fsym, (_loc, _args_and_body)) : c_function) : string = (** Filter functions according to [skip_and_only]: first according to "only", then according to "skip" *) -let select_functions (funs : c_function list) : c_function list = +let select_functions (fsyms : Sym.Set.t) : Sym.Set.t = let matches_str s fsym = String.equal s (Sym.pp_string fsym) in let str_fsyms s = - match List.filter (matches_str s) (List.map fst funs) with - | [] -> + let ss = Sym.Set.filter (matches_str s) fsyms in + if Sym.Set.is_empty ss then ( Pp.warn_noloc (!^"function" ^^^ !^s ^^^ !^"not found"); - [] - | ss -> ss + Sym.Set.empty) + else + ss + in + let strs_fsyms ss = + ss |> List.map str_fsyms |> List.fold_left Sym.Set.union Sym.Set.empty in - let strs_fsyms ss = SymSet.of_list (List.concat_map str_fsyms ss) in let skip = strs_fsyms (fst !skip_and_only) in let only = strs_fsyms (snd !skip_and_only) in let only_funs = match snd !skip_and_only with - | [] -> funs - | _ss -> List.filter (fun (fsym, _) -> SymSet.mem fsym only) funs + | [] -> fsyms + | _ss -> Sym.Set.filter (fun fsym -> Sym.Set.mem fsym only) fsyms in - List.filter (fun (fsym, _) -> not (SymSet.mem fsym skip)) only_funs + Sym.Set.filter (fun fsym -> not (Sym.Set.mem fsym skip)) only_funs (** Check a single C function. Failure of the check is encoded monadically. *) @@ -2458,7 +2511,10 @@ let check_c_functions_all (funs : c_function list) : (string * TypeErrors.t) lis with the name of the function in which they occurred. When [fail_fast] is set, the first error encountered will halt checking. *) let check_c_functions (funs : c_function list) : (string * TypeErrors.t) list m = - let selected_funs = select_functions funs in + let selected_fsyms = select_functions (Sym.Set.of_list (List.map fst funs)) in + let selected_funs = + List.filter (fun (fsym, _) -> Sym.Set.mem fsym selected_fsyms) funs + in match !fail_fast with | true -> let@ error_opt = check_c_functions_fast selected_funs in @@ -2469,40 +2525,42 @@ let check_c_functions (funs : c_function list) : (string * TypeErrors.t) list m (* (Sym.t * (Locations.t * ArgumentTypes.lemmat)) list *) let wf_check_and_record_lemma (lemma_s, (loc, lemma_typ)) = - let@ lemma_typ = WellTyped.WLemma.welltyped loc lemma_s lemma_typ in - let@ () = add_lemma lemma_s (loc, lemma_typ) in + let@ lemma_typ = WellTyped.lemma loc lemma_s lemma_typ in + let@ () = Global.add_lemma lemma_s (loc, lemma_typ) in return (lemma_s, (loc, lemma_typ)) let ctz_proxy_ft = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let info = (here, Some "ctz_proxy builtin ft") in let n_sym, n = IT.fresh_named BT.(Bits (Unsigned, 32)) "n_" here in let ret_sym, ret = IT.fresh_named BT.(Bits (Signed, 32)) "return" here in - let neq_0 = LC.T (IT.not_ (IT.eq_ (n, IT.int_lit_ 0 (IT.bt n) here) here) here) in + let neq_0 = LC.T (IT.not_ (IT.eq_ (n, IT.int_lit_ 0 (IT.get_bt n) here) here) here) in let eq_ctz = LC.T (IT.eq_ - (ret, cast_ (IT.bt ret) (IT.arith_unop Terms.BW_CTZ_NoSMT n here) here) + (ret, cast_ (IT.get_bt ret) (IT.arith_unop Terms.BW_CTZ_NoSMT n here) here) here) in let rt = - RT.mComputational ((ret_sym, IT.bt ret), info) (LRT.mConstraint (eq_ctz, info) LRT.I) + RT.mComputational + ((ret_sym, IT.get_bt ret), info) + (LRT.mConstraint (eq_ctz, info) LRT.I) in let ft = AT.mComputationals - [ (n_sym, IT.bt n, info) ] + [ (n_sym, IT.get_bt n, info) ] (AT.L (LAT.mConstraint (neq_0, info) (LAT.I rt))) in ft let ffs_proxy_ft sz = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let sz_name = CF.Pp_ail.string_of_integerBaseType sz in let bt = Memory.bt_of_sct Sctypes.(Integer (Signed sz)) in let ret_bt = Memory.bt_of_sct Sctypes.(Integer (Signed Int_)) in - let info = (Locations.other __FUNCTION__, Some ("ffs_proxy builtin ft: " ^ sz_name)) in + let info = (Locations.other __LOC__, Some ("ffs_proxy builtin ft: " ^ sz_name)) in let n_sym, n = IT.fresh_named bt "n_" here in let ret_sym, ret = IT.fresh_named ret_bt "return" here in let eq_ffs = @@ -2516,27 +2574,85 @@ let ffs_proxy_ft sz = ft -let add_stdlib_spec call_sigs fsym = - match Sym.has_id fsym with - (* FIXME: change the naming, we aren't unfolding these *) - | Some s when Setup.unfold_stdlib_name s -> - let add ft = - Pp.debug - 2 - (lazy (Pp.headline ("adding builtin spec for procedure " ^ Sym.pp_string fsym))); - add_fun_decl fsym (Locations.other __FUNCTION__, Some ft, Pmap.find fsym call_sigs) - in - if String.equal s "ctz_proxy" then - add ctz_proxy_ft - else if String.equal s "ffs_proxy" then - add (ffs_proxy_ft Sctypes.IntegerBaseTypes.Int_) - else if String.equal s "ffsl_proxy" then - add (ffs_proxy_ft Sctypes.IntegerBaseTypes.Long) - else if String.equal s "ffsll_proxy" then - add (ffs_proxy_ft Sctypes.IntegerBaseTypes.LongLong) - else - return () - | _ -> return () +let memcpy_proxy_ft = + let here = Locations.other __LOC__ in + let info = (here, Some "memcpy_proxy") in + (* C arguments *) + let dest_sym, dest = IT.fresh_named (BT.Loc ()) "dest" here in + let src_sym, src = IT.fresh_named (BT.Loc ()) "src" here in + let n_sym, n = IT.fresh_named Memory.size_bt "n" here in + (* requires *) + let q_bt = WellTyped.default_quantifier_bt in + let uchar_bt = Memory.bt_of_sct Sctypes.uchar_ct in + let map_bt = BT.Map (q_bt, uchar_bt) in + let destIn_sym, _ = IT.fresh_named map_bt "destIn" here in + let srcIn_sym, srcIn = IT.fresh_named map_bt "srcIn" here in + let destRes str init = Req.Q (bytes_qpred (Sym.fresh_named str) n dest init) in + let srcRes str = Req.Q (bytes_qpred (Sym.fresh_named str) n src Init) in + (* ensures *) + let ret_sym, ret = IT.fresh_named (BT.Loc ()) "return" here in + let destOut_sym, destOut = IT.fresh_named map_bt "destOut" here in + let srcOut_sym, srcOut = IT.fresh_named map_bt "srcOut" here in + AT.mComputationals + [ (dest_sym, Loc (), info); (src_sym, Loc (), info); (n_sym, Memory.size_bt, info) ] + (AT.L + (LAT.mResources + [ ((destIn_sym, (destRes "i_d" Uninit, map_bt)), info); + ((srcIn_sym, (srcRes "i_s", map_bt)), info) + ] + (LAT.I + (RT.mComputational + ((ret_sym, BT.Loc ()), info) + (LRT.mResources + [ ((destOut_sym, (destRes "j_d" Init, map_bt)), info); + ((srcOut_sym, (srcRes "j_s", map_bt)), info) + ] + (LRT.Constraint + ( LC.T + (and_ + [ eq_ (ret, dest) here; + eq_ (srcIn, srcOut) here; + eq_ (srcIn, destOut) here + ] + here), + info, + I ))))))) + + +let add_stdlib_spec = + let module StrMap = Map.Make (String) in + let proxies = + List.fold_left + (fun map (name, ft) -> StrMap.add name ft map) + StrMap.empty + [ ("ctz_proxy", ctz_proxy_ft); + ("ffs_proxy", ffs_proxy_ft Sctypes.IntegerBaseTypes.Int_); + ("ffsl_proxy", ffs_proxy_ft Sctypes.IntegerBaseTypes.Long); + ("ffsll_proxy", ffs_proxy_ft Sctypes.IntegerBaseTypes.LongLong); + ("memcpy_proxy", memcpy_proxy_ft) + ] + in + let add ct fsym ft = + Pp.debug + 2 + (lazy (Pp.headline ("adding builtin spec for procedure " ^ Sym.pp_string fsym))); + Global.add_fun_decl fsym (Locations.other __LOC__, Some ft, ct) + in + fun call_sigs fsym -> + match + Option.( + let@ s = Sym.has_id fsym in + let@ ft = StrMap.find_opt s proxies in + (* The C signatures for most of the proxies are included in + ./runtime/libc/include/builtins.h, and so show up in every file, + regardless of whether or not they are used, but the same is not true + for memcpy (its C signature is only present when it is used) hence + (1) the extra lookup and (2) it being safe to skip if absent *) + let@ ct = Pmap.lookup fsym call_sigs in + return (ft, ct)) + with + | None -> return () + | Some (ft, ct) -> add ct fsym ft let record_and_check_datatypes datatypes = @@ -2544,28 +2660,28 @@ let record_and_check_datatypes datatypes = let@ () = ListM.iterM (fun (s, Mu.{ loc = _; cases = _ }) -> - add_datatype s { constrs = []; all_params = [] }) + Global.add_datatype s { constrs = []; all_params = [] }) datatypes in (* check and normalise datatypes *) - let@ datatypes = ListM.mapM WellTyped.WDT.welltyped datatypes in - let@ sccs = WellTyped.WDT.check_recursion_ok datatypes in - let@ () = set_datatype_order (Some sccs) in + let@ datatypes = ListM.mapM WellTyped.datatype datatypes in + let@ sccs = WellTyped.datatype_recursion datatypes in + let@ () = Global.set_datatype_order (Some sccs) in (* properly add datatypes *) ListM.iterM (fun (s, Mu.{ loc = _; cases }) -> let@ () = - add_datatype + Global.add_datatype s { constrs = List.map fst cases; all_params = List.concat_map snd cases } in ListM.iterM - (fun (c, params) -> add_datatype_constr c { params; datatype_tag = s }) + (fun (c, params) -> Global.add_datatype_constr c { params; datatype_tag = s }) cases) datatypes -(** Note: this does not check loop invariants and CN statements! *) +(** NOTE: not clear if this checks loop invariants and CN statements! *) let check_decls_lemmata_fun_specs (file : unit Mu.file) = Cerb_debug.begin_csv_timing (); (* decl, lemmata, function specification checking *) @@ -2573,11 +2689,10 @@ let check_decls_lemmata_fun_specs (file : unit Mu.file) = let@ () = record_tagdefs file.tagDefs in let@ () = check_tagdefs file.tagDefs in let@ () = record_and_check_datatypes file.datatypes in - let@ () = init_solver () in - let@ () = record_globals file.globs in + let@ global_var_constraints = record_globals file.globs in let@ () = register_fun_syms file in let@ () = - ListM.iterM (add_stdlib_spec file.call_funinfo) (SymSet.elements file.stdlib_syms) + ListM.iterM (add_stdlib_spec file.call_funinfo) (Sym.Set.elements file.stdlib_syms) in Pp.debug 3 (lazy (Pp.headline "added top-level types and constants.")); let@ () = record_and_check_logical_functions file.logical_predicates in @@ -2590,14 +2705,46 @@ let check_decls_lemmata_fun_specs (file : unit Mu.file) = let@ _trusted, checked = wf_check_and_record_functions file.funs file.call_funinfo in Pp.debug 3 (lazy (Pp.headline "type-checked C functions and specifications.")); Cerb_debug.end_csv_timing "decl, lemmata, function specification checking"; - return (List.rev checked, lemmata) + return (List.rev checked, global_var_constraints, lemmata) (** With CSV timing enabled, check the provided functions with [check_c_functions]. See that function for more information on the semantics of checking. *) -let time_check_c_functions (checked : c_function list) : (string * TypeErrors.t) list m = +let time_check_c_functions (global_var_constraints, (checked : c_function list)) + : (string * TypeErrors.t) list m + = Cerb_debug.begin_csv_timing () (*type checking functions*); + let@ () = init_solver () in + let here = Locations.other __LOC__ in + let@ () = add_cs here global_var_constraints in + let@ global = get_global () in + let@ () = + Sym.Map.fold + (fun _ def acc -> + (* I think this avoids a left-recursion in the monad bind *) + let@ () = Consistent.predicate def in + acc) + global.resource_predicates + (return ()) + in + let@ () = + Sym.Map.fold + (fun _ (loc, def, _) acc -> + match def with + | None -> acc + | Some def -> + (* I think this avoids a left-recursion in the monad bind *) + let@ () = Consistent.function_type "proc/fun" loc def in + acc) + global.fun_decls + (return ()) + in + let@ () = + ListM.iterM + (fun (_, (loc, args_and_body)) -> Consistent.procedure loc args_and_body) + checked + in let@ errors = check_c_functions checked in Cerb_debug.end_csv_timing "type checking functions"; return errors @@ -2606,7 +2753,17 @@ let time_check_c_functions (checked : c_function list) : (string * TypeErrors.t) let generate_lemmas lemmata o_lemma_mode = let@ global = get_global () in match o_lemma_mode with - | Some mode -> embed_resultat (Lemmata.generate global mode lemmata) + | Some mode -> + let@ () = + Sym.Map.fold + (fun sym (loc, lemma_typ) acc -> + (* I think this avoids a left-recursion in the monad bind *) + let@ () = Consistent.lemma loc sym lemma_typ in + acc) + global.lemmata + (return ()) + in + lift (Lemmata.generate global mode lemmata) | None -> return () (* TODO: diff --git a/backend/cn/lib/cn_internal_to_ail.ml b/backend/cn/lib/cn_internal_to_ail.ml index 29f2a9639..2cf75ca01 100644 --- a/backend/cn/lib/cn_internal_to_ail.ml +++ b/backend/cn/lib/cn_internal_to_ail.ml @@ -6,6 +6,7 @@ module CF = Cerb_frontend open CF.Cn open Compile open Executable_spec_utils +module ESE = Executable_spec_extract module A = CF.AilSyntax module C = CF.Ctype module BT = BaseTypes @@ -43,19 +44,17 @@ let rec cn_base_type_to_bt = function module MembersKey = struct - type t = (Id.t * Sym.t cn_base_type) list + type t = (Id.t * BT.t) list let rec compare (ms : t) ms' = match (ms, ms') with | [], [] -> 0 | _, [] -> 1 | [], _ -> -1 - | (id, cn_bt) :: ms, (id', cn_bt') :: ms' -> - let c = String.compare (Id.s id) (Id.s id') in + | (id, bt) :: ms, (id', bt') :: ms' -> + let c = String.compare (Id.get_string id) (Id.get_string id') in if c == 0 then ( - let c' = - BaseTypes.compare (cn_base_type_to_bt cn_bt) (cn_base_type_to_bt cn_bt') - in + let c' = BaseTypes.compare bt bt' in if c' == 0 then compare ms ms' else @@ -73,10 +72,11 @@ let generic_cn_dt_sym = Sym.fresh_pretty "cn_datatype" let create_id_from_sym ?(lowercase = false) sym = let str = Sym.pp_string sym in let str = if lowercase then String.lowercase_ascii str else str in - Id.id str + let here = Locations.other __LOC__ in + Id.make here str -let create_sym_from_id id = Sym.fresh_pretty (Id.pp_string id) +let create_sym_from_id id = Sym.fresh_pretty (Id.get_string id) let generate_sym_with_suffix ?(suffix = "_tag") @@ -96,6 +96,7 @@ let generate_error_msg_info_update_stats ?(cn_source_loc_opt = None) () = | Some loc -> let loc_str = Cerb_location.location_to_string loc in let _, loc_str_2 = Cerb_location.head_pos_of_location loc in + let loc_str_escaped = Str.global_replace (Str.regexp_string "\"") "\'" loc_str in let loc_str_2_escaped = Str.global_replace (Str.regexp_string "\n") "\\n" loc_str_2 in @@ -104,7 +105,9 @@ let generate_error_msg_info_update_stats ?(cn_source_loc_opt = None) () = in let cn_source_loc_str = mk_expr - A.(AilEstr (None, [ (Cerb_location.unknown, [ loc_str_2_escaped ^ loc_str ]) ])) + A.( + AilEstr + (None, [ (Cerb_location.unknown, [ loc_str_2_escaped ^ loc_str_escaped ]) ])) in cn_source_loc_str | None -> mk_expr A.(AilEconst ConstantNull) @@ -142,9 +145,9 @@ let rec bt_to_cn_base_type = function | Bits (sign, size) -> CN_bits ((match sign with Unsigned -> CN_unsigned | Signed -> CN_signed), size) | Real -> CN_real - | MemByte -> failwith (__FUNCTION__ ^ ": TODO MemByte") + | MemByte -> failwith (__LOC__ ^ ": TODO MemByte") | Alloc_id -> CN_alloc_id - | CType -> failwith (__FUNCTION__ ^ ": TODO Ctype") + | CType -> failwith (__LOC__ ^ ": TODO Ctype") | Loc () -> CN_loc | Struct tag -> CN_struct tag | Datatype tag -> CN_datatype tag @@ -171,8 +174,8 @@ let str_of_bt_bitvector_type sign size = let augment_record_map ?cn_sym bt = let sym_prefix = match cn_sym with Some sym' -> sym' | None -> Sym.fresh () in - match bt_to_cn_base_type bt with - | CN_record members -> + match bt with + | BT.Record members -> (* Augment records map if entry does not exist already *) if not (RecordMap.mem members !records) then ( let sym' = generate_sym_with_suffix ~suffix:"_record" sym_prefix in @@ -188,10 +191,7 @@ let lookup_records_map members = ("Record not found in map (" ^ String.concat ", " - (List.map - (fun (x, cbt) -> - Pp.(plain (BT.pp (cn_base_type_to_bt cbt) ^^ space ^^ Id.pp x))) - members) + (List.map (fun (x, bt) -> Pp.(plain (BT.pp bt ^^ space ^^ Id.pp x))) members) ^ ")") @@ -214,7 +214,10 @@ let rec cn_to_ail_base_type ?pred_sym:(_ = None) cn_typ = (* gets replaced with typedef anyway (TODO: clean up) *) | CN_struct sym -> C.(Struct (generate_sym_with_suffix ~suffix:"_cn" sym)) | CN_record members -> - let sym = lookup_records_map members in + let sym = + lookup_records_map + (List.map (fun (id, bt) -> (id, cn_base_type_to_bt bt)) members) + in Struct sym (* Every struct is converted into a struct pointer *) | CN_datatype sym -> Struct sym @@ -223,7 +226,7 @@ let rec cn_to_ail_base_type ?pred_sym:(_ = None) cn_typ = generate_ail_array bt (* TODO: What is the optional second pair element for? Have just put None for now *) | CN_tuple _ts -> - failwith (__FUNCTION__ ^ ":Tuples not yet supported") + failwith (__LOC__ ^ ":Tuples not yet supported") (* Printf.printf "Entered CN_tuple case\n"; *) (* let some_id = create_id_from_sym (Sym.fresh_pretty "some_sym") in let members = List.map (fun t -> (some_id, t)) ts in @@ -362,6 +365,9 @@ let get_underscored_typedef_string_from_bt ?(is_record = false) bt = let suffix = if is_record then "" else "_cn" in let cn_sym = generate_sym_with_suffix ~suffix sym in Some ("struct_" ^ Sym.pp_string cn_sym) + | BT.Record ms -> + let sym = lookup_records_map ms in + Some ("struct_" ^ Sym.pp_string sym) | _ -> None) @@ -496,80 +502,6 @@ let get_equality_fn_call bt e1 e2 _dts = (CF.Pp_utils.to_plain_pretty_string (BT.pp bt))))) -let rearrange_start_inequality sym (IT.(IT (_, _, loc)) as e1) e2 = - match IT.term e2 with - | IT.Binop (binop, (IT.IT (Sym sym1, _, _) as expr1), (IT.IT (Sym sym2, _, _) as expr2)) - -> - if Sym.equal sym sym1 then ( - let inverse_binop = - match binop with - | Add -> IT.Sub - | Sub -> Add - | _ -> failwith "Other binops not supported" - in - IT.(Binop (inverse_binop, e1, expr2))) - else if Sym.equal sym sym2 then ( - match binop with - | Add -> IT.Binop (Sub, e1, expr1) - | Sub -> failwith "Minus not supported" - | _ -> failwith "Other binops not supported") - else - failwith "Not of correct form" - | _ -> - failwith ("TODO rearrange_start_inequality at " ^ Cerb_location.simple_location loc) - - -let generate_start_expr start_cond sym = - let start_expr, binop = - match IT.term start_cond with - | IT.(Binop (binop, expr1, IT.IT (Sym sym', _, _))) -> - if Sym.equal sym sym' then - (expr1, binop) - else - failwith "Not of correct form (unlikely case - i's not matching)" - | IT.(Binop (binop, expr1, expr2)) -> - ( IT.IT - (rearrange_start_inequality sym expr1 expr2, BT.Integer, Cerb_location.unknown), - binop ) - | _ -> failwith "Not of correct form: more complicated RHS of binexpr than just i" - in - match binop with - | LE -> start_expr - | LT -> - let one = - IT.(IT (Const (IT.Z (Z.of_int 1)), IT.bt start_expr, Cerb_location.unknown)) - in - IT.(IT (Binop (Add, start_expr, one), IT.bt start_expr, Cerb_location.unknown)) - | _ -> failwith "Not of correct form: not Le or Lt" - - -let rec get_leftmost_of_and_expr = function - | IT.IT (IT.(Binop (And, lhs, _rhs)), _, _) -> get_leftmost_of_and_expr lhs - | lhs -> lhs - - -let rec get_rest_of_expr_r_aux it = - match IT.term it with - | IT.(Binop (And, lhs, rhs)) -> - let r = get_rest_of_expr_r_aux lhs in - (match IT.term r with - | Const (Bool true) -> rhs - | _ -> IT.IT (IT.(Binop (And, r, rhs)), BT.Bool, IT.loc it)) - | _lhs -> IT.IT (Const (Bool true), BT.Bool, IT.loc it) - - -let get_rest_of_expr_r it = - match IT.term it with - | IT.(Binop (And, lhs, rhs)) -> - let is_simple = - match (IT.term lhs, IT.term rhs) with - | Binop (And, _, _), _ | _, Binop (And, _, _) -> false - | _, _ -> true - in - if is_simple then rhs else get_rest_of_expr_r_aux it - | _ -> IT.IT (Const (Bool true), BT.Bool, IT.loc it) - - let convert_from_cn_bool_sym = Sym.fresh_named (Option.get (get_conversion_from_fn_str BT.Bool)) @@ -741,25 +673,29 @@ let empty_for_dest : type a. a dest -> a = | PassBack -> ([], [], mk_expr empty_ail_expr) -let generate_check_ownership_function ~with_ownership_checking ctype +let generate_get_or_put_ownership_function ~without_ownership_checking ctype : A.sigma_declaration * CF.GenTypes.genTypeCategory A.sigma_function_definition = let ctype_str = str_of_ctype ctype in (* Printf.printf ("ctype_str: %s\n") ctype_str; *) let ctype_str = String.concat "_" (String.split_on_char ' ' ctype_str) in - let fn_sym = Sym.fresh_pretty ("check_owned_" ^ ctype_str) in + let fn_sym = Sym.fresh_pretty ("owned_" ^ ctype_str) in let param1_sym = Sym.fresh_pretty "cn_ptr" in + let here = Locations.other __LOC__ in let cast_expr = mk_expr A.( AilEcast ( empty_qualifiers, mk_ctype C.(Pointer (empty_qualifiers, ctype)), - mk_expr (AilEmemberofptr (mk_expr (AilEident param1_sym), Id.id "ptr")) )) + mk_expr (AilEmemberofptr (mk_expr (AilEident param1_sym), Id.make here "ptr")) + )) in let generic_c_ptr_sym = Sym.fresh_pretty "generic_c_ptr" in let generic_c_ptr_bs, generic_c_ptr_ss = - if with_ownership_checking then ( + if without_ownership_checking then + ([], []) + else ( let uintptr_t_type = C.uintptr_t in let generic_c_ptr_binding = create_binding generic_c_ptr_sym uintptr_t_type in let uintptr_t_cast_expr = @@ -769,8 +705,6 @@ let generate_check_ownership_function ~with_ownership_checking ctype A.(AilSdeclaration [ (generic_c_ptr_sym, Some uintptr_t_cast_expr) ]) in ([ generic_c_ptr_binding ], [ generic_c_ptr_assign_stat_ ])) - else - ([], []) in let param2_sym = Sym.fresh_pretty "owned_enum" in let param1 = (param1_sym, bt_to_ail_ctype BT.(Loc ())) in @@ -780,8 +714,10 @@ let generate_check_ownership_function ~with_ownership_checking ctype let param_syms, param_types = List.split [ param1; param2 ] in let param_types = List.map (fun t -> (empty_qualifiers, t, false)) param_types in let ownership_fcall_maybe = - if with_ownership_checking then ( - let ownership_fn_sym = Sym.fresh_pretty "cn_check_ownership" in + if without_ownership_checking then + [] + else ( + let ownership_fn_sym = Sym.fresh_pretty "cn_get_or_put_ownership" in let ownership_fn_args = A. [ AilEident param2_sym; @@ -796,8 +732,6 @@ let generate_check_ownership_function ~with_ownership_checking ctype ( mk_expr (AilEident ownership_fn_sym), List.map mk_expr ownership_fn_args )))) ]) - else - [] in let deref_expr_ = A.(AilEunary (Indirection, cast_expr)) in let sct_opt = Sctypes.of_ctype ctype in @@ -904,7 +838,7 @@ let rec cn_to_ail_expr_aux_internal let b2, s2, e2 = cn_to_ail_expr_aux_internal const_prop pred_name dts globals t2 PassBack in - let ail_bop, annot = cn_to_ail_binop_internal (IT.basetype t1) (IT.basetype t2) bop in + let ail_bop, annot = cn_to_ail_binop_internal (IT.get_bt t1) (IT.get_bt t2) bop in let str = match annot with Some str -> str | None -> failwith "No CN binop function found" in @@ -913,15 +847,15 @@ let rec cn_to_ail_expr_aux_internal in (* let is_map it = - match IT.bt it with + match IT.get_bt it with | BT.Map (bt1, bt2) -> - Printf.printf "Type of %s: Map(%s, %s)\n" (str_of_it_ (IT.term it)) (str_of_ctype (bt_to_ail_ctype bt1)) (str_of_ctype (bt_to_ail_ctype bt2)); + Printf.printf "Type of %s: Map(%s, %s)\n" (str_of_it_ (IT.get_term it)) (str_of_ctype (bt_to_ail_ctype bt1)) (str_of_ctype (bt_to_ail_ctype bt2)); true | _ -> false in *) let ail_expr_ = match ail_bop with - | Eq -> get_equality_fn_call (IT.bt t1) e1 e2 dts + | Eq -> get_equality_fn_call (IT.get_bt t1) e1 e2 dts | _ -> default_ail_binop in dest d (b1 @ b2, s1 @ s2, mk_expr ail_expr_) @@ -929,7 +863,7 @@ let rec cn_to_ail_expr_aux_internal let b, s, e = cn_to_ail_expr_aux_internal const_prop pred_name dts globals t PassBack in - let _ail_unop, annot = cn_to_ail_unop_internal (IT.bt t) unop in + let _ail_unop, annot = cn_to_ail_unop_internal (IT.get_bt t) unop in let str = match annot with Some str -> str | None -> failwith "No CN unop function found" in @@ -943,7 +877,7 @@ let rec cn_to_ail_expr_aux_internal | ITE (t1, t2, t3) -> let result_sym = Sym.fresh () in let result_ident = A.(AilEident result_sym) in - let result_binding = create_binding result_sym (bt_to_ail_ctype (IT.bt t2)) in + let result_binding = create_binding result_sym (bt_to_ail_ctype (IT.get_bt t2)) in let result_decl = A.(AilSdeclaration [ (result_sym, None) ]) in let b1, s1, e1 = cn_to_ail_expr_aux_internal const_prop pred_name dts globals t1 PassBack @@ -1059,7 +993,7 @@ let rec cn_to_ail_expr_aux_internal dest d (b, s, mk_expr ail_expr_) | StructUpdate ((struct_term, m), new_val) -> let struct_tag = - match IT.bt struct_term with + match IT.get_bt struct_term with | BT.Struct tag -> tag | _ -> failwith "Cannot do StructUpdate on non-struct term" in @@ -1120,9 +1054,7 @@ let rec cn_to_ail_expr_aux_internal let assign_stat = A.(AilSexpr (mk_expr (AilEassign (mk_expr ail_memberof, e)))) in (b, s, assign_stat) in - let transformed_ms = - List.map (fun (id, it) -> (id, bt_to_cn_base_type (IT.bt it))) ms - in + let transformed_ms = List.map (fun (id, it) -> (id, IT.get_bt it)) ms in let sym_name = lookup_records_map transformed_ms in let ctype_ = C.(Pointer (empty_qualifiers, mk_ctype (Struct sym_name))) in let res_binding = create_binding res_sym (mk_ctype ctype_) in @@ -1168,14 +1100,15 @@ let rec cn_to_ail_expr_aux_internal in let ail_decl = A.(AilSdeclaration [ (res_sym, Some (mk_expr fn_call)) ]) in let lc_constr_sym = generate_sym_with_suffix ~suffix:"" ~lowercase:true sym in - let e_ = A.(AilEmemberofptr (mk_expr res_ident, Id.id "u")) in + let here = Locations.other __LOC__ in + let e_ = A.(AilEmemberofptr (mk_expr res_ident, Id.make here "u")) in let e_' = A.(AilEmemberof (mk_expr e_, create_id_from_sym lc_constr_sym)) in let generate_ail_stat (id, it) = let b, s, e = cn_to_ail_expr_aux_internal const_prop pred_name dts globals it PassBack in let ail_memberof = - if Id.equal id (Id.id "tag") then + if Id.equal id (Id.make here "tag") then e else ( let e_'' = A.(AilEmemberofptr (mk_expr e_', id)) in @@ -1204,7 +1137,7 @@ let rec cn_to_ail_expr_aux_internal in let bs, ss, assign_stats = list_split_three (List.map generate_ail_stat ms) in let uc_constr_sym = generate_sym_with_suffix ~suffix:"" ~uppercase:true sym in - let tag_member_ptr = A.(AilEmemberofptr (mk_expr res_ident, Id.id "tag")) in + let tag_member_ptr = A.(AilEmemberofptr (mk_expr res_ident, Id.make here "tag")) in let tag_assign = A.( AilSexpr @@ -1273,7 +1206,7 @@ let rec cn_to_ail_expr_aux_internal cn_to_ail_expr_aux_internal const_prop pred_name dts globals m PassBack in let key_term = - if IT.bt key == BT.Integer then + if IT.get_bt key == BT.Integer then key else IT.IT (Cast (BT.Integer, key), BT.Integer, Cerb_location.unknown) @@ -1285,7 +1218,7 @@ let rec cn_to_ail_expr_aux_internal cn_to_ail_expr_aux_internal const_prop pred_name dts globals value PassBack in let new_map_sym = Sym.fresh () in - let new_map_binding = create_binding new_map_sym (bt_to_ail_ctype (IT.bt m)) in + let new_map_binding = create_binding new_map_sym (bt_to_ail_ctype (IT.get_bt m)) in let map_deep_copy_fcall = A.(AilEcall (mk_expr (AilEident (Sym.fresh_pretty "cn_map_deep_copy")), [ e1 ])) in @@ -1309,7 +1242,7 @@ let rec cn_to_ail_expr_aux_internal cn_to_ail_expr_aux_internal const_prop pred_name dts globals m PassBack in let key_term = - if IT.bt key == BT.Integer then + if IT.get_bt key == BT.Integer then key else IT.IT (Cast (BT.Integer, key), BT.Integer, Cerb_location.unknown) @@ -1317,7 +1250,9 @@ let rec cn_to_ail_expr_aux_internal let b2, s2, e2 = cn_to_ail_expr_aux_internal const_prop pred_name dts globals key_term PassBack in - let is_record = match BT.map_bt (IT.bt m) with _, Record _ -> true | _ -> false in + let is_record = + match BT.map_bt (IT.get_bt m) with _, Record _ -> true | _ -> false + in let cntype_str_opt = get_underscored_typedef_string_from_bt ~is_record basetype in let map_get_str = match cntype_str_opt with @@ -1327,7 +1262,7 @@ let rec cn_to_ail_expr_aux_internal let map_get_fcall = A.(AilEcall (mk_expr (AilEident (Sym.fresh_pretty map_get_str)), [ e1; e2 ])) in - let _key_bt, val_bt = BT.map_bt (IT.bt m) in + let _key_bt, val_bt = BT.map_bt (IT.get_bt m) in let ctype = bt_to_ail_ctype val_bt in let cast_expr_ = A.(AilEcast (empty_qualifiers, ctype, mk_expr map_get_fcall)) in dest d (b1 @ b2, s1 @ s2, mk_expr cast_expr_) @@ -1351,7 +1286,7 @@ let rec cn_to_ail_expr_aux_internal let b1, s1, e1 = cn_to_ail_expr_aux_internal const_prop pred_name dts globals t1 PassBack in - let ctype = bt_to_ail_ctype (IT.bt t1) in + let ctype = bt_to_ail_ctype (IT.get_bt t1) in let binding = create_binding var ctype in let ail_assign = A.(AilSdeclaration [ (var, Some e1) ]) in prefix @@ -1365,7 +1300,7 @@ let rec cn_to_ail_expr_aux_internal match ps with | T.(Pat (PSym sym', p_bt, pt_loc)) :: ps' -> ( mk_pattern T.PWild p_bt pt_loc :: ps', - T.(IT (Let ((sym', t1), t2), IT.basetype t2, pt_loc)) ) + T.(IT (Let ((sym', t1), t2), IT.get_bt t2, pt_loc)) ) | p :: ps' -> (p :: ps', t2) | [] -> assert false in @@ -1387,7 +1322,8 @@ let rec cn_to_ail_expr_aux_internal | _ :: _ -> failwith "Non-sum pattern" | [] -> assert false in - let transform_switch_expr e = A.(AilEmemberofptr (e, Id.id "tag")) in + let here = Locations.other __LOC__ in + let transform_switch_expr e = A.(AilEmemberofptr (e, Id.make here "tag")) in (* Matrix algorithm for pattern compilation *) let rec translate : int -> IT.t list -> (BT.t IT.pattern list * IT.t) list -> Sym.sym option -> @@ -1422,7 +1358,7 @@ let rec cn_to_ail_expr_aux_internal let bindings', stats' = translate count vs cases res_sym_opt in (bindings', stats')) else ( - match IT.bt term with + match IT.get_bt term with | BT.Datatype sym -> let cn_dt = List.filter (fun dt -> Sym.equal sym dt.cn_dt_name) dts in (match cn_dt with @@ -1446,7 +1382,7 @@ let rec cn_to_ail_expr_aux_internal let count_sym = generate_sym_with_suffix ~suffix ~lowercase:true constr_sym in - let rhs_memberof_ptr = A.(AilEmemberofptr (e1, Id.id "u")) in + let rhs_memberof_ptr = A.(AilEmemberofptr (e1, Id.make here "u")) in (* TODO: Remove hack *) let rhs_memberof = A.(AilEmemberof (mk_expr rhs_memberof_ptr, create_id_from_sym lc_sym)) @@ -1512,7 +1448,7 @@ let rec cn_to_ail_expr_aux_internal (b1, s1 @ [ switch ])) | _ -> (* Cannot have non-variable, non-wildcard pattern besides struct *) - let bt_string_opt = get_typedef_string (bt_to_ail_ctype (IT.bt term)) in + let bt_string_opt = get_typedef_string (bt_to_ail_ctype (IT.get_bt term)) in let bt_string = match bt_string_opt with | Some str -> str @@ -1554,7 +1490,7 @@ let rec cn_to_ail_expr_aux_internal let ail_expr_ = match ( get_typedef_string (bt_to_ail_ctype bt), - get_typedef_string (bt_to_ail_ctype (IT.bt t)) ) + get_typedef_string (bt_to_ail_ctype (IT.get_bt t)) ) with | Some cast_type_str, Some original_type_str -> let fn_name = "cast_" ^ original_type_str ^ "_to_" ^ cast_type_str in @@ -1601,9 +1537,7 @@ let cn_to_ail_expr_internal_with_pred_name let create_member (ctype, id) = (id, (empty_attributes, None, empty_qualifiers, ctype)) let generate_tag_definition dt_members = - let ail_dt_members = - List.map (fun (id, cn_type) -> (cn_to_ail_base_type cn_type, id)) dt_members - in + let ail_dt_members = List.map (fun (id, bt) -> (bt_to_ail_ctype bt, id)) dt_members in (* TODO: Check if something called tag already exists *) let members = List.map create_member ail_dt_members in C.(StructDef (members, None)) @@ -1619,9 +1553,9 @@ let generate_struct_definition ?(lc = true) (constructor, members) = (constr_sym, (Cerb_location.unknown, empty_attributes, generate_tag_definition members)) -let cn_to_ail_pred_records map_bindings = +let cn_to_ail_records map_bindings = let flipped_bindings = List.map (fun (ms, sym) -> (sym, ms)) map_bindings in - List.map generate_struct_definition flipped_bindings + List.map (generate_struct_definition ~lc:false) flipped_bindings (* Generic map get for structs, datatypes and records *) @@ -1643,7 +1577,8 @@ let generate_map_get sym = let ret_sym = Sym.fresh_pretty "ret" in let ret_binding = create_binding ret_sym void_ptr_type in let key_val_mem = - mk_expr A.(AilEmemberofptr (mk_expr (AilEident param2_sym), Id.id "val")) + let here = Locations.other __LOC__ in + mk_expr A.(AilEmemberofptr (mk_expr (AilEident param2_sym), Id.make here "val")) in let ht_get_fcall = mk_expr @@ -1703,15 +1638,16 @@ let cn_to_ail_datatype ?(first = false) (cn_datatype : cn_datatype) = let enum_sym = generate_sym_with_suffix cn_datatype.cn_dt_name in let constructor_syms = List.map fst cn_datatype.cn_dt_cases in + let here = Locations.other __LOC__ in let generate_enum_member sym = let doc = CF.Pp_ail.pp_id sym in let str = CF.Pp_utils.to_plain_string doc in let str = String.uppercase_ascii str in - Id.id str + Id.make here str in let enum_member_syms = List.map generate_enum_member constructor_syms in let attr : CF.Annot.attribute = - { attr_ns = None; attr_id = Id.id "enum"; attr_args = [] } + { attr_ns = None; attr_id = Id.make here "enum"; attr_args = [] } in let attrs = CF.Annot.Attrs [ attr ] in let enum_members = @@ -1724,13 +1660,17 @@ let cn_to_ail_datatype ?(first = false) (cn_datatype : cn_datatype) let cntype_sym = Sym.fresh_pretty "cntype" in let cntype_pointer = C.(Pointer (empty_qualifiers, mk_ctype (Struct cntype_sym))) in let extra_members tag_type = - [ create_member (mk_ctype tag_type, Id.id "tag"); - create_member (mk_ctype cntype_pointer, Id.id "cntype") + [ create_member (mk_ctype tag_type, Id.make here "tag"); + create_member (mk_ctype cntype_pointer, Id.make here "cntype") ] in - let structs = - List.map (fun c -> generate_struct_definition c) cn_datatype.cn_dt_cases + let bt_cases = + List.map + (fun (sym, ms) -> + (sym, List.map (fun (id, cn_t) -> (id, cn_base_type_to_bt cn_t)) ms)) + cn_datatype.cn_dt_cases in + let structs = List.map (fun c -> generate_struct_definition c) bt_cases in let structs = if first then ( let generic_dt_struct = @@ -1757,7 +1697,7 @@ let cn_to_ail_datatype ?(first = false) (cn_datatype : cn_datatype) constructor_syms in let union_def = C.(UnionDef union_def_members) in - let union_member = create_member (mk_ctype C.(Union union_sym), Id.id "u") in + let union_member = create_member (mk_ctype C.(Union union_sym), Id.make here "u") in let structs = structs @ [ (union_sym, (Cerb_location.unknown, empty_attributes, union_def)); @@ -1787,7 +1727,8 @@ let generate_datatype_equality_function (cn_datatype : cn_datatype) let fn_sym = Sym.fresh_pretty ("struct_" ^ Sym.pp_string dt_sym ^ "_equality") in let param1_sym = Sym.fresh_pretty "x" in let param2_sym = Sym.fresh_pretty "y" in - let id_tag = Id.id "tag" in + let here = Locations.other __LOC__ in + let id_tag = Id.make here "tag" in let param_syms = [ param1_sym; param2_sym ] in let param_type = ( empty_qualifiers, @@ -1852,7 +1793,8 @@ let generate_datatype_equality_function (cn_datatype : cn_datatype) in let memberof_ptr_es = List.map - (fun sym -> mk_expr A.(AilEmemberofptr (mk_expr (AilEident sym), Id.id "u"))) + (fun sym -> + mk_expr A.(AilEmemberofptr (mk_expr (AilEident sym), Id.make here "u"))) param_syms in let decls = @@ -1962,11 +1904,13 @@ let generate_datatype_default_function (cn_datatype : cn_datatype) = } in let enum_ident = mk_expr A.(AilEident enum_sym) in + let here = Locations.other __LOC__ in let res_tag_assign = A.( AilSexpr (mk_expr - (AilEassign (mk_expr (AilEmemberofptr (res_ident, Id.id "tag")), enum_ident)))) + (AilEassign + (mk_expr (AilEmemberofptr (res_ident, Id.make here "tag")), enum_ident)))) in let res_tag_assign_stat = A.( @@ -1974,7 +1918,7 @@ let generate_datatype_default_function (cn_datatype : cn_datatype) = (Cerb_location.unknown, CF.Annot.Attrs [ attribute ], res_tag_assign)) in let lc_constr_sym = generate_sym_with_suffix ~suffix:"" ~lowercase:true constructor in - let res_u = A.(AilEmemberofptr (res_ident, Id.id "u")) in + let res_u = A.(AilEmemberofptr (res_ident, Id.make here "u")) in let res_u_constr = mk_expr (AilEmemberof (mk_expr res_u, create_id_from_sym lc_constr_sym)) in @@ -1993,7 +1937,7 @@ let generate_datatype_default_function (cn_datatype : cn_datatype) = | Some member_ctype_str -> "default_" ^ member_ctype_str | None -> Printf.printf "%s\n" (Pp.plain (BT.pp bt)); - failwith "no underscored typedef string found" + failwith "Datatype default function: no underscored typedef string found" in let fcall = A.(AilEcall (mk_expr (AilEident (Sym.fresh_pretty default_fun_str)), [])) @@ -2185,7 +2129,7 @@ let generate_struct_default_function | Some member_ctype_str -> "default_" ^ member_ctype_str | None -> Printf.printf "%s\n" (Pp.plain (BT.pp bt)); - failwith "no underscored typedef string found" + failwith "Struct default function: no underscored typedef string found" in let fcall = A.(AilEcall (mk_expr (AilEident (Sym.fresh_pretty default_fun_str)), [])) @@ -2474,6 +2418,7 @@ let generate_record_default_function _dts (sym, (members : BT.member_types)) : (A.sigma_declaration * CF.GenTypes.genTypeCategory A.sigma_function_definition) list = let cn_sym = sym in + (* Printf.printf "Record sym: %s\n" (Sym.pp_string cn_sym); *) let fn_str = "default_struct_" ^ Sym.pp_string cn_sym in let cn_struct_ctype = C.(Struct cn_sym) in let cn_struct_ptr_ctype = @@ -2487,6 +2432,7 @@ let generate_record_default_function _dts (sym, (members : BT.member_types)) let ret_ident = A.(AilEident ret_sym) in (* Function body *) let generate_member_default_assign (id, bt) = + (* Printf.printf "Member: %s\n" (Id.get_string id); *) let lhs = A.(AilEmemberofptr (mk_expr ret_ident, id)) in let member_ctype_str_opt = get_underscored_typedef_string_from_bt bt in let default_fun_str = @@ -2494,7 +2440,7 @@ let generate_record_default_function _dts (sym, (members : BT.member_types)) | Some member_ctype_str -> "default_" ^ member_ctype_str | None -> Printf.printf "%s\n" (Pp.plain (BT.pp bt)); - failwith "no underscored typedef string found" + failwith "Record default function: no underscored typedef string found" in let fcall = A.(AilEcall (mk_expr (AilEident (Sym.fresh_pretty default_fun_str)), [])) @@ -2552,6 +2498,67 @@ let cn_to_ail_struct ((sym, (loc, attrs, tag_def)) : A.sigma_tag_definition) | C.UnionDef _ -> [] +let get_while_bounds_and_cond (i_sym, i_bt) it = + (* Translation of q.pointer *) + let i_it = IT.IT (IT.(Sym i_sym), i_bt, Cerb_location.unknown) in + (* Start of range *) + let start_expr = + if BT.equal_sign (fst (Option.get (BT.is_bits_bt i_bt))) BT.Unsigned then + IndexTerms.Bounds.get_lower_bound (i_sym, i_bt) it + else ( + match IndexTerms.Bounds.get_lower_bound_opt (i_sym, i_bt) it with + | Some e -> e + | None -> + Cerb_colour.with_colour + (fun () -> + print_endline + Pp.( + plain + (Pp.item + "Cannot infer lower bound for permission" + (squotes (IT.pp it) ^^^ !^"at" ^^^ Locations.pp (IT.get_loc it))))) + (); + exit 2) + in + let start_expr = + IT.IT + ( IT.Cast (IT.get_bt start_expr, start_expr), + IT.get_bt start_expr, + Cerb_location.unknown ) + in + let start_cond = + match start_expr with + | IT (Binop (Add, start_expr', IT (Const (Bits (_, n)), _, _)), _, _) + when Z.equal n Z.one -> + IT.lt_ (start_expr', i_it) Cerb_location.unknown + | _ -> IT.le_ (start_expr, i_it) Cerb_location.unknown + in + (* End of range *) + let end_expr = + match IndexTerms.Bounds.get_upper_bound_opt (i_sym, i_bt) it with + | Some e -> e + | None -> + Cerb_colour.with_colour + (fun () -> + print_endline + Pp.( + plain + (Pp.item + "Cannot infer upper bound for permission" + (squotes (IT.pp it) ^^^ !^"at" ^^^ Locations.pp (IT.get_loc it))))) + (); + exit 2 + in + let end_cond = + match end_expr with + | IT (Binop (Sub, end_expr', IT (Const (Bits (_, n)), _, _)), _, _) + when Z.equal n Z.one -> + IT.lt_ (i_it, end_expr') Cerb_location.unknown + | _ -> IT.le_ (i_it, end_expr) Cerb_location.unknown + in + (start_expr, end_expr, IT.and2_ (start_cond, end_cond) Cerb_location.unknown) + + (* is_pre used for ownership checking, to see if ownership needs to be taken or put back *) let cn_to_ail_resource_internal ?(is_pre = true) @@ -2559,19 +2566,42 @@ let cn_to_ail_resource_internal sym dts globals - (preds : (Sym.t * RP.definition) list) - _loc + (preds : (Sym.t * Def.Predicate.t) list) + loc = let calculate_return_type = function - | ResourceTypes.Owned (sct, _) -> + | Request.Owned (sct, _) -> ( Sctypes.to_ctype sct, BT.of_sct Memory.is_signed_integer_type Memory.size_of_integer_type sct ) | PName pname -> + if Sym.equal pname Alloc.Predicate.sym then ( + Cerb_colour.with_colour + (fun () -> + print_endline + Pp.( + plain + (Pp.item + "'Alloc' not currently supported at runtime" + (!^"Used at" ^^^ Locations.pp loc)))) + (); + exit 2); let matching_preds = List.filter (fun (pred_sym', _def) -> Sym.equal pname pred_sym') preds in let pred_sym', pred_def' = - match matching_preds with [] -> failwith "Predicate not found" | p :: _ -> p + match matching_preds with + | [] -> + Cerb_colour.with_colour + (fun () -> + print_endline + Pp.( + plain + (Pp.item + "Predicate not found" + (Sym.pp pname ^^^ !^"at" ^^^ Locations.pp loc)))) + (); + exit 2 + | p :: _ -> p in let cn_bt = bt_to_cn_base_type pred_def'.oarg_bt in let ctype = @@ -2586,7 +2616,7 @@ let cn_to_ail_resource_internal in (* let make_deref_expr_ e_ = A.(AilEunary (Indirection, mk_expr e_)) in *) function - | ResourceTypes.P p -> + | Request.P p -> let ctype, bt = calculate_return_type p.name in let b, s, e = cn_to_ail_expr_internal dts globals p.pointer PassBack in let enum_str = if is_pre then "GET" else "PUT" in @@ -2598,7 +2628,7 @@ let cn_to_ail_resource_internal ownership_ctypes := Sctypes.to_ctype sct :: !ownership_ctypes; let ct_str = str_of_ctype (Sctypes.to_ctype sct) in let ct_str = String.concat "_" (String.split_on_char ' ' ct_str) in - let owned_fn_name = "check_owned_" ^ ct_str in + let owned_fn_name = "owned_" ^ ct_str in (* Hack with enum as sym *) let enum_val_get = IT.(IT (Sym enum_sym, BT.Integer, Cerb_location.unknown)) in let fn_call_it = @@ -2635,7 +2665,7 @@ let cn_to_ail_resource_internal | _ -> A.(AilSdeclaration [ (sym, Some rhs) ]) in (b @ bs, s @ ss @ [ s_decl ]) - | ResourceTypes.Q q -> + | Request.Q q -> (* Input is expr of the form: take sym = each (integer q.q; q.permission){ Owned(q.pointer + (q.q * q.step)) } @@ -2650,22 +2680,12 @@ let cn_to_ail_resource_internal } *) let i_sym, i_bt = q.q in - let start_cond = get_leftmost_of_and_expr q.permission in - let start_expr = generate_start_expr start_cond (fst q.q) in - let start_expr = - IT.IT - (IT.Cast (IT.bt start_expr, start_expr), IT.bt start_expr, Cerb_location.unknown) - in + let start_expr, _, while_loop_cond = get_while_bounds_and_cond q.q q.permission in let _, _, e_start = cn_to_ail_expr_internal dts globals start_expr PassBack in - let end_cond = get_leftmost_of_and_expr (get_rest_of_expr_r q.permission) in - let if_stat_cond = get_rest_of_expr_r (get_rest_of_expr_r q.permission) in - let while_loop_cond = - IT.IT (Binop (And, start_cond, end_cond), BT.Bool, Cerb_location.unknown) - in let _, _, while_cond_expr = cn_to_ail_expr_internal dts globals while_loop_cond PassBack in - let _, _, if_cond_expr = cn_to_ail_expr_internal dts globals if_stat_cond PassBack in + let _, _, if_cond_expr = cn_to_ail_expr_internal dts globals q.permission PassBack in let cn_integer_ptr_ctype = bt_to_ail_ctype i_bt in (* let convert_to_cn_integer_sym = Sym.fresh_pretty (Option.get (get_conversion_to_fn_str BT.Integer)) @@ -2705,7 +2725,7 @@ let cn_to_ail_resource_internal ownership_ctypes := Sctypes.to_ctype sct :: !ownership_ctypes; let sct_str = str_of_ctype (Sctypes.to_ctype sct) in let sct_str = String.concat "_" (String.split_on_char ' ' sct_str) in - let owned_fn_name = "check_owned_" ^ sct_str in + let owned_fn_name = "owned_" ^ sct_str in let ptr_add_it = IT.(IT (Sym ptr_add_sym, BT.(Loc ()), Cerb_location.unknown)) in (* Hack with enum as sym *) let enum_val_get = IT.(IT (Sym enum_sym, BT.Integer, Cerb_location.unknown)) in @@ -2834,22 +2854,18 @@ let cn_to_ail_resource_internal let cn_to_ail_logical_constraint_internal : type a. - _ CF.Cn.cn_datatype list -> - (C.union_tag * C.ctype) list -> - a dest -> - LC.logical_constraint -> - a + _ CF.Cn.cn_datatype list -> (C.union_tag * C.ctype) list -> a dest -> LC.t -> a = fun dts globals d lc -> match lc with - | LogicalConstraints.T it -> cn_to_ail_expr_internal dts globals it d - | LogicalConstraints.Forall ((sym, bt), it) -> + | LC.T it -> cn_to_ail_expr_internal dts globals it d + | LC.Forall ((sym, bt), it) -> let cond_it, t = - match IT.term it with + match IT.get_term it with | Binop (Implies, it, it') -> (it, it') | _ -> failwith "Incorrect form of forall logical constraint term" in - (match IT.term t with + (match IT.get_term t with | Good _ -> dest d ([], [], cn_bool_true_expr) | _ -> (* Assume cond_it is of a particular form *) @@ -2872,26 +2888,12 @@ let cn_to_ail_logical_constraint_internal assign/return/assert/passback b *) - let start_cond = get_leftmost_of_and_expr cond_it in - let start_expr = generate_start_expr start_cond sym in - let start_expr = - IT.IT - ( IT.Cast (IT.bt start_expr, start_expr), - IT.bt start_expr, - Cerb_location.unknown ) - in + let start_expr, _, while_loop_cond = get_while_bounds_and_cond (sym, bt) cond_it in let _, _, e_start = cn_to_ail_expr_internal dts globals start_expr PassBack in - let end_cond = get_leftmost_of_and_expr (get_rest_of_expr_r cond_it) in - let if_stat_cond = get_rest_of_expr_r (get_rest_of_expr_r cond_it) in - let while_loop_cond = - IT.IT (Binop (And, start_cond, end_cond), BT.Bool, Cerb_location.unknown) - in let _, _, while_cond_expr = cn_to_ail_expr_internal dts globals while_loop_cond PassBack in - let _, _, if_cond_expr = - cn_to_ail_expr_internal dts globals if_stat_cond PassBack - in + let _, _, if_cond_expr = cn_to_ail_expr_internal dts globals cond_it PassBack in let t_translated = cn_to_ail_expr_internal dts globals t PassBack in let bs, ss, e = gen_bool_while_loop @@ -2918,9 +2920,8 @@ let cn_to_ail_logical_constraint let rec generate_record_opt pred_sym = function | BT.Record members -> - let members' = List.map (fun (id, bt) -> (id, bt_to_cn_base_type bt)) members in let record_sym = generate_sym_with_suffix ~suffix:"_record" pred_sym in - Some (generate_struct_definition ~lc:false (record_sym, members')) + Some (generate_struct_definition ~lc:false (record_sym, members)) | BT.Tuple ts -> let members = List.map (fun t -> (create_id_from_sym (Sym.fresh ()), t)) ts in generate_record_opt pred_sym (BT.Record members) @@ -2929,7 +2930,7 @@ let rec generate_record_opt pred_sym = function (* TODO: Finish with rest of function - maybe header file with A.Decl_function (cn.h?) *) let cn_to_ail_function_internal - (fn_sym, (lf_def : LogicalFunctions.definition)) + (fn_sym, (lf_def : Definition.Function.t)) (cn_datatypes : A.sigma_cn_datatype list) (cn_functions : A.sigma_cn_function list) : ((Locations.t * A.sigma_declaration) @@ -2939,16 +2940,26 @@ let cn_to_ail_function_internal let ret_type = bt_to_ail_ctype ~pred_sym:(Some fn_sym) lf_def.return_bt in (* let ret_type = mk_ctype C.(Pointer (empty_qualifiers, ret_type)) in *) let bs, ail_func_body_opt = - match lf_def.definition with + match lf_def.body with | Def it | Rec_Def it -> let bs, ss = cn_to_ail_expr_internal_with_pred_name (Some fn_sym) cn_datatypes [] it Return in (bs, Some (List.map mk_stmt ss)) | Uninterp -> - failwith - "Uninterpreted CN functions not supported at runtime. Please provide a concrete \ - function definition" + Cerb_colour.with_colour + (fun () -> + print_endline + Pp.( + plain + (Pp.item + "Uninterpreted CN functions not supported at runtime. Please provide \ + a concrete function definition for" + (squotes (Definition.Function.pp_sig (Sym.pp fn_sym) lf_def) + ^^^ !^"at" + ^^^ Locations.pp lf_def.loc)))) + (); + exit 2 in let ail_record_opt = generate_record_opt fn_sym lf_def.return_bt in let params = List.map (fun (sym, bt) -> (sym, bt_to_ail_ctype bt)) lf_def.args in @@ -2990,7 +3001,7 @@ let cn_to_ail_function_internal let rec cn_to_ail_lat_internal ?(is_toplevel = true) dts pred_sym_opt globals preds = function | LAT.Define ((name, it), _info, lat) -> - let ctype = bt_to_ail_ctype (IT.bt it) in + let ctype = bt_to_ail_ctype (IT.get_bt it) in let binding = create_binding name ctype in let decl = A.(AilSdeclaration [ (name, None) ]) in let b1, s1 = @@ -3021,14 +3032,14 @@ let rec cn_to_ail_lat_internal ?(is_toplevel = true) dts pred_sym_opt globals pr let cn_to_ail_predicate_internal - (pred_sym, (rp_def : ResourcePredicates.definition)) + (pred_sym, (rp_def : Def.Predicate.t)) dts globals preds cn_preds = let ret_type = bt_to_ail_ctype ~pred_sym:(Some pred_sym) rp_def.oarg_bt in - let rec clause_translate (clauses : RP.clause list) = + let rec clause_translate (clauses : Def.Clause.t list) = match clauses with | [] -> ([], []) | c :: cs -> @@ -3134,9 +3145,9 @@ let rec cn_to_ail_post_aux_internal dts globals preds = function (* Printf.printf "LRT.Define\n"; *) let new_name = generate_sym_with_suffix ~suffix:"_cn" name in let new_lrt = - Core_to_mucore.fn_spec_instrumentation_sym_subst_lrt (name, IT.bt it, new_name) t + LogicalReturnTypes.subst (ESE.sym_subst (name, IT.get_bt it, new_name)) t in - let binding = create_binding new_name (bt_to_ail_ctype (IT.bt it)) in + let binding = create_binding new_name (bt_to_ail_ctype (IT.get_bt it)) in let decl = A.(AilSdeclaration [ (new_name, None) ]) in let b1, s1 = cn_to_ail_expr_internal dts globals it (AssignVar new_name) in let b2, s2 = cn_to_ail_post_aux_internal dts globals preds new_lrt in @@ -3148,9 +3159,7 @@ let rec cn_to_ail_post_aux_internal dts globals preds = function let b1, s1 = cn_to_ail_resource_internal ~is_pre:false new_name dts globals preds loc re in - let new_lrt = - Core_to_mucore.fn_spec_instrumentation_sym_subst_lrt (name, bt, new_name) t - in + let new_lrt = LogicalReturnTypes.subst (ESE.sym_subst (name, bt, new_name)) t in let b2, s2 = cn_to_ail_post_aux_internal dts globals preds new_lrt in (b1 @ b2, upd_s @ s1 @ pop_s @ s2) | LRT.Constraint (lc, (loc, _str_opt), t) -> @@ -3263,13 +3272,18 @@ let prepend_to_precondition ail_executable_spec (b1, s1) = (* Precondition and postcondition translation - LAT.I case means precondition translation finished *) -let rec cn_to_ail_lat_internal_2 with_ownership_checking dts globals preds c_return_type +let rec cn_to_ail_lat_internal_2 + without_ownership_checking + dts + globals + preds + c_return_type = function | LAT.Define ((name, it), _info, lat) -> - let ctype = bt_to_ail_ctype (IT.bt it) in + let ctype = bt_to_ail_ctype (IT.get_bt it) in let new_name = generate_sym_with_suffix ~suffix:"_cn" name in let new_lat = - Core_to_mucore.fn_spec_instrumentation_sym_subst_lat (name, IT.bt it, new_name) lat + ESE.fn_largs_and_body_subst (ESE.sym_subst (name, IT.get_bt it, new_name)) lat in (* let ctype = mk_ctype C.(Pointer (empty_qualifiers, ctype)) in *) let binding = create_binding new_name ctype in @@ -3277,7 +3291,7 @@ let rec cn_to_ail_lat_internal_2 with_ownership_checking dts globals preds c_ret let b1, s1 = cn_to_ail_expr_internal dts globals it (AssignVar new_name) in let ail_executable_spec = cn_to_ail_lat_internal_2 - with_ownership_checking + without_ownership_checking dts globals preds @@ -3292,12 +3306,10 @@ let rec cn_to_ail_lat_internal_2 with_ownership_checking dts globals preds c_ret let b1, s1 = cn_to_ail_resource_internal ~is_pre:true new_name dts globals preds loc ret in - let new_lat = - Core_to_mucore.fn_spec_instrumentation_sym_subst_lat (name, bt, new_name) lat - in + let new_lat = ESE.fn_largs_and_body_subst (ESE.sym_subst (name, bt, new_name)) lat in let ail_executable_spec = cn_to_ail_lat_internal_2 - with_ownership_checking + without_ownership_checking dts globals preds @@ -3311,11 +3323,18 @@ let rec cn_to_ail_lat_internal_2 with_ownership_checking dts globals preds c_ret let b1, s, e = cn_to_ail_logical_constraint_internal dts globals PassBack lc in let ss = upd_s @ s @ generate_cn_assert (*~cn_source_loc_opt:(Some loc)*) e @ pop_s in let ail_executable_spec = - cn_to_ail_lat_internal_2 with_ownership_checking dts globals preds c_return_type lat + cn_to_ail_lat_internal_2 + without_ownership_checking + dts + globals + preds + c_return_type + lat in prepend_to_precondition ail_executable_spec (b1, ss) (* Postcondition *) - | LAT.I (post, stats) -> + | LAT.I (post, (stats, _loop)) -> + (*TODO: handle loops *) let rec remove_duplicates locs stats = match stats with | [] -> [] @@ -3330,7 +3349,7 @@ let rec cn_to_ail_lat_internal_2 with_ownership_checking dts globals preds c_ret else (loc, s) :: remove_duplicates (loc :: locs) ss in - (* let substitution : IT.t Subst.t = {replace = [(Sym.fresh_pretty "return", IT.(IT (Sym (Sym.fresh_pretty "__cn_ret"), BT.Unit)))]; relevant = SymSet.empty} in *) + (* let substitution : IT.t Subst.t = {replace = [(Sym.fresh_pretty "return", IT.(IT (Sym (Sym.fresh_pretty "__cn_ret"), BT.Unit)))]; relevant = Sym.Set.empty} in *) (* let post_with_ret = RT.subst substitution post in *) let return_cn_binding, return_cn_decl = match rm_ctype c_return_type with @@ -3362,15 +3381,15 @@ let rec cn_to_ail_lat_internal_2 with_ownership_checking dts globals preds c_ret in let post_bs, post_ss = cn_to_ail_post_internal dts globals preds post in let ownership_stat_ = - if with_ownership_checking then ( + if without_ownership_checking then + [] + else ( let cn_stack_depth_decr_stat_ = mk_stmt (A.AilSexpr (mk_expr (AilEcall (mk_expr (AilEident OE.cn_stack_depth_decr_sym), [])))) in [ cn_stack_depth_decr_stat_ ]) - else - [] in let block = A.( @@ -3380,7 +3399,7 @@ let rec cn_to_ail_lat_internal_2 with_ownership_checking dts globals preds c_ret let rec cn_to_ail_pre_post_aux_internal - with_ownership_checking + without_ownership_checking dts preds globals @@ -3392,12 +3411,10 @@ let rec cn_to_ail_pre_post_aux_internal let binding = create_binding cn_sym cn_ctype in let rhs = wrap_with_convert_to A.(AilEident sym) bt in let decl = A.(AilSdeclaration [ (cn_sym, Some (mk_expr rhs)) ]) in - let subst_at = - Core_to_mucore.fn_spec_instrumentation_sym_subst_at (sym, bt, cn_sym) at - in + let subst_at = ESE.fn_args_and_body_subst (ESE.sym_subst (sym, bt, cn_sym)) at in let ail_executable_spec = cn_to_ail_pre_post_aux_internal - with_ownership_checking + without_ownership_checking dts preds globals @@ -3406,15 +3423,26 @@ let rec cn_to_ail_pre_post_aux_internal in prepend_to_precondition ail_executable_spec ([ binding ], [ decl ]) | AT.L lat -> - cn_to_ail_lat_internal_2 with_ownership_checking dts globals preds c_return_type lat + cn_to_ail_lat_internal_2 + without_ownership_checking + dts + globals + preds + c_return_type + lat -let cn_to_ail_pre_post_internal ~with_ownership_checking dts preds globals c_return_type +let cn_to_ail_pre_post_internal + ~without_ownership_checking + dts + preds + globals + c_return_type = function | Some internal -> let ail_executable_spec = cn_to_ail_pre_post_aux_internal - with_ownership_checking + without_ownership_checking dts preds globals @@ -3422,20 +3450,20 @@ let cn_to_ail_pre_post_internal ~with_ownership_checking dts preds globals c_ret internal in let extra_stats_ = - if with_ownership_checking then ( + if without_ownership_checking then + [] + else ( let cn_stack_depth_incr_stat_ = A.AilSexpr (mk_expr (AilEcall (mk_expr (AilEident OE.cn_stack_depth_incr_sym), []))) in [ cn_stack_depth_incr_stat_ ]) - else - [] in prepend_to_precondition ail_executable_spec ([], extra_stats_) | None -> empty_ail_executable_spec -let generate_assume_ownership_function ~with_ownership_checking ctype +let generate_assume_ownership_function ~without_ownership_checking ctype : A.sigma_declaration * CF.GenTypes.genTypeCategory A.sigma_function_definition = let ctype_str = str_of_ctype ctype in @@ -3443,13 +3471,15 @@ let generate_assume_ownership_function ~with_ownership_checking ctype let ctype_str = String.concat "_" (String.split_on_char ' ' ctype_str) in let fn_sym = Sym.fresh_pretty ("assume_owned_" ^ ctype_str) in let param1_sym = Sym.fresh_pretty "cn_ptr" in + let here = Locations.other __LOC__ in let cast_expr = mk_expr A.( AilEcast ( empty_qualifiers, mk_ctype C.(Pointer (empty_qualifiers, ctype)), - mk_expr (AilEmemberofptr (mk_expr (AilEident param1_sym), Id.id "ptr")) )) + mk_expr (AilEmemberofptr (mk_expr (AilEident param1_sym), Id.make here "ptr")) + )) in let param2_sym = Sym.fresh_pretty "fun" in let param1 = (param1_sym, bt_to_ail_ctype BT.(Loc ())) in @@ -3457,11 +3487,13 @@ let generate_assume_ownership_function ~with_ownership_checking ctype let param_syms, param_types = List.split [ param1; param2 ] in let param_types = List.map (fun t -> (empty_qualifiers, t, false)) param_types in let ownership_fcall_maybe = - if with_ownership_checking then ( + if without_ownership_checking then + [] + else ( let ownership_fn_sym = Sym.fresh_pretty "cn_assume_ownership" in let ownership_fn_args = A. - [ AilEmemberofptr (mk_expr (AilEident param1_sym), Id.id "ptr"); + [ AilEmemberofptr (mk_expr (AilEident param1_sym), Id.make here "ptr"); AilEsizeof (empty_qualifiers, ctype); AilEident param2_sym ] @@ -3473,8 +3505,6 @@ let generate_assume_ownership_function ~with_ownership_checking ctype ( mk_expr (AilEident ownership_fn_sym), List.map mk_expr ownership_fn_args )))) ]) - else - [] in let deref_expr_ = A.(AilEunary (Indirection, cast_expr)) in let sct_opt = Sctypes.of_ctype ctype in @@ -3513,19 +3543,42 @@ let cn_to_ail_assume_resource_internal sym dts globals - (preds : (Sym.t * RP.definition) list) + (preds : (Sym.t * Def.Predicate.t) list) loc = let calculate_return_type = function - | ResourceTypes.Owned (sct, _) -> + | Request.Owned (sct, _) -> ( Sctypes.to_ctype sct, BT.of_sct Memory.is_signed_integer_type Memory.size_of_integer_type sct ) | PName pname -> + if Sym.equal pname Alloc.Predicate.sym then ( + Cerb_colour.with_colour + (fun () -> + print_endline + Pp.( + plain + (Pp.item + "'Alloc' not currently supported at runtime" + (!^"Used at" ^^^ Locations.pp loc)))) + (); + exit 2); let matching_preds = List.filter (fun (pred_sym', _def) -> Sym.equal pname pred_sym') preds in let pred_sym', pred_def' = - match matching_preds with [] -> failwith "Predicate not found" | p :: _ -> p + match matching_preds with + | [] -> + Cerb_colour.with_colour + (fun () -> + print_endline + Pp.( + plain + (Pp.item + "Predicate not found" + (Sym.pp pname ^^^ !^"at" ^^^ Locations.pp loc)))) + (); + exit 2 + | p :: _ -> p in let cn_bt = bt_to_cn_base_type pred_def'.oarg_bt in let ctype = @@ -3540,7 +3593,7 @@ let cn_to_ail_assume_resource_internal in (* let make_deref_expr_ e_ = A.(AilEunary (Indirection, mk_expr e_)) in *) function - | ResourceTypes.P p -> + | Request.P p -> let ctype, bt = calculate_return_type p.name in let b, s, e = cn_to_ail_expr_internal dts globals p.pointer PassBack in let rhs, bs, ss, _owned_ctype = @@ -3593,7 +3646,7 @@ let cn_to_ail_assume_resource_internal | _ -> A.(AilSdeclaration [ (sym, Some rhs) ]) in (b @ bs, s @ ss @ [ s_decl ]) - | ResourceTypes.Q q -> + | Request.Q q -> (* Input is expr of the form: take sym = each (integer q.q; q.permission){ Owned(q.pointer + (q.q * q.step)) } @@ -3608,22 +3661,12 @@ let cn_to_ail_assume_resource_internal } *) let i_sym, i_bt = q.q in - let start_cond = get_leftmost_of_and_expr q.permission in - let start_expr = generate_start_expr start_cond (fst q.q) in - let start_expr = - IT.IT - (IT.Cast (IT.bt start_expr, start_expr), IT.bt start_expr, Cerb_location.unknown) - in + let start_expr, _, while_loop_cond = get_while_bounds_and_cond q.q q.permission in let _, _, e_start = cn_to_ail_expr_internal dts globals start_expr PassBack in - let end_cond = get_leftmost_of_and_expr (get_rest_of_expr_r q.permission) in - let if_stat_cond = get_rest_of_expr_r (get_rest_of_expr_r q.permission) in - let while_loop_cond = - IT.IT (Binop (And, start_cond, end_cond), BT.Bool, Cerb_location.unknown) - in let _, _, while_cond_expr = cn_to_ail_expr_internal dts globals while_loop_cond PassBack in - let _, _, if_cond_expr = cn_to_ail_expr_internal dts globals if_stat_cond PassBack in + let _, _, if_cond_expr = cn_to_ail_expr_internal dts globals q.permission PassBack in let cn_integer_ptr_ctype = bt_to_ail_ctype i_bt in (* let convert_to_cn_integer_sym = Sym.fresh_pretty (Option.get (get_conversion_to_fn_str BT.Integer)) @@ -3794,7 +3837,7 @@ let cn_to_ail_assume_resource_internal let rec cn_to_ail_assume_lat_internal dts pred_sym_opt globals preds = function | LAT.Define ((name, it), _info, lat) -> - let ctype = bt_to_ail_ctype (IT.bt it) in + let ctype = bt_to_ail_ctype (IT.get_bt it) in let binding = create_binding name ctype in let decl = A.(AilSdeclaration [ (name, None) ]) in let b1, s1 = @@ -3817,13 +3860,13 @@ let rec cn_to_ail_assume_lat_internal dts pred_sym_opt globals preds = function let cn_to_ail_assume_predicate_internal - (pred_sym, (rp_def : ResourcePredicates.definition)) + (pred_sym, (rp_def : Def.Predicate.t)) dts globals preds = let ret_type = bt_to_ail_ctype ~pred_sym:(Some pred_sym) rp_def.oarg_bt in - let rec clause_translate (clauses : RP.clause list) = + let rec clause_translate (clauses : Def.Clause.t list) = match clauses with | [] -> ([], []) | c :: cs -> @@ -3894,7 +3937,7 @@ let rec cn_to_ail_assume_predicates_internal pred_def_list dts globals preds let rec cn_to_ail_assume_lat_internal_2 dts pred_sym_opt globals preds = function | LAT.Define ((name, it), _info, lat) -> - let ctype = bt_to_ail_ctype (IT.bt it) in + let ctype = bt_to_ail_ctype (IT.get_bt it) in let binding = create_binding name ctype in let decl = A.(AilSdeclaration [ (name, None) ]) in let b1, s1 = diff --git a/backend/cn/lib/cn_internal_to_ail.mli b/backend/cn/lib/cn_internal_to_ail.mli index a25332ac4..0eab96128 100644 --- a/backend/cn/lib/cn_internal_to_ail.mli +++ b/backend/cn/lib/cn_internal_to_ail.mli @@ -6,7 +6,7 @@ module BT = BaseTypes val ownership_ctypes : C.ctype list ref module MembersKey : sig - type t = (Id.t * Sym.t CF.Cn.cn_base_type) list + type t = (Id.t * BT.t) list val compare : t -> t -> int end @@ -57,13 +57,13 @@ type ail_executable_spec = in_stmt : (Locations.t * ail_bindings_and_statements) list } -val generate_check_ownership_function - : with_ownership_checking:bool -> +val generate_get_or_put_ownership_function + : without_ownership_checking:bool -> C.ctype -> A.sigma_declaration * CF.GenTypes.genTypeCategory A.sigma_function_definition val generate_assume_ownership_function - : with_ownership_checking:bool -> + : without_ownership_checking:bool -> C.ctype -> A.sigma_declaration * CF.GenTypes.genTypeCategory A.sigma_function_definition @@ -143,12 +143,12 @@ val cn_to_ail_datatype A.sigma_cn_datatype -> Locations.t * A.sigma_tag_definition list -val cn_to_ail_pred_records +val cn_to_ail_records : (MembersKey.t * A.ail_identifier) list -> A.sigma_tag_definition list val cn_to_ail_function_internal - : Sym.t * LogicalFunctions.definition -> + : Sym.t * Definition.Function.t -> A.sigma_cn_datatype list -> A.sigma_cn_function list -> ((Locations.t * A.sigma_declaration) @@ -156,10 +156,10 @@ val cn_to_ail_function_internal * A.sigma_tag_definition option val cn_to_ail_predicates_internal - : (Sym.t * ResourcePredicates.definition) list -> + : (Sym.t * Definition.Predicate.t) list -> A.sigma_cn_datatype list -> (Sym.t * C.ctype) list -> - (Sym.t * ResourcePredicates.definition) list -> + (Sym.t * Definition.Predicate.t) list -> A.sigma_cn_predicate list -> ((Locations.t * A.sigma_declaration) * CF.GenTypes.genTypeCategory A.sigma_function_definition) @@ -167,19 +167,19 @@ val cn_to_ail_predicates_internal * A.sigma_tag_definition option list val cn_to_ail_pre_post_internal - : with_ownership_checking:bool -> + : without_ownership_checking:bool -> A.sigma_cn_datatype list -> - (Sym.t * ResourcePredicates.definition) list -> + (Sym.t * Definition.Predicate.t) list -> (Sym.t * C.ctype) list -> C.ctype -> - Core_to_mucore.fn_spec_instrumentation option -> + Executable_spec_extract.fn_args_and_body option -> ail_executable_spec val cn_to_ail_assume_predicates_internal - : (Sym.t * ResourcePredicates.definition) list -> + : (Sym.t * Definition.Predicate.t) list -> A.sigma_cn_datatype list -> (Sym.t * C.ctype) list -> - (Sym.t * ResourcePredicates.definition) list -> + (Sym.t * Definition.Predicate.t) list -> (A.sigma_declaration * CF.GenTypes.genTypeCategory A.sigma_function_definition) list val cn_to_ail_assume_pre_internal @@ -187,6 +187,6 @@ val cn_to_ail_assume_pre_internal C.union_tag -> (C.union_tag * (BT.t * C.ctype)) list -> (C.union_tag * C.ctype) list -> - (C.union_tag * ResourcePredicates.definition) list -> + (C.union_tag * Definition.Predicate.t) list -> 'a LogicalArgumentTypes.t -> A.sigma_declaration * CF.GenTypes.genTypeCategory A.sigma_function_definition diff --git a/backend/cn/lib/cnprog.ml b/backend/cn/lib/cnprog.ml index fbf5e6c11..40b3491f0 100644 --- a/backend/cn/lib/cnprog.ml +++ b/backend/cn/lib/cnprog.ml @@ -2,7 +2,7 @@ module BT = BaseTypes module IT = IndexTerms module Loc = Locations module CF = Cerb_frontend -module RET = ResourceTypes +module Req = Request module LC = LogicalConstraints type have_show = @@ -12,8 +12,8 @@ type have_show = type extract = Id.t list * (Sym.t, Sctypes.t) CF.Cn.cn_to_extract * IndexTerms.t type statement = - | Pack_unpack of CF.Cn.pack_unpack * ResourceTypes.predicate_type - | To_from_bytes of CF.Cn.to_from * ResourceTypes.predicate_type + | Pack_unpack of CF.Cn.pack_unpack * Request.Predicate.t + | To_from_bytes of CF.Cn.to_from * Request.Predicate.t | Have of LogicalConstraints.t | Instantiate of (Sym.t, Sctypes.t) CF.Cn.cn_to_instantiate * IndexTerms.t | Split_case of LogicalConstraints.t @@ -42,9 +42,9 @@ let rec subst substitution = function let stmt = match stmt with | Pack_unpack (pack_unpack, pt) -> - Pack_unpack (pack_unpack, RET.subst_predicate_type substitution pt) + Pack_unpack (pack_unpack, Req.Predicate.subst substitution pt) | To_from_bytes (to_from, pt) -> - To_from_bytes (to_from, RET.subst_predicate_type substitution pt) + To_from_bytes (to_from, Req.Predicate.subst substitution pt) | Have lc -> Have (LC.subst substitution lc) | Instantiate (o_s, it) -> (* o_s is not a (option) binder *) @@ -73,7 +73,7 @@ and alpha_rename from prog = and suitably_alpha_rename syms s prog = - if IT.SymSet.mem s syms then + if Sym.Set.mem s syms then alpha_rename s prog else (s, prog) @@ -104,14 +104,13 @@ let dtree_of_to_extract = let dtree_of_statement = let open Cerb_frontend.Pp_ast in function - | Pack_unpack (Pack, pred) -> - Dnode (pp_ctor "Pack", [ ResourceTypes.dtree_of_predicate_type pred ]) + | Pack_unpack (Pack, pred) -> Dnode (pp_ctor "Pack", [ Request.Predicate.dtree pred ]) | Pack_unpack (Unpack, pred) -> - Dnode (pp_ctor "Unpack", [ ResourceTypes.dtree_of_predicate_type pred ]) + Dnode (pp_ctor "Unpack", [ Request.Predicate.dtree pred ]) | To_from_bytes (To, pred) -> - Dnode (pp_ctor "To_bytes", [ ResourceTypes.dtree_of_predicate_type pred ]) + Dnode (pp_ctor "To_bytes", [ Request.Predicate.dtree pred ]) | To_from_bytes (From, pred) -> - Dnode (pp_ctor "From_bytes", [ ResourceTypes.dtree_of_predicate_type pred ]) + Dnode (pp_ctor "From_bytes", [ Request.Predicate.dtree pred ]) | Have lc -> Dnode (pp_ctor "Have", [ LC.dtree lc ]) | Instantiate (to_instantiate, it) -> Dnode (pp_ctor "Instantiate", [ dtree_of_to_instantiate to_instantiate; IT.dtree it ]) diff --git a/backend/cn/lib/compile.ml b/backend/cn/lib/compile.ml index 648d9613d..cfad7854c 100644 --- a/backend/cn/lib/compile.ml +++ b/backend/cn/lib/compile.ml @@ -1,19 +1,17 @@ module CF = Cerb_frontend module SBT = BaseTypes.Surface module BT = BaseTypes -module RP = ResourcePredicates +module Def = Definition module IT = IndexTerms module LAT = LogicalArgumentTypes module LRT = LogicalReturnTypes module LC = LogicalConstraints -module RET = ResourceTypes +module Req = Request module Mu = Mucore module RT = ReturnTypes open Pp open CF.Cn open TypeErrors -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) module STermMap = Map.Make (IndexTerms.Surface) module StringMap = Map.Make (String) module StringSet = Set.Make (String) @@ -29,25 +27,25 @@ type predicate_sig = } type env = - { computationals : (SBT.t * Sym.t option) SymMap.t; - logicals : SBT.t SymMap.t; - predicates : predicate_sig SymMap.t; - functions : function_sig SymMap.t; - datatypes : BaseTypes.dt_info SymMap.t; - datatype_constrs : BaseTypes.constr_info SymMap.t; + { computationals : (SBT.t * Sym.t option) Sym.Map.t; + logicals : SBT.t Sym.Map.t; + predicates : predicate_sig Sym.Map.t; + functions : function_sig Sym.Map.t; + datatypes : BaseTypes.dt_info Sym.Map.t; + datatype_constrs : BaseTypes.constr_info Sym.Map.t; tagDefs : (Cerb_frontend.Symbol.sym, Mu.tag_definition) Pmap.map; - fetch_enum_expr : Locations.t -> Sym.t -> unit CF.AilSyntax.expression Resultat.t; - fetch_typedef : Locations.t -> Sym.t -> CF.Ctype.ctype Resultat.t + fetch_enum_expr : Locations.t -> Sym.t -> unit CF.AilSyntax.expression Or_TypeError.t; + fetch_typedef : Locations.t -> Sym.t -> CF.Ctype.ctype Or_TypeError.t } let init_env tagDefs fetch_enum_expr fetch_typedef = - let alloc_sig = { pred_iargs = []; pred_output = ResourcePredicates.alloc.oarg_bt } in - { computationals = SymMap.empty; - logicals = SymMap.(empty |> add Alloc.History.sym Alloc.History.sbt); - predicates = SymMap.(empty |> add Alloc.Predicate.sym alloc_sig); - functions = SymMap.empty; - datatypes = SymMap.empty; - datatype_constrs = SymMap.empty; + let alloc_sig = { pred_iargs = []; pred_output = Definition.alloc.oarg_bt } in + { computationals = Sym.Map.empty; + logicals = Sym.Map.(empty |> add Alloc.History.sym Alloc.History.sbt); + predicates = Sym.Map.(empty |> add Alloc.Predicate.sym alloc_sig); + functions = Sym.Map.empty; + datatypes = Sym.Map.empty; + datatype_constrs = Sym.Map.empty; tagDefs; fetch_enum_expr; fetch_typedef @@ -64,32 +62,32 @@ let symtable = SymTable.create 10000 let add_computational sym bTy env = SymTable.add symtable sym bTy; - { env with computationals = SymMap.add sym (bTy, None) env.computationals } + { env with computationals = Sym.Map.add sym (bTy, None) env.computationals } let add_renamed_computational sym sym2 bTy env = SymTable.add symtable sym bTy; - { env with computationals = SymMap.add sym (bTy, Some sym2) env.computationals } + { env with computationals = Sym.Map.add sym (bTy, Some sym2) env.computationals } let add_logical sym bTy env = SymTable.add symtable sym bTy; - { env with logicals = SymMap.add sym bTy env.logicals } + { env with logicals = Sym.Map.add sym bTy env.logicals } let add_predicate sym pred_sig env = - { env with predicates = SymMap.add sym pred_sig env.predicates } + { env with predicates = Sym.Map.add sym pred_sig env.predicates } let lookup_computational_or_logical sym env = - match SymMap.find_opt sym env.logicals with + match Sym.Map.find_opt sym env.logicals with | Some bt -> Some (bt, None) - | None -> SymMap.find_opt sym env.computationals + | None -> Sym.Map.find_opt sym env.computationals -let lookup_predicate sym env = SymMap.find_opt sym env.predicates +let lookup_predicate sym env = Sym.Map.find_opt sym env.predicates -let lookup_function sym env = SymMap.find_opt sym env.functions +let lookup_function sym env = Sym.Map.find_opt sym env.functions let lookup_struct_opt sym env = match Pmap.lookup sym env.tagDefs with @@ -98,17 +96,17 @@ let lookup_struct_opt sym env = let add_datatype sym info env = - let datatypes = SymMap.add sym info env.datatypes in + let datatypes = Sym.Map.add sym info env.datatypes in { env with datatypes } let add_datatype_constr sym info env = - let datatype_constrs = SymMap.add sym info env.datatype_constrs in + let datatype_constrs = Sym.Map.add sym info env.datatype_constrs in { env with datatype_constrs } let get_datatype_maps env = - (SymMap.bindings env.datatypes, SymMap.bindings env.datatype_constrs) + (Sym.Map.bindings env.datatypes, Sym.Map.bindings env.datatype_constrs) type cn_predicate = (CF.Symbol.sym, CF.Ctype.ctype) CF.Cn.cn_predicate @@ -158,22 +156,22 @@ type cn_datatype = CF.Symbol.sym CF.Cn.cn_datatype (* | CNExpr_default bt -> !^"default" *) let rec symset_bigunion = function - | [] -> SymSet.empty - | syms :: symses -> SymSet.union syms (symset_bigunion symses) + | [] -> Sym.Set.empty + | syms :: symses -> Sym.Set.union syms (symset_bigunion symses) let rec bound_by_pattern (CNPat (_loc, pat_)) = match pat_ with - | CNPat_sym s -> SymSet.singleton s - | CNPat_wild -> SymSet.empty + | CNPat_sym s -> Sym.Set.singleton s + | CNPat_wild -> Sym.Set.empty | CNPat_constructor (_, args) -> symset_bigunion (List.map (fun (_, p) -> bound_by_pattern p) args) let rec free_in_expr (CNExpr (_loc, expr_)) = match expr_ with - | CNExpr_const _ -> SymSet.empty - | CNExpr_var v -> SymSet.singleton v + | CNExpr_const _ -> Sym.Set.empty + | CNExpr_var v -> Sym.Set.singleton v | CNExpr_list es -> free_in_exprs es | CNExpr_memberof (e, _id) -> free_in_expr e | CNExpr_arrow (e, _id) -> free_in_expr e @@ -183,39 +181,39 @@ let rec free_in_expr (CNExpr (_loc, expr_)) = | CNExpr_arrayindexupdates (e, updates) -> free_in_exprs (e :: List.concat_map (fun (e1, e2) -> [ e1; e2 ]) updates) | CNExpr_binop (_binop, e1, e2) -> free_in_exprs [ e1; e2 ] - | CNExpr_sizeof _ -> SymSet.empty - | CNExpr_offsetof _ -> SymSet.empty + | CNExpr_sizeof _ -> Sym.Set.empty + | CNExpr_offsetof _ -> Sym.Set.empty | CNExpr_array_shift (e1, _ct, e2) -> free_in_exprs [ e1; e2 ] | CNExpr_membershift (e, _opt_tag, _id) -> free_in_expr e - | CNExpr_addr _ -> SymSet.empty + | CNExpr_addr _ -> Sym.Set.empty | CNExpr_cast (_bt, e) -> free_in_expr e | CNExpr_call (_id, es) -> free_in_exprs es | CNExpr_cons (_c, args) -> free_in_exprs (List.map snd args) - | CNExpr_each (s, _bt, _range, e) -> SymSet.remove s (free_in_expr e) + | CNExpr_each (s, _bt, _range, e) -> Sym.Set.remove s (free_in_expr e) | CNExpr_match (x, ms) -> let free_per_case = List.map - (fun (pat, body) -> SymSet.diff (free_in_expr body) (bound_by_pattern pat)) + (fun (pat, body) -> Sym.Set.diff (free_in_expr body) (bound_by_pattern pat)) ms in - SymSet.union (free_in_expr x) (symset_bigunion free_per_case) + Sym.Set.union (free_in_expr x) (symset_bigunion free_per_case) | CNExpr_let (s, e, body) -> - SymSet.union (free_in_expr e) (SymSet.remove s (free_in_expr body)) + Sym.Set.union (free_in_expr e) (Sym.Set.remove s (free_in_expr body)) | CNExpr_ite (e1, e2, e3) -> free_in_exprs [ e1; e2; e3 ] | CNExpr_good (_typ, e) -> free_in_expr e | CNExpr_deref e -> free_in_expr e - | CNExpr_value_of_c_atom (s, _) -> SymSet.singleton s + | CNExpr_value_of_c_atom (s, _) -> Sym.Set.singleton s | CNExpr_unchanged e -> free_in_expr e | CNExpr_at_env (e, _evaluation_scope) -> free_in_expr e | CNExpr_not e -> free_in_expr e | CNExpr_bnot e -> free_in_expr e | CNExpr_negate e -> free_in_expr e - | CNExpr_default _bt -> SymSet.empty + | CNExpr_default _bt -> Sym.Set.empty and free_in_exprs = function - | [] -> SymSet.empty - | e :: es -> SymSet.union (free_in_expr e) (free_in_exprs es) + | [] -> Sym.Set.empty + | e :: es -> Sym.Set.union (free_in_expr e) (free_in_exprs es) let rec translate_cn_base_type env (bTy : CF.Symbol.sym cn_base_type) = @@ -240,7 +238,7 @@ let rec translate_cn_base_type env (bTy : CF.Symbol.sym cn_base_type) = failwith "user type-abbreviation not removed by cabs->ail elaboration" | CN_c_typedef_name sym -> (* FIXME handle errors here properly *) - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in (match env.fetch_typedef here sym with | Result.Ok r -> Memory.sbt_of_sct (Sctypes.of_ctype_unsafe here r) | Result.Error e -> failwith (Pp.plain TypeErrors.((pp_message e.msg).short))) @@ -260,9 +258,9 @@ let register_cn_predicates env (defs : cn_predicate list) = List.fold_left aux env defs -open Resultat +open Or_TypeError -open Effectful.Make (Resultat) +open Effectful.Make (Or_TypeError) (* TODO: handle more kinds of constant expression *) let convert_enum_expr = @@ -314,7 +312,7 @@ let do_decode_enum env loc sym = let add_function _loc sym func_sig env = - return { env with functions = SymMap.add sym func_sig env.functions } + return { env with functions = Sym.Map.add sym func_sig env.functions } let register_cn_functions env (defs : cn_function list) = @@ -333,19 +331,24 @@ let register_cn_functions env (defs : cn_function list) = let add_datatype_info env (dt : cn_datatype) = Pp.debug 2 (lazy (Pp.item "translating datatype declaration" (Sym.pp dt.cn_dt_name))); - (* This seems to require that variables aren't simply unique to the constructor, but to - the entire datatype declaration. This is weird, and is probably an arbitrary - restriction that should be lifted, but it will require effort. *) + (* SMT format constraints seem to require variables to be unique to the + datatype, not just the constructor. *) let add_param m (nm, ty) = - match StringMap.find_opt (Id.s nm) m with + match StringMap.find_opt (Id.get_string nm) m with | None -> - return (StringMap.add (Id.s nm) (nm, SBT.proj (translate_cn_base_type env ty)) m) + return + (StringMap.add + (Id.get_string nm) + (nm, SBT.proj (translate_cn_base_type env ty)) + m) | Some _ -> fail - { loc = Id.loc nm; + { loc = Id.get_loc nm; msg = Generic - (!^"Re-using member name" ^^^ Id.pp nm ^^^ !^"within datatype definition.") + (!^"Re-using member name" + ^^^ Id.pp nm + ^^^ !^"within datatype definition (SMT limitation).") } in let@ all_params = @@ -369,18 +372,21 @@ let add_datatype_infos env dts = ListM.fold_leftM add_datatype_info env dts module E = struct type evaluation_scope = string - type 'a m = + type 'a t = | Done of 'a | Error of TypeErrors.t - | ScopeExists of Loc.t * evaluation_scope * (bool -> 'a m) + | ScopeExists of Locations.t * evaluation_scope * (bool -> 'a t) | Value_of_c_variable of - Loc.t * Sym.t * evaluation_scope option * (IT.Surface.t option -> 'a m) + Locations.t * Sym.t * evaluation_scope option * (IT.Surface.t option -> 'a t) | Deref of - Loc.t * IT.Surface.t * evaluation_scope option * (IT.Surface.t option -> 'a m) + Locations.t + * IT.Surface.t + * evaluation_scope option + * (IT.Surface.t option -> 'a t) let return x = Done x - let rec bind (m : 'a m) (f : 'a -> 'b m) : 'b m = + let rec bind (m : 'a t) (f : 'a -> 'b t) : 'b t = match m with | Done x -> f x | Error err -> Error err @@ -400,7 +406,7 @@ module E = struct Value_of_c_variable (loc, sym, scope, fun o_v_it -> Done o_v_it) - let liftResultat = function Result.Ok a -> Done a | Result.Error e -> Error e + let liftResult = function Result.Ok a -> Done a | Result.Error e -> Error e end let start_evaluation_scope = "start" @@ -418,26 +424,27 @@ module EffectfulTranslation = struct let lookup_struct loc tag env = match lookup_struct_opt tag env with | Some def -> return def - | None -> fail { loc; msg = Unknown_struct tag } + | None -> fail { loc; msg = Global (Unknown_struct tag) } let lookup_member loc (_tag, def) member = let member_types = Memory.member_types def in match List.assoc_opt Id.equal member member_types with | Some ty -> return ty - | None -> fail { loc; msg = Unexpected_member (List.map fst member_types, member) } + | None -> + fail { loc; msg = Global (Unexpected_member (List.map fst member_types, member)) } let lookup_datatype loc sym env = - match SymMap.find_opt sym env.datatypes with + match Sym.Map.find_opt sym env.datatypes with | Some info -> return info - | None -> fail TypeErrors.{ loc; msg = TypeErrors.Unknown_datatype sym } + | None -> fail { loc; msg = Global (Unknown_datatype sym) } let lookup_constr loc sym env = - match SymMap.find_opt sym env.datatype_constrs with + match Sym.Map.find_opt sym env.datatype_constrs with | Some info -> return info - | None -> fail TypeErrors.{ loc; msg = TypeErrors.Unknown_datatype_constr sym } + | None -> fail { loc; msg = Global (Unknown_datatype_constr sym) } let cannot_tell_pointee_ctype loc e = @@ -447,12 +454,11 @@ module EffectfulTranslation = struct (* TODO: type checks and disambiguation at this stage seems ill-advised, ideally would be integrated into wellTyped.ml *) - let mk_translate_binop loc' bop (e1, e2) = + let mk_translate_binop loc bop (e1, e2) = let open IndexTerms in - let loc = loc' in - match (bop, IT.bt e1) with + match (bop, get_bt e1) with | CN_add, (BT.Integer | Real | Bits _) -> - return (IT (Binop (Add, e1, e2), IT.bt e1, loc)) + return (IT (Binop (Add, e1, e2), get_bt e1, loc)) | CN_add, Loc oct -> (match oct with | Some ct -> @@ -463,11 +469,11 @@ module EffectfulTranslation = struct return (IT (it_, Loc oct, loc)) | None -> cannot_tell_pointee_ctype loc e1) | CN_sub, (Integer | Real | Bits _) -> - return (IT (Binop (Sub, e1, e2), IT.bt e1, loc)) + return (IT (Binop (Sub, e1, e2), get_bt e1, loc)) | CN_sub, Loc oct -> (match oct with | Some ct -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let (IT (it_, _, _)) = Surface.inj (arrayShift_ @@ -478,11 +484,11 @@ module EffectfulTranslation = struct in return (IT (it_, Loc oct, loc)) | None -> cannot_tell_pointee_ctype loc e1) - | CN_mul, _ -> return (IT (Binop (Mul, e1, e2), IT.bt e1, loc)) - | CN_div, _ -> return (IT (Binop (Div, e1, e2), IT.bt e1, loc)) - | CN_mod, _ -> return (IT (Binop (Rem, e1, e2), IT.bt e1, loc)) + | CN_mul, _ -> return (IT (Binop (Mul, e1, e2), get_bt e1, loc)) + | CN_div, _ -> return (IT (Binop (Div, e1, e2), get_bt e1, loc)) + | CN_mod, _ -> return (IT (Binop (Rem, e1, e2), get_bt e1, loc)) | CN_equal, _ -> - (match (IT.bt e1, IT.bt e2, !pointer_eq_warned) with + (match (get_bt e1, get_bt e2, !pointer_eq_warned) with | Loc _, Loc _, false -> pointer_eq_warned := true; Pp.warn @@ -492,7 +498,7 @@ module EffectfulTranslation = struct | _, _, _ -> ()); return (IT (Binop (EQ, e1, e2), BT.Bool, loc)) | CN_inequal, _ -> - (match (IT.bt e1, IT.bt e2, !pointer_eq_warned) with + (match (get_bt e1, get_bt e2, !pointer_eq_warned) with | Loc _, Loc _, false -> pointer_eq_warned := true; Pp.warn @@ -518,14 +524,16 @@ module EffectfulTranslation = struct | CN_implies, BT.Bool -> return (IT (Binop (Implies, e1, e2), BT.Bool, loc)) | CN_map_get, _ -> let@ rbt = - match IT.bt e1 with + match get_bt e1 with | Map (_, rbt) -> return rbt | has -> let expected = "map/array" in let reason = "map/array index" in fail { loc; - msg = Illtyped_it { it = Terms.pp e1; has = SBT.pp has; expected; reason } + msg = + WellTyped + (Illtyped_it { it = Terms.pp e1; has = SBT.pp has; expected; reason }) } in return (IT (MapGet (e1, e2), rbt, loc)) @@ -537,12 +545,13 @@ module EffectfulTranslation = struct (* just copy-pasting and adapting Kayvan's older version of this code *) let translate_member_access loc env (t : IT.Surface.t) member = - match IT.bt t with + match IT.get_bt t with | BT.Record members -> let@ member_bt = match List.assoc_opt Id.equal member members with | Some member_bt -> return member_bt - | None -> fail { loc; msg = Unexpected_member (List.map fst members, member) } + | None -> + fail { loc; msg = Global (Unexpected_member (List.map fst members, member)) } in return (IT.recordMember_ ~member_bt (t, member) loc) | Struct tag -> @@ -567,8 +576,9 @@ module EffectfulTranslation = struct fail { loc; msg = - Illtyped_it - { it = Terms.pp t; has = BaseTypes.Surface.pp has; expected; reason } + WellTyped + (Illtyped_it + { it = Terms.pp t; has = BaseTypes.Surface.pp has; expected; reason }) } @@ -577,7 +587,7 @@ module EffectfulTranslation = struct | CNPat_wild -> return (env, locally_bound, IT.Pat (PWild, bt, loc)) | CNPat_sym s -> let env' = add_logical s bt env in - let locally_bound' = SymSet.add s locally_bound in + let locally_bound' = Sym.Set.add s locally_bound in return (env', locally_bound', IT.Pat (PSym s, bt, loc)) | CNPat_constructor (cons, args) -> let@ cons_info = lookup_constr loc cons env in @@ -586,7 +596,10 @@ module EffectfulTranslation = struct (fun (env, locally_bound, acc) (m, pat') -> match List.assoc_opt Id.equal m cons_info.params with | None -> - fail { loc; msg = Unexpected_member (List.map fst cons_info.params, m) } + fail + { loc; + msg = Global (Unexpected_member (List.map fst cons_info.params, m)) + } | Some mbt -> let@ env', locally_bound', pat' = translate_cn_pat env locally_bound (pat', SBT.inj mbt) @@ -644,21 +657,21 @@ module EffectfulTranslation = struct ("failed lookup of CNExpr_var " ^ Sym.pp_string sym) (Pp.list (fun (nm, _) -> Sym.pp nm) - (SymMap.bindings env.computationals)))); - fail { loc; msg = Unknown_variable sym } + (Sym.Map.bindings env.computationals)))); + fail { loc; msg = WellTyped (Unknown_variable sym) } | Some (bt, None) -> return (sym, bt) | Some (bt, Some renamed_sym) -> return (renamed_sym, bt) in return (IT (Sym sym, bTy, loc)) | CNExpr_list es -> let@ es = ListM.mapM self es in - let item_bt = basetype (List.hd es) in + let item_bt = get_bt (List.hd es) in let _, nil_pos, _ = (* parser should ensure loc is a region *) Option.get @@ Locations.get_region loc in let cons hd tl = - let hd_pos = Option.get @@ Locations.start_pos @@ IT.loc hd in + let hd_pos = Option.get @@ Locations.start_pos @@ IT.get_loc hd in let loc = Locations.(region (hd_pos, nil_pos) NoCursor) in IT (Cons (hd, tl), BT.List item_bt, loc) in @@ -676,22 +689,22 @@ module EffectfulTranslation = struct translate_member_access loc env e xs | CNExpr_record members -> let@ members = ListM.mapsndM self members in - let bts = List.map_snd IT.bt members in + let bts = List.map_snd IT.get_bt members in return (IT (IT.Record members, BT.Record bts, loc)) | CNExpr_struct (tag, members) -> let@ members = ListM.mapsndM self members in return (IT (IT.Struct (tag, members), BT.Struct tag, loc)) | CNExpr_memberupdates (e, updates) -> let@ e = self e in - let bt = IT.bt e in + let bt = IT.get_bt e in let end_pos = Option.get @@ Locations.end_pos loc in - (match IT.bt e with + (match IT.get_bt e with | Struct _ -> let@ expr = ListM.fold_rightM (fun (id, v) expr -> let@ v = self v in - let start_pos = Option.get @@ Locations.start_pos @@ Id.loc id in + let start_pos = Option.get @@ Locations.start_pos @@ Id.get_loc id in let cursor = Cerb_location.PointCursor start_pos in let loc = Locations.region (start_pos, end_pos) cursor in return (IT (StructUpdate ((expr, id), v), bt, loc))) @@ -701,20 +714,21 @@ module EffectfulTranslation = struct return expr | _ -> fail - { loc = IT.loc e; + { loc = IT.get_loc e; msg = - Illtyped_it - { it = Terms.pp e; - has = SBT.pp bt; - expected = "struct"; - reason = - (let head, pos = Locations.head_pos_of_location loc in - head ^ "\n" ^ pos) - } + WellTyped + (Illtyped_it + { it = Terms.pp e; + has = SBT.pp bt; + expected = "struct"; + reason = + (let head, pos = Locations.head_pos_of_location loc in + head ^ "\n" ^ pos) + }) }) | CNExpr_arrayindexupdates (e, updates) -> let@ e = self e in - let bt = IT.bt e in + let bt = IT.get_bt e in (* start_pos points to start_pos of e ignored cursor points to '[' end_pos points to ']' *) let start_pos, end_pos, _ = @@ -726,10 +740,11 @@ module EffectfulTranslation = struct (fun acc (i, v) -> let@ i = self i in let@ v = self v in - let end_pos = Option.get @@ Locations.end_pos @@ IT.loc v in + let end_pos = Option.get @@ Locations.end_pos @@ IT.get_loc v in (* cursor for the first update doesn't point to '[' - oh well *) let cursor = - Cerb_location.PointCursor (Option.get @@ Locations.start_pos @@ IT.loc i) + Cerb_location.PointCursor + (Option.get @@ Locations.start_pos @@ IT.get_loc i) in return (IT @@ -757,7 +772,7 @@ module EffectfulTranslation = struct | CNExpr_array_shift (base, ty_annot, index) -> let@ base = self base in let@ ct = - match (ty_annot, IT.bt base) with + match (ty_annot, IT.get_bt base) with | Some ty, _ -> (* this does not check whether the annotation and pointer type agree and just defers to what the user wrote, because pointer arithmetic can happen at any @@ -773,10 +788,10 @@ module EffectfulTranslation = struct pointer" } in - (match IT.bt base with + (match IT.get_bt base with | Loc _ -> let@ index = self index in - (match IT.bt index with + (match IT.get_bt index with | Integer | Bits _ -> return (IT (ArrayShift { base; ct; index }, Loc (Some ct), loc)) | has -> @@ -785,8 +800,9 @@ module EffectfulTranslation = struct fail { loc; msg = - Illtyped_it - { it = Terms.pp index; has = SBT.pp has; expected; reason } + WellTyped + (Illtyped_it + { it = Terms.pp index; has = SBT.pp has; expected; reason }) }) | has -> let expected = "pointer" in @@ -794,7 +810,8 @@ module EffectfulTranslation = struct fail { loc; msg = - Illtyped_it { it = Terms.pp base; has = SBT.pp has; expected; reason } + WellTyped + (Illtyped_it { it = Terms.pp base; has = SBT.pp has; expected; reason }) }) | CNExpr_membershift (e, opt_tag, member) -> let@ e = self e in @@ -808,7 +825,7 @@ module EffectfulTranslation = struct now. *) return (IT (it_, Loc (Some member_ty), loc)) in - (match (opt_tag, IT.bt e) with + (match (opt_tag, IT.get_bt e) with | Some tag, Loc (Some (Struct tag')) -> if Sym.equal tag tag' then with_tag tag @@ -818,8 +835,9 @@ module EffectfulTranslation = struct fail { loc; msg = - Illtyped_it - { it = Terms.pp e; has = SBT.pp (Struct tag'); expected; reason } + WellTyped + (Illtyped_it + { it = Terms.pp e; has = SBT.pp (Struct tag'); expected; reason }) }) | Some tag, Loc None | None, Loc (Some (Struct tag)) -> with_tag tag | None, Loc None -> cannot_tell_pointee_ctype loc e @@ -828,7 +846,9 @@ module EffectfulTranslation = struct let reason = "struct member offset" in fail { loc; - msg = Illtyped_it { it = Terms.pp e; has = SBT.pp has; expected; reason } + msg = + WellTyped + (Illtyped_it { it = Terms.pp e; has = SBT.pp has; expected; reason }) }) | CNExpr_addr nm -> return (sym_ (nm, BT.Loc None, loc)) | CNExpr_cast (bt, expr) -> @@ -837,7 +857,7 @@ module EffectfulTranslation = struct return (IT (Cast (SBT.proj bt, expr), bt, loc)) | CNExpr_call (fsym, exprs) -> let@ args = ListM.mapM self exprs in - let@ b = liftResultat (Builtins.apply_builtin_funs fsym args loc) in + let@ b = liftResult (Builtins.apply_builtin_funs fsym args loc) in (match b with | Some t -> return t | None -> @@ -846,7 +866,9 @@ module EffectfulTranslation = struct | Some fsig -> return fsig.return_bty | None -> fail - { loc; msg = Unknown_logical_function { id = fsym; resource = false } } + { loc; + msg = Global (Unknown_logical_function { id = fsym; resource = false }) + } in return (apply_ fsym args (BaseTypes.Surface.inj bt) loc)) | CNExpr_cons (c_nm, exprs) -> @@ -863,7 +885,7 @@ module EffectfulTranslation = struct let@ expr = trans evaluation_scope - (SymSet.add sym locally_bound) + (Sym.Set.add sym locally_bound) (add_logical sym BT.Integer env) e in @@ -879,24 +901,24 @@ module EffectfulTranslation = struct ListM.mapM (fun (pat, body) -> let@ env', locally_bound', pat = - translate_cn_pat env locally_bound (pat, IT.bt x) + translate_cn_pat env locally_bound (pat, IT.get_bt x) in let@ body = trans evaluation_scope locally_bound' env' body in return (pat, body)) ms in - let rbt = IT.basetype (snd (List.hd ms)) in + let rbt = IT.get_bt (snd (List.hd ms)) in return (IT (Match (x, ms), rbt, loc)) | CNExpr_let (s, e, body) -> let@ e = self e in let@ body = trans evaluation_scope - (SymSet.add s locally_bound) - (add_logical s (IT.bt e) env) + (Sym.Set.add s locally_bound) + (add_logical s (IT.get_bt e) env) body in - return (IT (Let ((s, e), body), IT.bt body, loc)) + return (IT (Let ((s, e), body), IT.get_bt body, loc)) | CNExpr_ite (e1, e2, e3) -> let@ e1 = self e1 in let@ e2 = self e2 in @@ -946,8 +968,8 @@ module EffectfulTranslation = struct trans (Some scope) locally_bound env e | CNExpr_deref e -> let@ () = - let locally_bound_in_e = SymSet.inter (free_in_expr e) locally_bound in - match SymSet.elements locally_bound_in_e with + let locally_bound_in_e = Sym.Set.inter (free_in_expr e) locally_bound in + match Sym.Set.elements locally_bound_in_e with | [] -> return () | s :: _ -> let msg = @@ -979,7 +1001,7 @@ module EffectfulTranslation = struct in fail { loc; msg = Generic msg }) | CNExpr_value_of_c_atom (sym, C_kind_var) -> - assert (not (SymSet.mem sym locally_bound)); + assert (not (Sym.Set.mem sym locally_bound)); (* let@ o_v = match evaluation_scope with *) (* | Some scope -> *) (* let state = StringMap.find scope env.old_states in *) @@ -987,7 +1009,7 @@ module EffectfulTranslation = struct (* Option.map (function *) (* | CVS_Value x -> x *) (* | CVS_Pointer_pointing_to x -> x *) - (* ) (SymMap.find_opt sym state.c_variable_state) *) + (* ) (Sym.Map.find_opt sym state.c_variable_state) *) (* in *) (* return o_v *) (* | None -> *) @@ -1008,14 +1030,14 @@ module EffectfulTranslation = struct fail { loc; msg = Generic msg } | Some v -> return v) | CNExpr_value_of_c_atom (sym, C_kind_enum) -> - assert (not (SymSet.mem sym locally_bound)); - liftResultat (do_decode_enum env loc sym) + assert (not (Sym.Set.mem sym locally_bound)); + liftResult (do_decode_enum env loc sym) in trans None let translate_cn_res_info res_loc loc env res args = - let open RET in + let open Req in let@ ptr_expr, iargs = match args with | [] -> fail { loc; msg = First_iarg_missing } @@ -1026,7 +1048,7 @@ module EffectfulTranslation = struct match oty with | Some ty -> return (Sctypes.of_ctype_unsafe res_loc ty) | None -> - (match IT.bt ptr_expr with + (match IT.get_bt ptr_expr with | BT.Loc (Some ty) -> return ty | Loc None -> fail @@ -1045,30 +1067,34 @@ module EffectfulTranslation = struct fail { loc; msg = - Illtyped_it - { it = Terms.pp ptr_expr; has = SBT.pp has; expected; reason } + WellTyped + (Illtyped_it + { it = Terms.pp ptr_expr; has = SBT.pp has; expected; reason }) }) in match res with | CN_owned oty -> let@ scty = infer_scty "Owned" oty in - (* we don't take Resources.owned_oargs here because we want to maintain the C-type + (* we don't take Resource.owned_oargs here because we want to maintain the C-type information *) let oargs_ty = Memory.sbt_of_sct scty in - return (Owned (scty, Init), oargs_ty) + return (Req.Owned (scty, Init), oargs_ty) | CN_block oty -> let@ scty = infer_scty "Block" oty in let oargs_ty = Memory.sbt_of_sct scty in - return (Owned (scty, Uninit), oargs_ty) + return (Req.Owned (scty, Uninit), oargs_ty) | CN_named pred -> let@ pred_sig = match lookup_predicate pred env with | None -> - fail { loc; msg = Unknown_resource_predicate { id = pred; logical = false } } + fail + { loc; + msg = Global (Unknown_resource_predicate { id = pred; logical = false }) + } | Some pred_sig -> return pred_sig in let output_bt = pred_sig.pred_output in - return (PName pred, SBT.inj output_bt) + return (Req.PName pred, SBT.inj output_bt) in return (pname, ptr_expr, iargs, oargs_ty) @@ -1077,21 +1103,21 @@ module EffectfulTranslation = struct let open Pp in let qs = IT.sym_ sym_args in let msg_s = "Iterated predicate pointer must be array_shift(ptr, q_var):" in - match IT.term ptr_expr with + match IT.get_term ptr_expr with | ArrayShift { base = p; ct; index = x } when Terms.equal_annot SBT.equal x qs -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in return (p, IT.cast_ (SBT.proj bt) (IT.sizeOf_ ct here) here) | _ -> fail { loc; msg = Generic (!^msg_s ^^^ IT.pp ptr_expr) } let owned_good _sym (res_t, _oargs_ty) = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in match res_t with - | RET.P { pointer; name = Owned (scty, _); _ } -> + | Req.P { pointer; name = Owned (scty, _); _ } -> [ ( LC.T (IT.good_ (Pointer scty, pointer) here), (here, Some "default pointer constraint") ) ] - | RET.Q { pointer; name = Owned (scty, _); _ } -> + | Req.Q { pointer; name = Owned (scty, _); _ } -> [ ( LC.T (IT.good_ (Pointer scty, pointer) here), (here, Some "default pointer constraint") ) ] @@ -1099,12 +1125,12 @@ module EffectfulTranslation = struct let translate_cn_let_resource__pred env res_loc sym (pred_loc, res, args) = - let@ args = ListM.mapM (translate_cn_expr SymSet.empty env) args in + let@ args = ListM.mapM (translate_cn_expr Sym.Set.empty env) args in let@ pname, ptr_expr, iargs, oargs_ty = translate_cn_res_info res_loc pred_loc env res args in let pt = - ( RET.P + ( Req.P { name = pname; pointer = IT.Surface.proj ptr_expr; iargs = List.map IT.Surface.proj iargs @@ -1114,7 +1140,7 @@ module EffectfulTranslation = struct let pointee_value = match pname with | Owned (_, Init) -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in [ (ptr_expr, IT.sym_ (sym, oargs_ty, here)) ] | _ -> [] in @@ -1124,16 +1150,16 @@ module EffectfulTranslation = struct let translate_cn_let_resource__each env res_loc (q, bt, guard, pred_loc, res, args) = let@ bt' = check_quantified_base_type env pred_loc bt in let env_with_q = add_logical q bt' env in - let@ guard_expr = translate_cn_expr (SymSet.singleton q) env_with_q guard in - let@ args = ListM.mapM (translate_cn_expr (SymSet.singleton q) env_with_q) args in + let@ guard_expr = translate_cn_expr (Sym.Set.singleton q) env_with_q guard in + let@ args = ListM.mapM (translate_cn_expr (Sym.Set.singleton q) env_with_q) args in let@ pname, ptr_expr, iargs, oargs_ty = translate_cn_res_info res_loc pred_loc env_with_q res args in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ ptr_base, step = split_pointer_linear_step pred_loc (q, bt', here) ptr_expr in let m_oargs_ty = SBT.make_map_bt bt' oargs_ty in let pt = - ( RET.Q + ( Req.Q { name = pname; q = (q, SBT.proj bt'); q_loc = here; @@ -1161,13 +1187,13 @@ module EffectfulTranslation = struct let translate_cn_assrt env (loc, assrt) = match assrt with | CN_assert_exp e_ -> - let@ e = translate_cn_expr SymSet.empty env e_ in + let@ e = translate_cn_expr Sym.Set.empty env e_ in return (LC.T (IT.Surface.proj e)) | CN_assert_qexp (sym, bTy, e1_, e2_) -> let bt = translate_cn_base_type env bTy in let env_with_q = add_logical sym bt env in - let@ e1 = translate_cn_expr (SymSet.singleton sym) env_with_q e1_ in - let@ e2 = translate_cn_expr (SymSet.singleton sym) env_with_q e2_ in + let@ e1 = translate_cn_expr (Sym.Set.singleton sym) env_with_q e1_ in + let@ e2 = translate_cn_expr (Sym.Set.singleton sym) env_with_q e2_ in return (LC.Forall ((sym, SBT.proj bt), IT.impl_ (IT.Surface.proj e1, IT.Surface.proj e2) loc)) @@ -1177,8 +1203,8 @@ module ET = EffectfulTranslation module Pure = struct let handle what = function - | E.Done x -> Resultat.return x - | E.Error e -> Resultat.fail e + | E.Done x -> Or_TypeError.return x + | E.Error e -> Or_TypeError.fail e | E.Value_of_c_variable (loc, _, _, _) -> let msg = !^what ^^^ !^"are not allowed to refer to (the state of) C variables." in fail { loc; msg = Generic msg } @@ -1192,27 +1218,28 @@ end let translate_cn_func_body env body = let handle = Pure.handle "Function definitions" in - let@ body = handle (ET.translate_cn_expr SymSet.empty env body) in + let@ body = handle (ET.translate_cn_expr Sym.Set.empty env body) in return (IT.Surface.proj body) let known_attrs = [ "rec"; "coq_unfold" ] let translate_cn_function env (def : cn_function) = - let open LogicalFunctions in Pp.debug 2 (lazy (Pp.item "translating function defn" (Sym.pp def.cn_func_name))); let args = List.map (fun (sym, bTy) -> (sym, translate_cn_base_type env bTy)) def.cn_func_args in let env' = List.fold_left (fun acc (sym, bt) -> add_logical sym bt acc) env args in - let is_rec = List.exists (fun id -> String.equal (Id.s id) "rec") def.cn_func_attrs in + let is_rec = + List.exists (fun id -> String.equal (Id.get_string id) "rec") def.cn_func_attrs + in let coq_unfold = - List.exists (fun id -> String.equal (Id.s id) "coq_unfold") def.cn_func_attrs + List.exists (fun id -> String.equal (Id.get_string id) "coq_unfold") def.cn_func_attrs in let@ () = ListM.iterM (fun id -> - if List.exists (String.equal (Id.s id)) known_attrs then + if List.exists (String.equal (Id.get_string id)) known_attrs then return () else fail @@ -1221,21 +1248,22 @@ let translate_cn_function env (def : cn_function) = }) def.cn_func_attrs in - let@ definition = + let@ body = match def.cn_func_body with | Some body -> let@ body = translate_cn_func_body env' body in - return (if is_rec then Rec_Def body else Def body) - | None -> return Uninterp + return (if is_rec then Def.Function.Rec_Def body else Def.Function.Def body) + | None -> return Def.Function.Uninterp in let return_bt = translate_cn_base_type env def.cn_func_return_bty in let def2 = - { loc = def.cn_func_loc; - args = List.map_snd SBT.proj args; - return_bt = SBT.proj return_bt; - emit_coq = not coq_unfold; - definition - } + Def.Function. + { loc = def.cn_func_loc; + args = List.map_snd SBT.proj args; + return_bt = SBT.proj return_bt; + emit_coq = not coq_unfold; + body + } in return (def.cn_func_name, def2) @@ -1260,8 +1288,8 @@ let allocation_token loc addr_s = | SD_ObjectAddress obj_name -> Sym.fresh_make_uniq ("A_" ^ obj_name) | _ -> assert false in - let alloc_ret = ResourceTypes.make_alloc (IT.sym_ (addr_s, BT.Loc (), loc)) in - ((name, (ResourceTypes.P alloc_ret, Alloc.History.value_bt)), (loc, None)) + let alloc_ret = Request.make_alloc (IT.sym_ (addr_s, BT.Loc (), loc)) in + ((name, (Request.P alloc_ret, Alloc.History.value_bt)), (loc, None)) module LocalState = struct @@ -1272,11 +1300,11 @@ module LocalState = struct (* currently the variable is a pointer to memory holding this value *) type state = - { c_variable_state : c_variable_state SymMap.t; + { c_variable_state : c_variable_state Sym.Map.t; pointee_values : IT.Surface.t STermMap.t } - let empty_state = { c_variable_state = SymMap.empty; pointee_values = STermMap.empty } + let empty_state = { c_variable_state = Sym.Map.empty; pointee_values = STermMap.empty } type states = { state : state; @@ -1291,7 +1319,7 @@ module LocalState = struct let add_c_variable_state c_sym cvs { state; old_states } = { state = - { state with c_variable_state = SymMap.add c_sym cvs state.c_variable_state }; + { state with c_variable_state = Sym.Map.add c_sym cvs state.c_variable_state }; old_states } @@ -1310,14 +1338,14 @@ module LocalState = struct List.fold_left (fun st (p, v) -> add_pointee_value p v st) st pvs - let handle { state; old_states } : 'a E.m -> 'a Resultat.m = + let handle { state; old_states } : 'a E.t -> 'a Or_TypeError.t = let state_for_scope = function | None -> state | Some s -> StringMap.find s old_states in let rec aux = function - | E.Done x -> Resultat.return x - | E.Error e -> Resultat.fail e + | E.Done x -> Or_TypeError.return x + | E.Error e -> Or_TypeError.fail e | E.Value_of_c_variable (loc, sym, scope, k) -> let variable_state = (state_for_scope scope).c_variable_state in let o_v = @@ -1325,7 +1353,7 @@ module LocalState = struct (function | CVS_Value (sym', sbt) -> IT.sym_ (sym', sbt, loc) | CVS_Pointer_pointing_to x -> x) - (SymMap.find_opt sym variable_state) + (Sym.Map.find_opt sym variable_state) in aux (k o_v) | E.Deref (_loc, it, scope, k) -> @@ -1338,7 +1366,6 @@ module LocalState = struct end let translate_cn_clause env clause = - let open Resources in let open LocalState in let rec translate_cn_clause_aux env st acc clause = let module LAT = LogicalArgumentTypes in @@ -1357,15 +1384,15 @@ let translate_cn_clause env clause = let st' = add_pointee_values pointee_vals st in translate_cn_clause_aux env' st' acc' cl | CN_letExpr (loc, sym, e_, cl) -> - let@ e = handle st (ET.translate_cn_expr SymSet.empty env e_) in + let@ e = handle st (ET.translate_cn_expr Sym.Set.empty env e_) in let acc' z = acc (LAT.mDefine (sym, IT.Surface.proj e, (loc, None)) z) in - translate_cn_clause_aux (add_logical sym (IT.basetype e) env) st acc' cl + translate_cn_clause_aux (add_logical sym (IT.get_bt e) env) st acc' cl | CN_assert (loc, assrt, cl) -> let@ lc = handle st (ET.translate_cn_assrt env (loc, assrt)) in let acc' z = acc (LAT.mConstraint (lc, (loc, None)) z) in translate_cn_clause_aux env st acc' cl | CN_return (_loc, e_) -> - let@ e = handle st (ET.translate_cn_expr SymSet.empty env e_) in + let@ e = handle st (ET.translate_cn_expr Sym.Set.empty env e_) in let e = IT.Surface.proj e in acc (LAT.I e) in @@ -1376,14 +1403,14 @@ let translate_cn_clauses env clauses = let rec self acc = function | CN_clause (loc, cl_) -> let@ cl = translate_cn_clause env cl_ in - let here = Locations.other __FUNCTION__ in - return (RP.{ loc; guard = IT.bool_ true here; packing_ft = cl } :: acc) + let here = Locations.other __LOC__ in + return (Def.Clause.{ loc; guard = IT.bool_ true here; packing_ft = cl } :: acc) | CN_if (loc, e_, cl_, clauses') -> let@ e = - Pure.handle "Predicate guards" (ET.translate_cn_expr SymSet.empty env e_) + Pure.handle "Predicate guards" (ET.translate_cn_expr Sym.Set.empty env e_) in let@ cl = translate_cn_clause env cl_ in - self (RP.{ loc; guard = IT.Surface.proj e; packing_ft = cl } :: acc) clauses' + self ({ loc; guard = IT.Surface.proj e; packing_ft = cl } :: acc) clauses' in let@ xs = self [] clauses in return (List.rev xs) @@ -1397,7 +1424,6 @@ let translate_option_cn_clauses env = function let translate_cn_predicate env (def : cn_predicate) = - let open RP in Pp.debug 2 (lazy (Pp.item "translating predicate defn" (Sym.pp def.cn_pred_name))); let iargs, output_bt = match lookup_predicate def.cn_pred_name env with @@ -1412,12 +1438,13 @@ let translate_cn_predicate env (def : cn_predicate) = | (iarg0, BaseTypes.Loc ()) :: iargs' -> return ( def.cn_pred_name, - { loc = def.cn_pred_loc; - pointer = iarg0; - iargs = iargs'; - oarg_bt = output_bt; - clauses - } ) + Def.Predicate. + { loc = def.cn_pred_loc; + pointer = iarg0; + iargs = iargs'; + oarg_bt = output_bt; + clauses + } ) | (_, found_bty) :: _ -> fail { loc = def.cn_pred_loc; @@ -1443,8 +1470,10 @@ let rec make_lrt_generic env st = env, st ) | CN_cletExpr (loc, name, expr) :: ensures -> - let@ expr = handle st (ET.translate_cn_expr SymSet.empty env expr) in - let@ lrt, env, st = make_lrt_generic (add_logical name (IT.bt expr) env) st ensures in + let@ expr = handle st (ET.translate_cn_expr Sym.Set.empty env expr) in + let@ lrt, env, st = + make_lrt_generic (add_logical name (IT.get_bt expr) env) st ensures + in return (LRT.mDefine (name, IT.Surface.proj expr, (loc, None)) lrt, env, st) | CN_cconstr (loc, constr) :: ensures -> let@ lc = handle st (ET.translate_cn_assrt env (loc, constr)) in @@ -1487,8 +1516,8 @@ let make_rt loc (env : env) st (s, ct) (accesses, ensures) = make_lrt_with_accesses (add_computational s sbt env) st (accesses, ensures) in (* let info = (loc, Some "return value good") in *) - (* let here = Locations.other __FUNCTION__ in *) - (* let lrt = LRT.mConstraint (LC.t_ (IT.good_ (ct, IT.sym_ (s, bt, here)) here), info) + (* let here = Locations.other __LOC__ in *) + (* let lrt = LRT.mConstraint (LC.T (IT.good_ (ct, IT.sym_ (s, bt, here)) here), info) lrt in *) return (RT.mComputational ((s, bt), (loc, None)) lrt) @@ -1515,7 +1544,7 @@ let translate_cn_lemma env (def : cn_lemma) = module UsingLoads = struct let pointee_ct loc it = - match IT.bt it with + match IT.get_bt it with | BT.Loc (Some ct) -> return ct | BT.Loc None -> let msg = !^"Cannot tell pointee C-type of" ^^^ squotes (IT.pp it) ^^ dot in @@ -1523,11 +1552,13 @@ module UsingLoads = struct | has -> let expected = "pointer" in let reason = "dereferencing" in - let msg = Illtyped_it { it = IT.pp it; has = SBT.pp has; expected; reason } in + let msg = + WellTyped (Illtyped_it { it = IT.pp it; has = SBT.pp has; expected; reason }) + in fail { loc; msg } - let handle allocations old_states : Cnprog.t E.m -> Cnprog.t Resultat.m = + let handle allocations old_states : Cnprog.t E.t -> Cnprog.t Or_TypeError.t = let rec aux = function | E.Done x -> return x | E.Error e -> fail e @@ -1542,7 +1573,7 @@ module UsingLoads = struct (function | LocalState.CVS_Value (sym', sbt) -> IT.sym_ (sym', sbt, loc) | LocalState.CVS_Pointer_pointing_to x -> x) - (SymMap.find_opt sym variable_state) + (Sym.Map.find_opt sym variable_state) in aux (k o_v) | None -> @@ -1559,7 +1590,7 @@ module UsingLoads = struct | ScopeExists (_loc, scope, k) -> aux (k (StringMap.mem scope old_states)) and load loc action_pp pointer k = let@ pointee_ct = pointee_ct loc pointer in - let value_loc = Locations.other __FUNCTION__ in + let value_loc = Locations.other __LOC__ in let value_s = Sym.fresh_make_uniq (action_pp ^ "_" ^ Pp.plain (IT.pp pointer)) in let value_bt = Memory.sbt_of_sct pointee_ct in let value = IT.sym_ (value_s, value_bt, value_loc) in @@ -1583,7 +1614,7 @@ let translate_cn_statement (let open Effectful.Make (E) in match stmt_ with | CN_pack_unpack (pack_unpack, pred, args) -> - let@ args = ListM.mapM (ET.translate_cn_expr SymSet.empty env) args in + let@ args = ListM.mapM (ET.translate_cn_expr Sym.Set.empty env) args in let@ name, pointer, iargs, _oargs_ty = ET.translate_cn_res_info loc loc env pred args in @@ -1597,7 +1628,7 @@ let translate_cn_statement in return (Statement (loc, stmt)) | CN_to_from_bytes (to_from, pred, args) -> - let@ args = ListM.mapM (ET.translate_cn_expr SymSet.empty env) args in + let@ args = ListM.mapM (ET.translate_cn_expr Sym.Set.empty env) args in let@ name, pointer, iargs, _oargs_ty = ET.translate_cn_res_info loc loc env pred args in @@ -1614,7 +1645,7 @@ let translate_cn_statement let@ assrt = ET.translate_cn_assrt env (loc, assrt) in return (Statement (loc, Have assrt)) | CN_instantiate (to_instantiate, expr) -> - let@ expr = ET.translate_cn_expr SymSet.empty env expr in + let@ expr = ET.translate_cn_expr Sym.Set.empty env expr in let expr = IT.Surface.proj expr in let to_instantiate = match to_instantiate with @@ -1627,7 +1658,7 @@ let translate_cn_statement let@ e = ET.translate_cn_assrt env (loc, e) in return (Statement (loc, Split_case e)) | CN_extract (attrs, to_extract, expr) -> - let@ expr = ET.translate_cn_expr SymSet.empty env expr in + let@ expr = ET.translate_cn_expr Sym.Set.empty env expr in let expr = IT.Surface.proj expr in let to_extract = match to_extract with @@ -1640,18 +1671,18 @@ let translate_cn_statement in return (Statement (loc, Extract (attrs, to_extract, expr))) | CN_unfold (s, args) -> - let@ args = ListM.mapM (ET.translate_cn_expr SymSet.empty env) args in + let@ args = ListM.mapM (ET.translate_cn_expr Sym.Set.empty env) args in let args = List.map IT.Surface.proj args in return (Statement (loc, Unfold (s, args))) | CN_assert_stmt e -> let@ e = ET.translate_cn_assrt env (loc, e) in return (Statement (loc, Assert e)) | CN_apply (s, args) -> - let@ args = ListM.mapM (ET.translate_cn_expr SymSet.empty env) args in + let@ args = ListM.mapM (ET.translate_cn_expr Sym.Set.empty env) args in let args = List.map IT.Surface.proj args in return (Statement (loc, Apply (s, args))) | CN_inline nms -> return (Statement (loc, Inline nms)) | CN_print expr -> - let@ expr = ET.translate_cn_expr SymSet.empty env expr in + let@ expr = ET.translate_cn_expr Sym.Set.empty env expr in let expr = IT.Surface.proj expr in return (Statement (loc, Print expr))) diff --git a/backend/cn/lib/consistent.ml b/backend/cn/lib/consistent.ml new file mode 100644 index 000000000..78eb932f3 --- /dev/null +++ b/backend/cn/lib/consistent.ml @@ -0,0 +1,245 @@ +module LC = LogicalConstraints +module IT = IndexTerms +module Loc = Locations + +let debug, item = Pp.(debug, item) + +open Pp.Infix + +let pure, add_l, add_r, add_c, fail, provable, add_a, map_and_fold_resources = + Typing.(pure, add_l, add_r, add_c, fail, provable, add_a, map_and_fold_resources) + + +open Effectful.Make (Typing) + +let logicalReturnTypes loc lrt = + let rec aux = + let here = Locations.other __LOC__ in + function + | LogicalReturnTypes.Define ((s, it), ((loc, _) as info), lrt) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in + let@ () = add_c (fst info) (LC.T (IT.def_ s it here)) in + aux lrt + | Resource ((s, (re, re_oa_spec)), (loc, _), lrt) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_l s re_oa_spec (loc, lazy (Pp.string "let-var")) in + let@ () = add_r loc (re, O (IT.sym_ (s, re_oa_spec, here))) in + aux lrt + | Constraint (lc, info, lrt) -> + (* TODO abort early if one of the constraints is the literal fase, + so that users are allowed to write such specs *) + let@ () = add_c (fst info) lc in + aux lrt + | I -> + let@ provable = provable loc in + let here = Locations.other __LOC__ in + (match provable (LC.T (IT.bool_ false here)) with + | `True -> + fail (fun ctxt_log -> + { loc; msg = Inconsistent_assumptions ("return type", ctxt_log) }) + | `False -> return ()) + in + pure (aux lrt) + + +let returnTypes loc rt = + pure + (match rt with + | ReturnTypes.Computational ((name, bt), info, lrt) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_a name bt (fst info, lazy (Sym.pp name)) in + logicalReturnTypes loc lrt) + + +let logicalArgumentTypes i_welltyped i_pp kind loc at : unit Typing.t = + let module LAT = LogicalArgumentTypes in + let _ = (at : _ LAT.t) in + debug + 12 + (lazy (item ("checking wf of " ^ kind ^ " at " ^ Loc.to_string loc) (LAT.pp i_pp at))); + let rec aux = + let here = Locations.other __LOC__ in + function + | LAT.Define ((s, it), info, at) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in + let@ () = add_c (fst info) (LC.T (IT.def_ s it here)) in + aux at + | Resource ((s, (re, re_oa_spec)), (loc, _), at) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_l s re_oa_spec (loc, lazy (Pp.string "let-var")) in + let@ () = add_r loc (re, O (IT.sym_ (s, re_oa_spec, here))) in + aux at + | Constraint (lc, info, at) -> + let@ () = add_c (fst info) lc in + aux at + | I i -> + let@ provable = provable loc in + let here = Locations.other __LOC__ in + let@ () = + match provable (LC.T (IT.bool_ false here)) with + | `True -> + fail (fun ctxt_log -> { loc; msg = Inconsistent_assumptions (kind, ctxt_log) }) + | `False -> return () + in + i_welltyped loc i + in + pure (aux at) + + +let argumentTypes i_welltyped i_pp kind loc at : unit Typing.t = + let module AT = ArgumentTypes in + let _ = (at : _ AT.t) in + debug + 12 + (lazy (item ("checking wf of " ^ kind ^ " at " ^ Loc.to_string loc) (AT.pp i_pp at))); + let rec aux = function + | AT.Computational ((name, bt), info, at) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_a name bt (fst info, lazy (Sym.pp name)) in + aux at + | L at -> logicalArgumentTypes i_welltyped i_pp kind loc at + in + pure (aux at) + + +let pure_and_no_initial_resources loc m = + pure + (let@ (), _ = map_and_fold_resources loc (fun _re () -> (Deleted, ())) () in + m) + + +let function_type = + argumentTypes + (fun loc rt -> pure_and_no_initial_resources loc (returnTypes loc rt)) + ReturnTypes.pp + + +let logicalArguments + (i_welltyped : Loc.t -> 'i -> 'j Typing.t) + kind + loc + (at : 'i Mucore.arguments_l) + : unit Typing.t + = + let rec aux = + let here = Locations.other __LOC__ in + function + | Mucore.Define ((s, it), ((loc, _) as info), at) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in + let@ () = add_c (fst info) (LC.T (IT.def_ s it here)) in + aux at + | Resource ((s, (re, re_oa_spec)), (loc, _), at) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_l s re_oa_spec (loc, lazy (Pp.string "let-var")) in + let@ () = add_r loc (re, O (IT.sym_ (s, re_oa_spec, here))) in + aux at + | Constraint (lc, info, at) -> + let@ () = add_c (fst info) lc in + aux at + | I i -> + let@ provable = provable loc in + let here = Locations.other __LOC__ in + let@ () = + match provable (LC.T (IT.bool_ false here)) with + | `True -> + fail (fun ctxt_log -> { loc; msg = Inconsistent_assumptions (kind, ctxt_log) }) + | `False -> return () + in + i_welltyped loc i + in + pure (aux at) + + +let arguments + : (Loc.t -> 'i -> 'j Typing.t) -> string -> Loc.t -> 'i Mucore.arguments -> + unit Typing.t + = + fun (i_welltyped : Loc.t -> 'i -> 'j Typing.t) kind loc (at : 'i Mucore.arguments) -> + debug 6 (lazy !^__LOC__); + debug + 12 + (lazy + (item + ("checking consistency of " ^ kind ^ " at " ^ Loc.to_string loc) + (Cerb_frontend.Pp_ast.pp_doc_tree + (Mucore.dtree_of_arguments (fun _i -> Dleaf !^"...") at)))); + let rec aux = function + | Mucore.Computational ((name, bt), info, at) -> + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + let@ () = add_a name bt (fst info, lazy (Sym.pp name)) in + aux at + | L at -> logicalArguments i_welltyped kind loc at + in + pure (aux at) + + +let procedure : Loc.t -> _ Mucore.args_and_body -> unit Typing.t = + fun (loc : Loc.t) (at : 'TY1 Mucore.args_and_body) -> + arguments + (fun loc (_body, labels, rt) -> + let@ () = pure_and_no_initial_resources loc (returnTypes loc rt) in + PmapM.iterM + (fun _sym def -> + match def with + | Mucore.Return _ -> return () + | Label (loc, label_args_and_body, _annots, _parsed_spec, _loop_info) -> + pure_and_no_initial_resources + loc + (arguments + (fun _loc _label_body -> return ()) + "label" + loc + label_args_and_body)) + labels) + "function" + loc + at + + +let predicate pred = + let module Def = Definition in + let Def.Predicate.{ loc; pointer; iargs; oarg_bt = _; clauses } = pred in + (* no need to alpha-rename, because context.ml ensures there's no name clashes *) + pure + (let@ () = add_l pointer BaseTypes.(Loc ()) (loc, lazy (Pp.string "ptr-var")) in + let@ () = + ListM.iterM (fun (s, bt) -> add_l s bt (loc, lazy (Pp.string "input-var"))) iargs + in + match clauses with + | None -> return () + | Some clauses -> + let@ _ = + ListM.fold_leftM + (fun acc Def.Clause.{ loc; guard; packing_ft } -> + let here = Locations.other __LOC__ in + let negated_guards = + List.map (fun clause -> IT.not_ clause.Def.Clause.guard here) acc + in + pure + (let@ () = add_c loc (LC.T guard) in + let@ () = add_c loc (LC.T (IT.and_ negated_guards here)) in + let@ () = + logicalArgumentTypes + (fun _loc _it -> return ()) + IT.pp + "clause" + loc + packing_ft + in + return (acc @ [ Def.Clause.{ loc; guard; packing_ft } ]))) + [] + clauses + in + return ()) + + +let lemma loc _lemma_s lemma_typ = + argumentTypes + (fun loc lrt -> pure_and_no_initial_resources loc (logicalReturnTypes loc lrt)) + LogicalReturnTypes.pp + "lemma" + loc + lemma_typ diff --git a/backend/cn/lib/consistent.mli b/backend/cn/lib/consistent.mli new file mode 100644 index 000000000..d93cf1448 --- /dev/null +++ b/backend/cn/lib/consistent.mli @@ -0,0 +1,11 @@ +val function_type + : string -> + Locations.t -> + ReturnTypes.t ArgumentTypes.t -> + unit Typing.t + +val predicate : Definition.Predicate.t -> unit Typing.m + +val lemma : Locations.t -> 'a -> LogicalReturnTypes.t ArgumentTypes.t -> unit Typing.t + +val procedure : Locations.t -> 'TY1 Mucore.args_and_body -> unit Typing.t diff --git a/backend/cn/lib/context.ml b/backend/cn/lib/context.ml index 1d8e93046..474780df5 100644 --- a/backend/cn/lib/context.ml +++ b/backend/cn/lib/context.ml @@ -1,12 +1,8 @@ open Pp open List module BT = BaseTypes -module LS = LogicalSorts -module RE = Resources +module Res = Resource module LC = LogicalConstraints -module LCSet = Set.Make (LC) -module Loc = Locations -module SymMap = Map.Make (Sym) module IntMap = Map.Make (Int) type l_info = Locations.t * Pp.document Lazy.t @@ -19,7 +15,7 @@ type basetype_or_value = | BaseType of BT.t | Value of IndexTerms.t -let bt_of = function BaseType bt -> bt | Value v -> IndexTerms.bt v +let bt_of = function BaseType bt -> bt | Value v -> IndexTerms.get_bt v let has_value = function BaseType _ -> false | Value _ -> true @@ -36,11 +32,11 @@ type resource_history = } type t = - { computational : (basetype_or_value * l_info) SymMap.t; - logical : (basetype_or_value * l_info) SymMap.t; - resources : (RE.t * int) list * int; + { computational : (basetype_or_value * l_info) Sym.Map.t; + logical : (basetype_or_value * l_info) Sym.Map.t; + resources : (Res.t * int) list * int; resource_history : resource_history IntMap.t; - constraints : LCSet.t; + constraints : LC.Set.t; global : Global.t; where : Where.t } @@ -49,13 +45,13 @@ let empty = let logical = let loc_str = __FILE__ ^ ":" ^ string_of_int __LINE__ in let l_info = (Locations.other loc_str, lazy (Pp.string loc_str)) in - SymMap.(empty |> add Alloc.History.sym (BaseType Alloc.History.bt, l_info)) + Sym.Map.(empty |> add Alloc.History.sym (BaseType Alloc.History.bt, l_info)) in - { computational = SymMap.empty; + { computational = Sym.Map.empty; logical; resources = ([], 0); resource_history = IntMap.empty; - constraints = LCSet.empty; + constraints = LC.Set.empty; global = Global.empty; where = Where.empty } @@ -71,7 +67,7 @@ let pp_basetype_or_value = function let pp_variable_bindings bindings = Pp.list (fun (sym, (binding, _)) -> typ (Sym.pp sym) (pp_basetype_or_value binding)) - (SymMap.bindings bindings) + (Sym.Map.bindings bindings) let pp_constraints constraints = @@ -81,37 +77,37 @@ let pp_constraints constraints = LC.pp lc else parens !^"...") - (LCSet.elements constraints) + (LC.Set.elements constraints) let pp (ctxt : t) = item "computational" (pp_variable_bindings ctxt.computational) ^/^ item "logical" (pp_variable_bindings ctxt.logical) - ^/^ item "resources" (Pp.list RE.pp (get_rs ctxt)) + ^/^ item "resources" (Pp.list Res.pp (get_rs ctxt)) ^/^ item "constraints" (pp_constraints ctxt.constraints) -let bound_a s ctxt = SymMap.exists (fun s' _ -> Sym.equal s s') ctxt.computational +let bound_a s ctxt = Sym.Map.exists (fun s' _ -> Sym.equal s s') ctxt.computational -let bound_l s ctxt = SymMap.exists (fun s' _ -> Sym.equal s s') ctxt.logical +let bound_l s ctxt = Sym.Map.exists (fun s' _ -> Sym.equal s s') ctxt.logical let bound s ctxt = bound_a s ctxt || bound_l s ctxt let get_a s ctxt = - match SymMap.find_opt s ctxt.computational with + match Sym.Map.find_opt s ctxt.computational with | Some (bt_v, _) -> bt_v | None -> failwith ("Context.get_a: not found: " ^ Pp.plain (Sym.pp_debug s)) let get_l s ctxt = - match SymMap.find_opt s ctxt.logical with + match Sym.Map.find_opt s ctxt.logical with | Some (bt_v, _) -> bt_v | None -> failwith ("Context.get_l: not found: " ^ Pp.plain (Sym.pp_debug s)) let add_a_binding s binding info ctxt = if bound s ctxt then failwith ("already bound: " ^ Sym.pp_string s); - { ctxt with computational = SymMap.add s (binding, info) ctxt.computational } + { ctxt with computational = Sym.Map.add s (binding, info) ctxt.computational } let add_a s bt info ctxt = add_a_binding s (BaseType bt) info ctxt @@ -120,7 +116,7 @@ let add_a_value s value info ctxt = add_a_binding s (Value value) info ctxt let add_l_binding s binding info ctxt = if bound s ctxt then failwith ("already bound: " ^ Sym.pp_string s); - { ctxt with logical = SymMap.add s (binding, info) ctxt.logical } + { ctxt with logical = Sym.Map.add s (binding, info) ctxt.logical } let add_l s bt info ctxt = add_l_binding s (BaseType bt) info ctxt @@ -131,20 +127,20 @@ let add_l_value s value info ctxt = add_l_binding s (Value value) info ctxt attached to s: s will still be bound "logically", but out of scope as far as the Core program goes. *) let remove_a s ctxt = - let binding, info = SymMap.find s ctxt.computational in + let binding, info = Sym.Map.find s ctxt.computational in add_l_binding s binding info - { ctxt with computational = SymMap.remove s ctxt.computational } + { ctxt with computational = Sym.Map.remove s ctxt.computational } let add_c c (ctxt : t) = let s = ctxt.constraints in - if LCSet.mem c s then + if LC.Set.mem c s then ctxt else - { ctxt with constraints = LCSet.add c s } + { ctxt with constraints = LC.Set.add c s } let modify_where (f : Where.t -> Where.t) ctxt = { ctxt with where = f ctxt.where } @@ -204,7 +200,7 @@ let res_map_history m id = match IntMap.find_opt id m with | Some h -> h | None -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in { last_written = here; reason_written = "unknown"; last_written_id = id; @@ -246,16 +242,16 @@ let json (ctxt : t) : Yojson.Safe.t = List.map (fun (sym, (binding, _)) -> `Assoc [ ("name", Sym.json sym); ("type", basetype_or_value binding) ]) - (SymMap.bindings ctxt.computational) + (Sym.Map.bindings ctxt.computational) in let logical = List.map (fun (sym, (binding, _)) -> `Assoc [ ("name", Sym.json sym); ("type", basetype_or_value binding) ]) - (SymMap.bindings ctxt.logical) + (Sym.Map.bindings ctxt.logical) in - let resources = List.map RE.json (get_rs ctxt) in - let constraints = List.map LC.json (LCSet.elements ctxt.constraints) in + let resources = List.map Res.json (get_rs ctxt) in + let constraints = List.map LC.json (LC.Set.elements ctxt.constraints) in let json_record = `Assoc [ ("computational", `List computational); @@ -272,18 +268,18 @@ let json (ctxt : t) : Yojson.Safe.t = let not_given_to_solver ctxt = let global = ctxt.global in let constraints = - filter LogicalConstraints.is_forall (LCSet.elements ctxt.constraints) + filter LogicalConstraints.is_forall (LC.Set.elements ctxt.constraints) in let funs = - SymMap.bindings - (SymMap.filter - (fun _ v -> not (LogicalFunctions.given_to_solver v)) + Sym.Map.bindings + (Sym.Map.filter + (fun _ v -> not (Definition.Function.given_to_solver v)) global.logical_functions) in let preds = - SymMap.bindings - (SymMap.filter - (fun _ v -> not (ResourcePredicates.given_to_solver v)) + Sym.Map.bindings + (Sym.Map.filter + (fun _ v -> not (Definition.Predicate.given_to_solver v)) global.resource_predicates) in (constraints, funs, preds) diff --git a/backend/cn/lib/context.mli b/backend/cn/lib/context.mli new file mode 100644 index 000000000..872442846 --- /dev/null +++ b/backend/cn/lib/context.mli @@ -0,0 +1,108 @@ +type l_info = Locations.t * Pp.document Lazy.t + +val pp_l_info : Pp.document -> l_info -> Pp.document + +type basetype_or_value = + | BaseType of BaseTypes.t + | Value of IndexTerms.t + +val bt_of : basetype_or_value -> BaseTypes.t + +val has_value : basetype_or_value -> bool + +type resource_history = + { last_written : Locations.t; + reason_written : string; + last_written_id : int; + last_read : Locations.t; + last_read_id : int + } + +type t = + { computational : (basetype_or_value * l_info) Sym.Map.t; + logical : (basetype_or_value * l_info) Sym.Map.t; + resources : (Resource.t * int) list * int; + resource_history : resource_history Map.Make(Int).t; + constraints : LogicalConstraints.Set.t; + global : Global.t; + where : Where.t + } + +val empty : t + +val get_rs : t -> Resource.t list + +val pp_basetype_or_value : basetype_or_value -> Pp.document + +val pp_variable_bindings : (basetype_or_value * 'a) Sym.Map.t -> Pp.document + +val pp_constraints : LogicalConstraints.Set.t -> Pp.document + +val pp : t -> Pp.document + +val bound_a : Sym.t -> t -> bool + +val bound_l : Sym.t -> t -> bool + +val bound : Sym.t -> t -> bool + +val get_a : Sym.t -> t -> basetype_or_value + +val get_l : Sym.t -> t -> basetype_or_value + +val add_a_binding : Sym.t -> basetype_or_value -> l_info -> t -> t + +val add_a : Sym.t -> BaseTypes.t -> l_info -> t -> t + +val add_a_value : Sym.t -> IndexTerms.t -> l_info -> t -> t + +val add_l_binding : Sym.t -> basetype_or_value -> l_info -> t -> t + +val add_l : Sym.t -> BaseTypes.t -> l_info -> t -> t + +val add_l_value : Sym.t -> IndexTerms.t -> l_info -> t -> t + +val remove_a : Sym.t -> t -> t + +val add_c : LogicalConstraints.Set.elt -> t -> t + +val modify_where : (Where.t -> Where.t) -> t -> t + +val pp_history : resource_history -> Pp.document + +val set_map_history : int -> 'a -> 'a Map.Make(Int).t -> 'a Map.Make(Int).t + +val set_history : int -> resource_history -> t -> t + +val add_r : Locations.t -> Resource.t -> t -> t + +val res_map_history : resource_history Map.Make(Int).t -> int -> resource_history + +val res_history : t -> int -> resource_history + +val res_read + : Locations.t -> + int -> + int * resource_history Map.Make(Int).t -> + int * resource_history Map.Make(Int).t + +val res_written + : Locations.t -> + int -> + string -> + int * resource_history Map.Make(Int).t -> + int * resource_history Map.Make(Int).t + +val clone_history + : int -> + int list -> + resource_history Map.Make(Int).t -> + resource_history Map.Make(Int).t + +val json : t -> Yojson.Safe.t + +val not_given_to_solver + : t -> + LogicalConstraints.t list + * (Sym.t * Definition.Function.t) list + * (Sym.t * Definition.Predicate.t) list diff --git a/backend/cn/lib/coreTypeChecks.ml b/backend/cn/lib/coreTypeChecks.ml index 2b613c86f..fc5bf7894 100644 --- a/backend/cn/lib/coreTypeChecks.ml +++ b/backend/cn/lib/coreTypeChecks.ml @@ -1,12 +1,20 @@ (* comparisons between CN base types and Core base types *) -open Effectful.Make (Resultat) - module BT = BaseTypes open Cerb_frontend.Core -let check_against_core_bt fail_op core_bt cn_bt = - let fail cbt bt = +let check_against_core_bt core_bt cn_bt = + let fail msg = Result.Error msg in + let module M = struct + include Result + + type 'a t = ('a, Pp.document) Result.t + + let return = ok + end + in + let open Effectful.Make (M) in + let mismatch cbt bt = let msg1 = Pp.typ (Pp.string "mismatching core/CN types") @@ -22,7 +30,7 @@ let check_against_core_bt fail_op core_bt cn_bt = (Pp.string "inner mismatch") (Pp.ineq (Pp_mucore.pp_core_base_type cbt) (BT.pp bt))) in - fail_op msg2 + fail msg2 in let rec check_object_type = function | OTy_integer, BT.Integer -> return () @@ -32,9 +40,9 @@ let check_against_core_bt fail_op core_bt cn_bt = let@ () = check_object_type (OTy_integer, param_t) in check_object_type (t, t2) | OTy_struct tag, BT.Struct tag2 when Sym.equal tag tag2 -> return () - | OTy_union _tag, _ -> fail_op (Pp.string "unsupported: union types") - | OTy_floating, _ -> fail_op (Pp.string "unsupported: floats") - | core_obj_ty, bt -> fail (BTy_object core_obj_ty) bt + | OTy_union _tag, _ -> fail (Pp.string "unsupported: union types") + | OTy_floating, _ -> fail (Pp.string "unsupported: floats") + | core_obj_ty, bt -> mismatch (BTy_object core_obj_ty) bt in let rec check_core_base_type = function | BTy_unit, BT.Unit -> return () @@ -45,8 +53,8 @@ let check_against_core_bt fail_op core_bt cn_bt = | BTy_tuple cbts, BT.Tuple bts when List.length bts == List.length bts -> let@ _ = ListM.map2M (Tools.curry check_core_base_type) cbts bts in return () - | BTy_storable, _ -> fail_op (Pp.string "unsupported: BTy_storable") + | BTy_storable, _ -> fail (Pp.string "unsupported: BTy_storable") | BTy_ctype, BT.CType -> return () - | cbt, bt -> fail cbt bt + | cbt, bt -> mismatch cbt bt in check_core_base_type (core_bt, cn_bt) diff --git a/backend/cn/lib/core_to_mucore.ml b/backend/cn/lib/core_to_mucore.ml index 17ffcce7f..312d644f9 100644 --- a/backend/cn/lib/core_to_mucore.ml +++ b/backend/cn/lib/core_to_mucore.ml @@ -8,11 +8,8 @@ module Ctype = CF.Ctype module BT = BaseTypes module C = Compile module IT = IndexTerms -module IdMap = Map.Make (Id) module SBT = BaseTypes.Surface module Mu = Mucore -module SymMap = Map.Make (Sym) -module SymSet = Set.Make (Sym) (* Short forms *) module Desugar = struct @@ -32,9 +29,9 @@ let get_loc_ = CF.Annot.get_loc_ open CF.Core open Pp -open Effectful.Make (Resultat) +open Effectful.Make (Or_TypeError) -let fail = Resultat.fail +let fail = Or_TypeError.fail let do_ail_desugar_op desugar_state f = match f desugar_state with @@ -235,7 +232,7 @@ let rec n_pexpr ~inherit_loc loc (Pexpr (annots, bty, pe)) : unit Mucore.pexpr = | PEmemop (_mop, _pes) -> (* FIXME(CHERI merge) *) (* this construct is currently only used by the CHERI switch *) - assert_error loc !^"PEmemop" + assert_error loc !^"PEmemop (CHERI only)" | PEnot e' -> let e' = n_pexpr loc e' in annotate (PEnot e') @@ -628,9 +625,12 @@ let n_memop ~inherit_loc loc memop pexprs = let pe1 = n_pexpr loc pe1 in let pe2 = n_pexpr loc pe2 in CopyAllocId (pe1, pe2) + | PtrMemberShift _, _ -> assert_error loc !^"PtrMemberShift (CHERI only)" | memop, pexprs1 -> let err = - !^(show_n_memop memop) + !^__LOC__ + ^^ colon + ^^^ !^(show_n_memop memop) ^^^ !^"applied to" ^^^ int (List.length pexprs1) ^^^ !^"arguments" @@ -646,7 +646,7 @@ let rec n_expr ((env, old_states), desugaring_things) (global_types, visible_objects_env) e - : unit Mucore.expr Resultat.m + : unit Mucore.expr Or_TypeError.t = let markers_env, cn_desugaring_state = desugaring_things in let (Expr (annots, pe)) = e in @@ -848,9 +848,7 @@ let rec n_expr | Eexcluded _ -> assert_error loc !^"core_anormalisation: Eexcluded" -module RT = ReturnTypes module AT = ArgumentTypes -module LRT = LogicalReturnTypes module LAT = LogicalArgumentTypes let rec lat_of_arguments f_i = function @@ -895,8 +893,10 @@ let make_largs f_i = ((name, (pt_ret, SBT.proj oa_bt)), (loc, None)) (Mu.mConstraints lcs lat)) | Cn.CN_cletExpr (loc, name, expr) :: conditions -> - let@ expr = C.LocalState.handle st (C.ET.translate_cn_expr SymSet.empty env expr) in - let@ lat = aux (C.add_logical name (IT.bt expr) env) st conditions in + let@ expr = + C.LocalState.handle st (C.ET.translate_cn_expr Sym.Set.empty env expr) + in + let@ lat = aux (C.add_logical name (IT.get_bt expr) env) st conditions in return (Mu.mDefine ((name, IT.Surface.proj expr), (loc, None)) lat) | Cn.CN_cconstr (loc, constr) :: conditions -> let@ lc = C.LocalState.handle st (C.ET.translate_cn_assrt env (loc, constr)) in @@ -927,8 +927,9 @@ let rec make_largs_with_accesses f_i env st (accesses, conditions) = let is_pass_by_pointer = function By_pointer -> true | By_value -> false -let check_against_core_bt loc = - CoreTypeChecks.check_against_core_bt (fun msg -> fail { loc; msg = Generic msg }) +let check_against_core_bt loc cbt bt = + CoreTypeChecks.check_against_core_bt cbt bt + |> Result.map_error (fun msg -> TypeErrors.{ loc; msg = Generic msg }) let make_label_args f_i loc env st args (accesses, inv) = @@ -943,8 +944,8 @@ let make_label_args f_i loc env st args (accesses, inv) = let env = C.add_computational s p_sbt env in (* let good_pointer_lc = *) (* let info = (loc, Some (Sym.pp_string s ^ " good")) in *) - (* let here = Locations.other __FUNCTION__ in *) - (* (LC.t_ (IT.good_ (Pointer sct, IT.sym_ (s, BT.Loc, here)) here), info) *) + (* let here = Locations.other __LOC__ in *) + (* (LC.T (IT.good_ (Pointer sct, IT.sym_ (s, BT.Loc, here)) here), info) *) (* in *) let@ oa_name, ((pt_ret, oa_bt), lcs), value = C.ownership (loc, (s, ct)) env in let env = C.add_logical oa_name oa_bt env in @@ -980,8 +981,8 @@ let make_function_args f_i loc env args (accesses, requires) = let st = C.LocalState.add_c_variable_state mut_arg arg_state st in (* let good_lc = *) (* let info = (loc, Some (Sym.pp_string pure_arg ^ " good")) in *) - (* let here = Locations.other __FUNCTION__ in *) - (* (LC.t_ (IT.good_ (ct, IT.sym_ (pure_arg, bt, here)) here), info) *) + (* let here = Locations.other __LOC__ in *) + (* (LC.T (IT.good_ (ct, IT.sym_ (pure_arg, bt, here)) here), info) *) (* in *) let@ at = aux (arg_states @ [ (mut_arg, arg_state) ]) (* good_lc :: *) good_lcs env st rest @@ -1019,8 +1020,8 @@ let make_fun_with_spec_args f_i loc env args requires = let env = C.add_computational pure_arg sbt env in (* let good_lc = *) (* let info = (loc, Some (Sym.pp_string pure_arg ^ " good")) in *) - (* let here = Locations.other __FUNCTION__ in *) - (* (LC.t_ (IT.good_ (ct, IT.sym_ (pure_arg, bt, here)) here), info) *) + (* let here = Locations.other __LOC__ in *) + (* (LC.T (IT.good_ (ct, IT.sym_ (pure_arg, bt, here)) here), info) *) (* in *) let@ at = aux (* good_lc :: *) good_lcs env st rest in return (Mu.mComputational ((pure_arg, bt), (loc, None)) at) @@ -1128,7 +1129,7 @@ let normalise_label fsym (markers_env, precondition_cn_desugaring_state) (global_types, visible_objects_env) - (accesses, loop_attributes) + (accesses, (loop_attributes : CF.Annot.loop_attributes)) (env : C.env) st _label_name @@ -1139,9 +1140,9 @@ let normalise_label | Mi_Label (loc, lt, label_args, label_body, annots) -> (match CF.Annot.get_label_annot annots with | Some (LAloop loop_id) -> - let@ desugared_inv, cn_desugaring_state = + let@ desugared_inv, cn_desugaring_state, loop_condition_loc = match Pmap.lookup loop_id loop_attributes with - | Some (marker_id, attrs) -> + | Some { marker_id; attributes = attrs; loc_condition; loc_loop } -> let@ inv = Parse.loop_spec attrs in let d_st = CAE. @@ -1153,8 +1154,9 @@ let normalise_label } in let@ inv, d_st = desugar_conds d_st inv in - return (inv, d_st.inner.cn_state) - | None -> return ([], precondition_cn_desugaring_state) + return (inv, d_st.inner.cn_state, (loc_condition, loc_loop)) + | None -> assert false + (* return ([], precondition_cn_desugaring_state) *) in debug 6 (lazy (!^"invariant in function" ^^^ Sym.pp fsym)); debug 6 (lazy (CF.Pp_ast.pp_doc_tree (dtree_of_inv desugared_inv))); @@ -1179,7 +1181,12 @@ let normalise_label (* ) label_args_and_body *) (* in *) return - (Mu.Label (loc, label_args_and_body, annots, { label_spec = desugared_inv })) + (Mu.Label + ( loc, + label_args_and_body, + annots, + { label_spec = desugared_inv }, + `Loop loop_condition_loc )) (* | Some (LAloop_body _loop_id) -> *) (* assert_error loc !^"body label has not been inlined" *) | Some (LAloop_continue _loop_id) -> @@ -1257,11 +1264,12 @@ let normalise_fun_map_decl let@ accesses = ListM.mapM (desugar_access d_st global_types) accesses in let@ requires, d_st = desugar_conds d_st (List.map snd requires) in debug 6 (lazy (string "desugared requires conds")); - let@ ret_s, ret_d_st = register_new_cn_local (Id.id "return") d_st in + let here = Locations.other __LOC__ in + let@ ret_s, ret_d_st = register_new_cn_local (Id.make here "return") d_st in let@ ensures, _ret_d_st = desugar_conds ret_d_st (List.map snd ensures) in debug 6 (lazy (string "desugared ensures conds")); let@ spec_req, spec_ens, env = - match SymMap.find_opt fname fun_specs with + match Sym.Map.find_opt fname fun_specs with | Some (_, spec) -> let@ () = match defn_spec_sites with @@ -1339,7 +1347,7 @@ let normalise_fun_map_decl return (Some (Mu.Proc { loc; args_and_body; trusted; desugared_spec }, mk_functions)) | Mi_ProcDecl (loc, ret_bt, _bts) -> - (match SymMap.find_opt fname fun_specs with + (match Sym.Map.find_opt fname fun_specs with | Some (_ail_marker, (spec : (CF.Symbol.sym, Ctype.ctype) Cn.cn_fun_spec)) -> let@ () = check_against_core_bt loc ret_bt (Memory.bt_of_sct (convert_ct loc ret_ct)) @@ -1419,7 +1427,7 @@ let normalise_fun_map let normalise_globs ~inherit_loc env _sym g = - let loc = Locations.other __FUNCTION__ in + let loc = Locations.other __LOC__ in match g with | GlobalDef ((bt, ct), e) -> let@ () = check_against_core_bt loc bt BT.(Loc ()) in @@ -1545,9 +1553,9 @@ let normalise_file ~inherit_loc ((fin_markers_env : CAE.fin_markers_env), ail_pr let env = List.fold_left register_glob env globs in let fun_specs_map = List.fold_right - (fun (id, spec) acc -> SymMap.add spec.Cn.cn_spec_name (id, spec) acc) + (fun (id, spec) acc -> Sym.Map.add spec.Cn.cn_spec_name (id, spec) acc) ail_prog.cn_fun_specs - SymMap.empty + Sym.Map.empty in let@ funs, mk_functions = normalise_fun_map @@ -1571,7 +1579,7 @@ let normalise_file ~inherit_loc ((fin_markers_env : CAE.fin_markers_env), ail_pr }) file.mi_funinfo in - let stdlib_syms = SymSet.of_list (List.map fst (Pmap.bindings_list file.mi_stdlib)) in + let stdlib_syms = Sym.Set.of_list (List.map fst (Pmap.bindings_list file.mi_stdlib)) in let datatypes = List.map (translate_datatype env) ail_prog.cn_datatypes in let file = Mu. @@ -1591,137 +1599,3 @@ let normalise_file ~inherit_loc ((fin_markers_env : CAE.fin_markers_env), ail_pr in debug 3 (lazy (headline "done core_to_mucore normalising file")); return file - - -(* type internal = { pre: unit arguments; post: ReturnTypes.t; inv: (Loc.t * unit - arguments); statements: (Locations.t * Cnprog.cn_prog list) list; } *) - -type statements = (Locations.t * Cnprog.t list) list - -type fn_spec_instrumentation = (ReturnTypes.t * statements) ArgumentTypes.t - -type instrumentation = - { fn : Sym.t; - fn_loc : Locations.t; - internal : fn_spec_instrumentation option - } - -let rt_stmts_subst subst (rt, stmts) = - let rt = ReturnTypes.subst subst rt in - let stmts = - List.map (fun (loc, cn_progs) -> (loc, List.map (Cnprog.subst subst) cn_progs)) stmts - in - (rt, stmts) - - -let fn_spec_instrumentation_subst_at - : _ Subst.t -> fn_spec_instrumentation -> fn_spec_instrumentation - = - ArgumentTypes.subst rt_stmts_subst - - -let fn_spec_instrumentation_subst_lat - : _ Subst.t -> (ReturnTypes.t * statements) LogicalArgumentTypes.t -> - (ReturnTypes.t * statements) LogicalArgumentTypes.t - = - LogicalArgumentTypes.subst rt_stmts_subst - - -(* substitute `s_with` for `s_replace` of basetype `bt` *) -let fn_spec_instrumentation_sym_subst_at (s_replace, bt, s_with) fn_spec = - let subst = - IT.make_subst [ (s_replace, IT.sym_ (s_with, bt, Cerb_location.unknown)) ] - in - fn_spec_instrumentation_subst_at subst fn_spec - - -let fn_spec_instrumentation_sym_subst_lat (s_replace, bt, s_with) fn_spec = - let subst = - IT.make_subst [ (s_replace, IT.sym_ (s_with, bt, Cerb_location.unknown)) ] - in - fn_spec_instrumentation_subst_lat subst fn_spec - - -let fn_spec_instrumentation_sym_subst_lrt (s_replace, bt, s_with) fn_spec = - let subst = - IT.make_subst [ (s_replace, IT.sym_ (s_with, bt, Cerb_location.unknown)) ] - in - LRT.subst subst fn_spec - - -let concat2 (x : 'a list * 'b list) (y : 'a list * 'b list) : 'a list * 'b list = - let a1, b1 = x in - let a2, b2 = y in - (a1 @ a2, b1 @ b2) - - -let concat2_map (f : 'a -> 'b list * 'c list) (xs : 'a list) : 'b list * 'c list = - List.fold_right (fun x acc -> concat2 (f x) acc) xs ([], []) - - -let rec stmts_in_expr (Mu.Expr (loc, _, _, e_)) = - match e_ with - | Epure _ -> ([], []) - | Ememop _ -> ([], []) - | Eaction _ -> ([], []) - | Eskip -> ([], []) - | Eccall _ -> ([], []) - | Elet (_, _, e) -> stmts_in_expr e - | Eunseq es -> concat2_map stmts_in_expr es - | Ewseq (_, e1, e2) -> concat2 (stmts_in_expr e1) (stmts_in_expr e2) - | Esseq (_, e1, e2) -> concat2 (stmts_in_expr e1) (stmts_in_expr e2) - | Eif (_, e1, e2) -> concat2 (stmts_in_expr e1) (stmts_in_expr e2) - | Ebound e -> stmts_in_expr e - | End es -> concat2_map stmts_in_expr es - | Erun _ -> ([], []) - | CN_progs (stmts_s, stmts_i) -> ([ (loc, stmts_s) ], [ (loc, stmts_i) ]) - - -let rec stmts_in_largs f_i = function - | Mu.Define (_, _, a) -> stmts_in_largs f_i a - | Resource (_, _, a) -> stmts_in_largs f_i a - | Constraint (_, _, a) -> stmts_in_largs f_i a - | I i -> f_i i - - -let rec stmts_in_args f_i = function - | Mu.Computational (_, _, a) -> stmts_in_args f_i a - | L a -> stmts_in_largs f_i a - - -let stmts_in_labels labels = - Pmap.fold - (fun _s def acc -> - match def with - | Mu.Return _ -> acc - | Label (_, a, _, _) -> concat2 (stmts_in_args stmts_in_expr a) acc) - labels - ([], []) - - -(* - * let stmts_in_function args_and_body = - * stmts_in_args - * (fun (body, labels, _rt) -> concat2 (stmts_in_expr body) (stmts_in_labels labels)) - * args_and_body - *) - -let collect_instrumentation (file : _ Mu.file) = - let instrs = - List.map - (fun (fn, decl) -> - match decl with - | Mu.Proc { loc = fn_loc; args_and_body; _ } -> - let args_and_body = at_of_arguments Fun.id args_and_body in - let internal = - ArgumentTypes.map - (fun (body, labels, rt) -> - let _, stmts = concat2 (stmts_in_expr body) (stmts_in_labels labels) in - (rt, stmts)) - args_and_body - in - { fn; fn_loc; internal = Some internal } - | ProcDecl (fn_loc, _fn) -> { fn; fn_loc; internal = None }) - (Pmap.bindings_list file.funs) - in - (instrs, C.symtable) diff --git a/backend/cn/lib/core_to_mucore.mli b/backend/cn/lib/core_to_mucore.mli index a867d7d43..606e4d0db 100644 --- a/backend/cn/lib/core_to_mucore.mli +++ b/backend/cn/lib/core_to_mucore.mli @@ -5,36 +5,8 @@ val normalise_file : inherit_loc:bool -> Cerb_frontend.Cabs_to_ail_effect.fin_markers_env * 'a Cerb_frontend.AilSyntax.sigma -> ('b, unit) Cerb_frontend.Milicore.mi_file -> - unit Mucore.file Resultat.m - -(* TODO(RB) - Do these belong here? Looks like they can/should be factored out *) -type statements = (Locations.t * Cnprog.t list) list - -type fn_spec_instrumentation = (ReturnTypes.t * statements) ArgumentTypes.t + unit Mucore.file Or_TypeError.t val arguments_of_at : ('a -> 'b) -> 'a ArgumentTypes.t -> 'b Mucore.arguments -val fn_spec_instrumentation_sym_subst_lrt - : Sym.t * BaseTypes.t * Sym.t -> - LogicalReturnTypes.t -> - LogicalReturnTypes.t - -val fn_spec_instrumentation_sym_subst_lat - : Sym.t * BaseTypes.t * Sym.t -> - (ReturnTypes.t * statements) LogicalArgumentTypes.t -> - (ReturnTypes.t * statements) LogicalArgumentTypes.t - -val fn_spec_instrumentation_sym_subst_at - : Sym.t * BaseTypes.t * Sym.t -> - fn_spec_instrumentation -> - fn_spec_instrumentation - -type instrumentation = - { fn : Sym.t; - fn_loc : Locations.t; - internal : fn_spec_instrumentation option - } - -val collect_instrumentation - : 'a Mucore.file -> - instrumentation list * BaseTypes.Surface.t Hashtbl.Make(Sym).t +val at_of_arguments : ('b -> 'a) -> 'b Mucore.arguments -> 'a ArgumentTypes.t diff --git a/backend/cn/lib/definition.ml b/backend/cn/lib/definition.ml new file mode 100644 index 000000000..3da6d997f --- /dev/null +++ b/backend/cn/lib/definition.ml @@ -0,0 +1,199 @@ +module IT = IndexTerms +module LAT = LogicalArgumentTypes + +module Function = struct + type body = + | Def of IT.t + | Rec_Def of IT.t + | Uninterp + + let subst_body subst = function + | Def it -> Def (IT.subst subst it) + | Rec_Def it -> Rec_Def (IT.subst subst it) + | Uninterp -> Uninterp + + + type t = + { loc : Locations.t; + args : (Sym.t * BaseTypes.t) list; + (* If the predicate is supposed to get used in a quantified form, one of the arguments + has to be the index/quantified variable. For now at least. *) + return_bt : BaseTypes.t; + emit_coq : bool; + body : body + } + + let is_recursive def = + match def.body with Rec_Def _ -> true | Def _ -> false | Uninterp -> false + + + let given_to_solver def = + match def.body with Rec_Def _ -> false | Def _ -> true | Uninterp -> false + + + let pp_args xs = + let doc = + Pp.flow_map + (Pp.break 1) + (fun (sym, typ) -> Pp.parens (Pp.typ (Sym.pp sym) (BaseTypes.pp typ))) + xs + in + if PPrint.requirement doc = 0 then + Pp.parens Pp.empty + else + doc + + + let pp_sig nm def = + let open Pp in + nm ^^ pp_args def.args ^^^ colon ^^^ BaseTypes.pp def.return_bt + + + let pp nm def = + let open Pp in + pp_sig nm def + ^^^ equals + ^/^ + match def.body with + | Uninterp -> !^"uninterpreted" + | Def t -> IT.pp t + | Rec_Def t -> !^"rec:" ^^^ IT.pp t + + + let open_ def_args def_body args = + let su = IT.make_subst (List.map2 (fun (s, _) arg -> (s, arg)) def_args args) in + IT.subst su def_body + + + let unroll_once def args = + match def.body with + | Def body | Rec_Def body -> Some (open_ def.args body args) + | Uninterp -> None + + + let try_open def args = + match def.body with + | Def body -> Some (open_ def.args body args) + | Rec_Def _ -> None + | Uninterp -> None + + + (*Extensibility hook. For now, all functions are displayed as "interesting" in error reporting*) + let is_interesting : t -> bool = fun _ -> true +end + +module Clause = struct + type t = + { loc : Locations.t; + guard : IT.t; + packing_ft : LAT.packing_ft + } + + let pp { loc = _; guard; packing_ft } = + let open Pp in + item "condition" (IT.pp guard) + ^^ comma + ^^^ item "return type" (LAT.pp IT.pp packing_ft) + + + let subst subst { loc; guard; packing_ft } = + { loc; + guard = IT.subst subst guard; + packing_ft = LAT.subst IT.subst subst packing_ft + } + + + let lrt (pred_oarg : IT.t) clause_packing_ft = + let module LRT = LogicalReturnTypes in + let rec aux = function + | LAT.Define (bound, info, lat) -> LRT.Define (bound, info, aux lat) + | LAT.Resource (bound, info, lat) -> LRT.Resource (bound, info, aux lat) + | LAT.Constraint (lc, info, lat) -> LRT.Constraint (lc, info, aux lat) + | I output -> + let loc = Locations.other __LOC__ in + let lc = LogicalConstraints.T (IT.eq_ (pred_oarg, output) loc) in + LRT.Constraint (lc, (loc, None), LRT.I) + in + aux clause_packing_ft +end + +module Predicate = struct + type t = + { loc : Locations.t; + pointer : Sym.t; + iargs : (Sym.t * BaseTypes.t) list; + oarg_bt : BaseTypes.t; + clauses : Clause.t list option + } + + let pp def = + let open Pp in + item "pointer" (Sym.pp def.pointer) + ^/^ item "iargs" (Pp.list (fun (s, _) -> Sym.pp s) def.iargs) + ^/^ item "oarg_bt" (BaseTypes.pp def.oarg_bt) + ^/^ item + "clauses" + (match def.clauses with + | Some clauses -> Pp.list Clause.pp clauses + | None -> !^"(uninterpreted)") + + + let instantiate (def : t) ptr_arg iargs = + match def.clauses with + | Some clauses -> + let subst = + IT.make_subst + ((def.pointer, ptr_arg) + :: List.map2 (fun (def_ia, _) ia -> (def_ia, ia)) def.iargs iargs) + in + Some (List.map (Clause.subst subst) clauses) + | None -> None + + + let identify_right_clause provable (def : t) pointer iargs = + match instantiate def pointer iargs with + | None -> + (* "uninterpreted" predicates cannot be un/packed *) + None + | Some clauses -> + let rec try_clauses : Clause.t list -> _ = function + | [] -> None + | clause :: clauses -> + (match provable (LogicalConstraints.T clause.guard) with + | `True -> Some clause + | `False -> + let loc = Locations.other __LOC__ in + (match provable (LogicalConstraints.T (IT.not_ clause.guard loc)) with + | `True -> try_clauses clauses + | `False -> + Pp.debug + 5 + (lazy + (Pp.item "cannot prove or disprove clause guard" (IT.pp clause.guard))); + None)) + in + try_clauses clauses + + + (* determines if a resource predicate will be given to the solver + * TODO: right now this is an overapproximation *) + let given_to_solver (def : t) = + match def.clauses with + | None -> false + | Some [] -> true + | Some [ _ ] -> true + | _ -> false +end + +let alloc = + Predicate. + { loc = Locations.other __LOC__; + pointer = Sym.fresh_named "ptr"; + iargs = []; + oarg_bt = Alloc.History.value_bt; + clauses = None + } + + +(*Extensibility hook. For now, all predicates are displayed as "interesting" in error reporting*) +let is_interesting : Predicate.t -> bool = fun _ -> true diff --git a/backend/cn/lib/definition.mli b/backend/cn/lib/definition.mli new file mode 100644 index 000000000..e2f0f0bd4 --- /dev/null +++ b/backend/cn/lib/definition.mli @@ -0,0 +1,75 @@ +module Function : sig + type body = + | Def of IndexTerms.t + | Rec_Def of IndexTerms.t + | Uninterp + + val subst_body : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> body -> body + + type t = + { loc : Locations.t; + args : (Sym.t * BaseTypes.t) list; + return_bt : BaseTypes.t; + emit_coq : bool; + body : body + } + + val is_recursive : t -> bool + + val given_to_solver : t -> bool + + val pp_args : (Cerb_frontend.Symbol.sym * unit BaseTypes.t_gen) list -> Pp.document + + val pp_sig : Pp.document -> t -> Pp.document + + val pp : Pp.document -> t -> Pp.document + + val open_ : (Sym.t * 'a) list -> IndexTerms.t -> IndexTerms.t list -> IndexTerms.t + + val unroll_once : t -> IndexTerms.t list -> IndexTerms.t option + + val try_open : t -> IndexTerms.t list -> IndexTerms.t option + + val is_interesting : t -> bool +end + +module Clause : sig + type t = + { loc : Locations.t; + guard : IndexTerms.t; + packing_ft : LogicalArgumentTypes.packing_ft + } + + val pp : t -> Pp.document + + val subst : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> t -> t + + val lrt : IndexTerms.t -> IndexTerms.t LogicalArgumentTypes.t -> LogicalReturnTypes.t +end + +module Predicate : sig + type t = + { loc : Locations.t; + pointer : Sym.t; + iargs : (Sym.t * BaseTypes.t) list; + oarg_bt : BaseTypes.t; + clauses : Clause.t list option + } + + val pp : t -> Pp.document + + val instantiate : t -> IndexTerms.t -> IndexTerms.t list -> Clause.t list option + + val identify_right_clause + : (LogicalConstraints.t -> [< `False | `True ]) -> + t -> + IndexTerms.t -> + IndexTerms.t list -> + Clause.t option + + val given_to_solver : t -> bool +end + +val alloc : Predicate.t + +val is_interesting : Predicate.t -> bool diff --git a/backend/cn/lib/diagnostics.ml b/backend/cn/lib/diagnostics.ml index 735e2e39f..1c7edc76c 100644 --- a/backend/cn/lib/diagnostics.ml +++ b/backend/cn/lib/diagnostics.ml @@ -1,6 +1,5 @@ open Typing module LC = LogicalConstraints -module LCSet = Set.Make (LC) module IT = IndexTerms open Effectful.Make (Typing) @@ -48,14 +47,13 @@ let continue_with (opts : opt list) cfg = let term_with_model_name nm cfg x = - let@ g = get_global () in let open Pp in - match Solver.eval g (fst cfg.model) x with + match Solver.eval (fst cfg.model) x with | None -> return (bold nm ^^ colon ^^^ parens (string "cannot eval") ^^ colon ^^^ IT.pp x) | Some r -> if IT.is_true r || IT.is_false r then ( - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ p = provable here in let info = match p (LC.T (IT.eq_ (x, r) here)) with @@ -68,13 +66,13 @@ let term_with_model_name nm cfg x = let bool_subterms1 t = - match IT.term t with + match IT.get_term t with | IT.Binop (And, it, it') -> [ it; it' ] | IT.Binop (Or, it, it') -> [ it; it' ] | IT.Binop (Implies, x, y) -> [ x; y ] | IT.Unop (Not, x) -> [ x ] | IT.Binop (EQ, x, y) -> - if BT.equal (IT.bt x) BT.Bool then + if BT.equal (IT.get_bt x) BT.Bool then [ x; y ] else [] @@ -88,25 +86,26 @@ let rec bool_subterms_of t = let constraint_ts () = let@ cs = get_cs () in let ts = - List.filter_map (function LC.T t -> Some t | _ -> None) (LCSet.elements cs) + List.filter_map (function LC.T t -> Some t | _ -> None) (LC.Set.elements cs) in return ts let same_pred nm t = - match IT.term t with IT.Apply (nm2, _) -> Sym.equal nm nm2 | _ -> false + match IT.get_term t with IT.Apply (nm2, _) -> Sym.equal nm nm2 | _ -> false -let pred_args t = match IT.term t with IT.Apply (_, args) -> args | _ -> [] +let pred_args t = match IT.get_term t with IT.Apply (_, args) -> args | _ -> [] let split_eq x y = - match (IT.term x, IT.term y) with + match (IT.get_term x, IT.get_term y) with | IT.MapGet (m1, x1), IT.MapGet (m2, x2) -> Some [ (m1, m2); (x1, x2) ] | IT.Apply (nm, xs), IT.Apply (nm2, ys) when Sym.equal nm nm2 -> Some (List.map2 (fun x y -> (x, y)) xs ys) | IT.Constructor (nm, xs), IT.Constructor (nm2, ys) when Sym.equal nm nm2 -> - let xs = List.sort WellTyped.compare_by_fst_id xs in - let ys = List.sort WellTyped.compare_by_fst_id ys in + let compare_fst_id (x, _) (y, _) = Id.compare x y in + let xs = List.sort compare_fst_id xs in + let ys = List.sort compare_fst_id ys in Some (List.map2 (fun (_, x) (_, y) -> (x, y)) xs ys) | _ -> None @@ -142,13 +141,13 @@ let rec investigate_term cfg t = match split_eq x y with | None -> return [] | Some bits -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in ListM.mapM (fun (x, y) -> rec_opt "parametric eq" (IT.eq_ (x, y) here)) bits in return (List.concat trans_opts @ [ get_eq_opt ] @ split_opts) in let@ pred_opts = - match IT.term t with + match IT.get_term t with | IT.Apply (nm, _xs) -> investigate_pred cfg nm t | _ -> return [] in @@ -186,7 +185,7 @@ and investigate_eq_side _cfg (side_nm, t, t2) = { doc = IT.pp t; continue = (fun cfg -> - let eq = IT.eq_ (t, t2) @@ Locations.other __FUNCTION__ in + let eq = IT.eq_ (t, t2) @@ Locations.other __LOC__ in print stdout (bold "investigating eq:" ^^^ IT.pp eq); investigate_term cfg eq) }) @@ -209,7 +208,8 @@ and investigate_trans_eq t cfg = (fun _ acc t -> match IT.is_eq t with | None -> acc - | Some (x, y) -> if BT.equal (IT.bt x) (IT.bt t) then [ x; y ] @ acc else acc) + | Some (x, y) -> + if BT.equal (IT.get_bt x) (IT.get_bt t) then [ x; y ] @ acc else acc) [] [] cs @@ -221,7 +221,7 @@ and investigate_trans_eq t cfg = |> ITSet.elements in let opt_of x = - let eq = IT.eq_ (t, x) @@ Locations.other __FUNCTION__ in + let eq = IT.eq_ (t, x) @@ Locations.other __LOC__ in let@ doc = term_with_model_name "eq to constraint elem" cfg eq in return { doc; continue = (fun cfg -> investigate_term cfg eq) } in @@ -238,7 +238,7 @@ and get_eqs_then_investigate cfg x y = let x_set = IT.fold_list (fun _ acc t -> - if BT.equal (IT.bt t) (IT.bt x) then + if BT.equal (IT.get_bt t) (IT.get_bt x) then ITSet.add t acc else acc) @@ -247,10 +247,10 @@ and get_eqs_then_investigate cfg x y = cs in let opt_xs = ITSet.elements x_set in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ () = test_value_eqs here None x opt_xs in let@ () = test_value_eqs here None y opt_xs in - investigate_term cfg (IT.eq_ (x, y) @@ Locations.other __FUNCTION__) + investigate_term cfg (IT.eq_ (x, y) @@ Locations.other __LOC__) and investigate_pred cfg nm t = @@ -271,8 +271,7 @@ and investigate_pred cfg nm t = return { doc; continue = - (fun cfg -> - investigate_term cfg (IT.eq_ (t, p) @@ Locations.other __FUNCTION__)) + (fun cfg -> investigate_term cfg (IT.eq_ (t, p) @@ Locations.other __LOC__)) } in ListM.mapM pred_opt ps @@ -281,7 +280,7 @@ and investigate_pred cfg nm t = and investigate_ite cfg t = let ites = IT.fold - (fun _ acc t -> match IT.term t with ITE (x, _y, _z) -> x :: acc | _ -> acc) + (fun _ acc t -> match IT.get_term t with ITE (x, _y, _z) -> x :: acc | _ -> acc) [] [] t @@ -300,7 +299,7 @@ and investigate_ite cfg t = continue = (fun cfg -> let open Pp in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let t' = simp x (IT.bool_ b here) t in print stdout (bold "rewrote to:" ^^^ IT.pp t'); print diff --git a/backend/cn/lib/dune b/backend/cn/lib/dune index d84bd0072..93d190369 100644 --- a/backend/cn/lib/dune +++ b/backend/cn/lib/dune @@ -4,7 +4,7 @@ (name cn) (public_name cn) (flags - (:standard -w -37 -open Monomorphic.Int)) + (:standard -w @60 -open Monomorphic.Int)) (libraries cerb_backend cerb_frontend @@ -13,13 +13,16 @@ menhirLib monomorphic ocamlgraph + ppx_deriving_yojson.runtime result str - unix) + unix + yojson) (preprocess (pps ppx_deriving.eq ppx_deriving.fold ppx_deriving.map ppx_deriving.ord - ppx_deriving.show))) + ppx_deriving.show + ppx_deriving_yojson))) diff --git a/backend/cn/lib/effectful.ml b/backend/cn/lib/effectful.ml index 36b76db48..bc2233220 100644 --- a/backend/cn/lib/effectful.ml +++ b/backend/cn/lib/effectful.ml @@ -1,9 +1,9 @@ module type S = sig - type 'a m + type 'a t - val return : 'a -> 'a m + val return : 'a -> 'a t - val bind : 'a m -> ('a -> 'b m) -> 'b m + val bind : 'a t -> ('a -> 'b t) -> 'b t end module Make (T : S) = struct @@ -12,9 +12,7 @@ module Make (T : S) = struct let ( let@ ) = T.bind module ListM = struct - open List - - let rec mapM (f : 'a -> 'b m) (l : 'a list) : 'b list m = + let rec mapM (f : 'a -> 'b t) (l : 'a list) : 'b list t = match l with | [] -> return [] | x :: xs -> @@ -23,7 +21,7 @@ module Make (T : S) = struct return (y :: ys) - let mapfstM (f : 'a -> 'c m) (l : ('a * 'b) list) : ('c * 'b) list m = + let mapfstM (f : 'a -> 'c t) (l : ('a * 'b) list) : ('c * 'b) list t = mapM (fun (a, b) -> let@ c = f a in @@ -31,7 +29,7 @@ module Make (T : S) = struct l - let mapsndM (f : 'b -> 'c m) (l : ('a * 'b) list) : ('a * 'c) list m = + let mapsndM (f : 'b -> 'c t) (l : ('a * 'b) list) : ('a * 'c) list t = mapM (fun (a, b) -> let@ c = f b in @@ -39,7 +37,7 @@ module Make (T : S) = struct l - let mapiM (f : int -> 'a -> 'b m) (l : 'a list) : 'b list m = + let mapiM (f : int -> 'a -> 'b t) (l : 'a list) : 'b list t = let rec aux i l = match l with | [] -> return [] @@ -51,26 +49,26 @@ module Make (T : S) = struct aux 0 l - let map2M (f : 'a -> 'b -> 'c m) (l1 : 'a list) (l2 : 'b list) : 'c list m = + let map2M (f : 'a -> 'b -> 'c t) (l1 : 'a list) (l2 : 'b list) : 'c list t = let l12 = List.combine l1 l2 in mapM (Tools.uncurry f) l12 - let iteriM (f : int -> 'a -> unit m) (l : 'a list) : unit m = + let iteriM (f : int -> 'a -> unit t) (l : 'a list) : unit t = let@ _ = mapiM f l in return () - let iterM (f : 'a -> unit m) (l : 'a list) : unit m = iteriM (fun _ -> f) l + let iterM (f : 'a -> unit t) (l : 'a list) : unit t = iteriM (fun _ -> f) l let concat_mapM f l = let@ xs = mapM f l in - return (concat xs) + return (List.concat xs) let filter_mapM f l = let@ xs = mapM f l in - return (filter_map (fun x -> x) xs) + return (List.filter_map (fun x -> x) xs) let filterM f xs = @@ -84,8 +82,8 @@ module Make (T : S) = struct return (List.map snd (List.filter fst ys)) - let fold_leftM (f : 'a -> 'b -> 'c m) (a : 'a) (bs : 'b list) = - Stdlib.List.fold_left + let fold_leftM (f : 'a -> 'b -> 'c t) (a : 'a) (bs : 'b list) = + List.fold_left (fun aM b -> let@ a = aM in f a b) @@ -93,9 +91,8 @@ module Make (T : S) = struct bs - (* maybe from Exception.lem *) - let fold_rightM (f : 'b -> 'a -> 'c m) (bs : 'b list) (a : 'a) = - Stdlib.List.fold_right + let fold_rightM (f : 'b -> 'a -> 'c t) (bs : 'b list) (a : 'a) = + List.fold_right (fun b aM -> let@ a = aM in f b a) @@ -104,7 +101,7 @@ module Make (T : S) = struct end module PmapM = struct - let foldM (f : 'k -> 'x -> 'y -> 'y m) (map : ('k, 'x) Pmap.map) (init : 'y) : 'y m = + let foldM (f : 'k -> 'x -> 'y -> 'y t) (map : ('k, 'x) Pmap.map) (init : 'y) : 'y t = Pmap.fold (fun k v aM -> let@ a = aM in @@ -113,8 +110,8 @@ module Make (T : S) = struct (return init) - let foldiM (f : int -> 'k -> 'x -> 'y -> 'y m) (map : ('k, 'x) Pmap.map) (init : 'y) - : 'y m + let foldiM (f : int -> 'k -> 'x -> 'y -> 'y t) (map : ('k, 'x) Pmap.map) (init : 'y) + : 'y t = ListM.fold_leftM (fun y (i, (k, x)) -> f i k x y) @@ -131,8 +128,8 @@ module Make (T : S) = struct (return ()) - let mapM (f : 'k -> 'v -> 'w m) (m : ('k, 'v) Pmap.map) (cmp : 'k -> 'k -> int) - : ('k, 'w) Pmap.map m + let mapM (f : 'k -> 'v -> 'w t) (m : ('k, 'v) Pmap.map) (cmp : 'k -> 'k -> int) + : ('k, 'w) Pmap.map t = foldM (fun k v m -> diff --git a/backend/cn/lib/eqTable.ml b/backend/cn/lib/eqTable.ml index e2d0867d2..b5ded9acc 100644 --- a/backend/cn/lib/eqTable.ml +++ b/backend/cn/lib/eqTable.ml @@ -44,7 +44,7 @@ let add_eq_sym (guard, lhs, rhs) tab = let add_one_eq (tab : table) (it : IT.t) = - match IT.term it with + match IT.get_term it with | IT.Binop (IT.EQ, x, y) -> add_eq_sym (None, x, y) tab | Binop (Implies, guard, x) -> (match IT.is_eq x with Some (y, z) -> add_eq_sym (Some guard, y, z) tab | _ -> tab) diff --git a/backend/cn/lib/executable_spec.ml b/backend/cn/lib/executable_spec.ml index e98964401..9a0a7b37e 100644 --- a/backend/cn/lib/executable_spec.ml +++ b/backend/cn/lib/executable_spec.ml @@ -194,7 +194,7 @@ let output_to_oc oc str_list = List.iter (Stdlib.output_string oc) str_list open Executable_spec_internal let main - ?(with_ownership_checking = false) + ?(without_ownership_checking = false) ?(with_test_gen = false) ?(copy_source_dir = false) filename @@ -213,11 +213,13 @@ let main let oc = Stdlib.open_out (Filename.concat prefix output_filename) in let cn_oc = Stdlib.open_out (Filename.concat prefix "cn.c") in let cn_header_oc = Stdlib.open_out (Filename.concat prefix "cn.h") in - let instrumentation, symbol_table = Core_to_mucore.collect_instrumentation prog5 in + let instrumentation, symbol_table = + Executable_spec_extract.collect_instrumentation prog5 + in Executable_spec_records.populate_record_map instrumentation prog5; let executable_spec = generate_c_specs_internal - with_ownership_checking + without_ownership_checking instrumentation symbol_table statement_locs @@ -227,10 +229,10 @@ let main let c_datatype_defs, _c_datatype_decls, c_datatype_equality_fun_decls = generate_c_datatypes sigm in - let c_function_defs, c_function_decls, locs_and_c_extern_function_decls, c_records = + let c_function_defs, c_function_decls, locs_and_c_extern_function_decls, _c_records = generate_c_functions_internal sigm prog5.logical_predicates in - let c_predicate_defs, locs_and_c_predicate_decls, c_records' = + let c_predicate_defs, locs_and_c_predicate_decls, _c_records' = generate_c_predicates_internal sigm prog5.resource_predicates in let conversion_function_defs, conversion_function_decls = @@ -244,7 +246,7 @@ let main in let ownership_function_defs, ownership_function_decls = generate_ownership_functions - with_ownership_checking + without_ownership_checking Cn_internal_to_ail.ownership_ctypes sigm in @@ -252,31 +254,22 @@ let main let cn_converted_struct_defs, _cn_converted_struct_decls = generate_cn_versions_of_structs sigm.tag_definitions in - (* let (records_str, record_equality_fun_strs, record_equality_fun_prot_strs) = - generate_all_record_strs sigm in *) - let record_defs_str, _record_decls_str = c_records in - let record_defs_str', _record_decls_str = c_records' in let record_fun_defs, record_fun_decls = - Executable_spec_internal.generate_c_record_funs - sigm - prog5.logical_predicates - prog5.resource_predicates + Executable_spec_records.generate_c_record_funs sigm in - (* let extern_ownership_globals = if with_ownership_checking then "\n" ^ - generate_ownership_globals ~is_extern:true () else "" in *) let datatype_strs = String.concat "\n" (List.map snd c_datatype_defs) in let predicate_decls = String.concat "\n" (List.concat (List.map snd locs_and_c_predicate_decls)) in + let record_defs, _record_decls = Executable_spec_records.generate_all_record_strs () in let cn_header_decls_list = [ cn_utils_header; "\n"; + (if not (String.equal record_defs "") then "\n/* CN RECORDS */\n\n" else ""); + record_defs; c_struct_defs; cn_converted_struct_defs; - (if String.equal record_defs_str "" then "\n/* CN RECORDS */\n\n" else ""); - record_defs_str; - record_defs_str'; - (if String.equal datatype_strs "" then "\n/* CN DATATYPES */\n\n" else ""); + (if not (String.equal datatype_strs "") then "\n/* CN DATATYPES */\n\n" else ""); datatype_strs; "\n\n/* OWNERSHIP FUNCTIONS */\n\n"; ownership_function_decls; @@ -335,7 +328,7 @@ let main List.map (fun (loc, _) -> (loc, [ "" ])) toplevel_locs_and_defs in let accesses_stmt_injs = - if with_ownership_checking then memory_accesses_injections ail_prog else [] + if without_ownership_checking then [] else memory_accesses_injections ail_prog in let struct_injs_with_filenames = Executable_spec_internal.generate_struct_injs sigm in let struct_injs_with_filenames = @@ -381,12 +374,12 @@ let main failwith "Input file cannot have predefined main function when passing to CN test-gen \ tooling" - else if with_ownership_checking then ( + else if without_ownership_checking then + executable_spec.pre_post + else ( (* Inject ownership init function calls and mapping and unmapping of globals into provided main function *) let global_ownership_init_pair = generate_ownership_global_assignments sigm prog5 in global_ownership_init_pair @ executable_spec.pre_post) - else - executable_spec.pre_post in (match Source_injection.( diff --git a/backend/cn/lib/executable_spec_extract.ml b/backend/cn/lib/executable_spec_extract.ml new file mode 100644 index 000000000..2f904b3be --- /dev/null +++ b/backend/cn/lib/executable_spec_extract.ml @@ -0,0 +1,137 @@ +open Mucore + +type statement = Locations.t * Cnprog.t list + +let statement_subst subst ((loc, cnprogs) : statement) : statement = + (loc, List.map (Cnprog.subst subst) cnprogs) + + +type statements = statement list + +let statements_subst subst = List.map (statement_subst subst) + +type loop = Locations.t * statements ArgumentTypes.t + +let loop_subst subst ((loc, at) : loop) = + (loc, ArgumentTypes.subst statements_subst subst at) + + +type loops = loop list + +let loops_subst subst = List.map (loop_subst subst) + +type fn_body = statements * loops + +let fn_body_subst subst ((statements, loops) : fn_body) = + (statements_subst subst statements, loops_subst subst loops) + + +type fn_rt_and_body = ReturnTypes.t * fn_body + +let fn_rt_and_body_subst subst ((rt, fn_body) : fn_rt_and_body) = + (ReturnTypes.subst subst rt, fn_body_subst subst fn_body) + + +type fn_args_and_body = fn_rt_and_body ArgumentTypes.t + +let fn_args_and_body_subst subst (at : fn_args_and_body) : fn_args_and_body = + ArgumentTypes.subst fn_rt_and_body_subst subst at + + +type fn_largs_and_body = fn_rt_and_body LogicalArgumentTypes.t + +let fn_largs_and_body_subst subst (lat : fn_largs_and_body) : fn_largs_and_body = + LogicalArgumentTypes.subst fn_rt_and_body_subst subst lat + + +type instrumentation = + { fn : Sym.t; + fn_loc : Locations.t; + internal : fn_args_and_body option + } + +(* replace `s_replace` of basetype `bt` with `s_with` *) +let sym_subst (s_replace, bt, s_with) = + let module IT = IndexTerms in + IT.make_subst [ (s_replace, IT.sym_ (s_with, bt, Cerb_location.unknown)) ] + + +(* + let concat2 (x : 'a list * 'b list) (y : 'a list * 'b list) : 'a list * 'b list = + let a1, b1 = x in + let a2, b2 = y in + (a1 @ a2, b1 @ b2) + + +let concat2_map (f : 'a -> 'b list * 'c list) (xs : 'a list) : 'b list * 'c list = + List.fold_right (fun x acc -> concat2 (f x) acc) xs ([], []) + + +let rec stmts_in_expr (Mucore.Expr (loc, _, _, e_)) = + match e_ with + | Epure _ -> ([], []) + | Ememop _ -> ([], []) + | Eaction _ -> ([], []) + | Eskip -> ([], []) + | Eccall _ -> ([], []) + | Elet (_, _, e) -> stmts_in_expr e + | Eunseq es -> concat2_map stmts_in_expr es + | Ewseq (_, e1, e2) -> concat2 (stmts_in_expr e1) (stmts_in_expr e2) + | Esseq (_, e1, e2) -> concat2 (stmts_in_expr e1) (stmts_in_expr e2) + | Eif (_, e1, e2) -> concat2 (stmts_in_expr e1) (stmts_in_expr e2) + | Ebound e -> stmts_in_expr e + | End es -> concat2_map stmts_in_expr es + | Erun _ -> ([], []) + | CN_progs (stmts_s, stmts_i) -> ([ (loc, stmts_s) ], [ (loc, stmts_i) ]) +*) + +let rec stmts_in_expr (Mucore.Expr (loc, _, _, e_)) = + match e_ with + | Epure _ -> [] + | Ememop _ -> [] + | Eaction _ -> [] + | Eskip -> [] + | Eccall _ -> [] + | Elet (_, _, e) -> stmts_in_expr e + | Eunseq es -> List.concat_map stmts_in_expr es + | Ewseq (_, e1, e2) -> stmts_in_expr e1 @ stmts_in_expr e2 + | Esseq (_, e1, e2) -> stmts_in_expr e1 @ stmts_in_expr e2 + | Eif (_, e1, e2) -> stmts_in_expr e1 @ stmts_in_expr e2 + | Ebound e -> stmts_in_expr e + | End es -> List.concat_map stmts_in_expr es + | Erun _ -> [] + | CN_progs (_stmts_s, stmts_i) -> [ (loc, stmts_i) ] + + +let from_loop ((_label_sym : Sym.t), (label_def : _ label_def)) : loop option = + match label_def with + | Return _ -> None + | Label (_loc, label_args_and_body, _annots, _, `Loop (loop_condition_loc, _loop_loc)) + -> + let label_args_and_body = Core_to_mucore.at_of_arguments Fun.id label_args_and_body in + let label_args_and_statements = ArgumentTypes.map stmts_in_expr label_args_and_body in + Some (loop_condition_loc, label_args_and_statements) + + +let from_fn (fn, decl) = + match decl with + | ProcDecl (fn_loc, _fn) -> { fn; fn_loc; internal = None } + | Proc { loc = fn_loc; args_and_body; _ } -> + let args_and_body = Core_to_mucore.at_of_arguments Fun.id args_and_body in + let internal = + ArgumentTypes.map + (fun (body, labels, rt) -> + let stmts = stmts_in_expr body in + let loops = List.filter_map from_loop (Pmap.bindings_list labels) in + (rt, (stmts, loops))) + args_and_body + in + { fn; fn_loc; internal = Some internal } + + +let from_file (file : _ Mucore.file) = + let instrs = List.map from_fn (Pmap.bindings_list file.funs) in + (instrs, Compile.symtable) + + +let collect_instrumentation = from_file diff --git a/backend/cn/lib/executable_spec_extract.mli b/backend/cn/lib/executable_spec_extract.mli new file mode 100644 index 000000000..9844565f1 --- /dev/null +++ b/backend/cn/lib/executable_spec_extract.mli @@ -0,0 +1,41 @@ +type statement = Locations.t * Cnprog.t list + +type statements = statement list + +type loop = + Locations.t * statements ArgumentTypes.t (* location is for the loop condition *) + +type loops = loop list + +type fn_body = statements * loops + +type fn_args_and_body = (ReturnTypes.t * fn_body) ArgumentTypes.t + +type fn_largs_and_body = (ReturnTypes.t * fn_body) LogicalArgumentTypes.t + +(* type fn_spec_instrumentation = (ReturnTypes.t * statements) ArgumentTypes.t *) +(* type fn_spec_instrumentation_lat = (ReturnTypes.t * statements) LogicalArgumentTypes.t *) + +val sym_subst + : Sym.t * BaseTypes.t * Sym.t -> + [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t + +val fn_args_and_body_subst + : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> + fn_args_and_body -> + fn_args_and_body + +val fn_largs_and_body_subst + : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> + fn_largs_and_body -> + fn_largs_and_body + +type instrumentation = + { fn : Sym.t; + fn_loc : Locations.t; + internal : fn_args_and_body option + } + +val collect_instrumentation + : 'a Mucore.file -> + instrumentation list * BaseTypes.Surface.t Hashtbl.Make(Sym).t diff --git a/backend/cn/lib/executable_spec_internal.ml b/backend/cn/lib/executable_spec_internal.ml index 8cbc53a0b..d1cb0a530 100644 --- a/backend/cn/lib/executable_spec_internal.ml +++ b/backend/cn/lib/executable_spec_internal.ml @@ -55,8 +55,8 @@ let rec extract_global_variables = function let generate_c_pres_and_posts_internal - with_ownership_checking - (instrumentation : Core_to_mucore.instrumentation) + without_ownership_checking + (instrumentation : Executable_spec_extract.instrumentation) _ (sigm : _ CF.AilSyntax.sigma) (prog5 : unit Mucore.file) @@ -71,7 +71,7 @@ let generate_c_pres_and_posts_internal let globals = extract_global_variables prog5.globs in let ail_executable_spec = Cn_internal_to_ail.cn_to_ail_pre_post_internal - ~with_ownership_checking + ~without_ownership_checking dts preds globals @@ -82,7 +82,9 @@ let generate_c_pres_and_posts_internal let post_str = generate_ail_stat_strs ail_executable_spec.post in (* C ownership checking *) let (pre_str, post_str), block_ownership_injs = - if with_ownership_checking then ( + if without_ownership_checking then + ((pre_str, post_str), []) + else ( let fn_ownership_stats_opt, block_ownership_injs = Ownership_exec.get_c_fn_local_ownership_checking_injs instrumentation.fn sigm in @@ -97,8 +99,6 @@ let generate_c_pres_and_posts_internal in (pre_post_pair, block_ownership_injs) | None -> ((pre_str, post_str), [])) - else - ((pre_str, post_str), []) in (* Needed for extracting correct location for CN statement injection *) let modify_magic_comment_loc loc = @@ -151,11 +151,11 @@ let generate_c_pres_and_posts_internal let generate_c_assume_pres_internal - (instrumentation_list : Core_to_mucore.instrumentation list) + (instrumentation_list : Executable_spec_extract.instrumentation list) (sigma : CF.GenTypes.genTypeCategory A.sigma) (prog5 : unit Mucore.file) = - let aux (inst : Core_to_mucore.instrumentation) = + let aux (inst : Executable_spec_extract.instrumentation) = let dts = sigma.cn_datatypes in let preds = prog5.resource_predicates in let args = @@ -176,23 +176,23 @@ let generate_c_assume_pres_internal (AT.get_lat (Option.get inst.internal)) in instrumentation_list - |> List.filter (fun (inst : Core_to_mucore.instrumentation) -> + |> List.filter (fun (inst : Executable_spec_extract.instrumentation) -> Option.is_some inst.internal) |> List.map aux -(* Core_to_mucore.instrumentation list -> executable_spec *) +(* Executable_spec_extract.instrumentation list -> executable_spec *) let generate_c_specs_internal - with_ownership_checking + without_ownership_checking instrumentation_list type_map (_ : Cerb_location.t CStatements.LocMap.t) (sigm : CF.GenTypes.genTypeCategory CF.AilSyntax.sigma) (prog5 : unit Mucore.file) = - let generate_c_spec (instrumentation : Core_to_mucore.instrumentation) = + let generate_c_spec (instrumentation : Executable_spec_extract.instrumentation) = generate_c_pres_and_posts_internal - with_ownership_checking + without_ownership_checking instrumentation type_map sigm @@ -235,13 +235,6 @@ let generate_record_strs (record_def_strs, record_decl_strs) -let generate_all_record_strs sigm = - generate_record_strs - sigm - (Cn_internal_to_ail.cn_to_ail_pred_records - (Cn_internal_to_ail.RecordMap.bindings !Cn_internal_to_ail.records)) - - let generate_str_from_ail_struct ail_struct = CF.Pp_utils.to_plain_pretty_string (generate_doc_from_ail_struct ail_struct) @@ -360,89 +353,22 @@ let bt_is_record_or_tuple = function BT.Record _ | BT.Tuple _ -> true | _ -> fal let fns_and_preds_with_record_rt (funs, preds) = let funs' = List.filter - (fun (_, (def : LogicalFunctions.definition)) -> - bt_is_record_or_tuple def.return_bt) + (fun (_, (def : Definition.Function.t)) -> bt_is_record_or_tuple def.return_bt) funs in let fun_syms = List.map (fun (fn_sym, _) -> fn_sym) funs' in let preds' = List.filter - (fun (_, (def : ResourcePredicates.definition)) -> - bt_is_record_or_tuple def.oarg_bt) + (fun (_, (def : Definition.Predicate.t)) -> bt_is_record_or_tuple def.oarg_bt) preds in let pred_syms = List.map (fun (pred_sym, _) -> pred_sym) preds' in (fun_syms, pred_syms) -let generate_c_record_funs - (sigm : CF.GenTypes.genTypeCategory CF.AilSyntax.sigma) - (logical_predicates : (Sym.t * LogicalFunctions.definition) list) - (resource_predicates : (Sym.t * ResourcePredicates.definition) list) - = - let cn_record_info = - List.map - (fun (sym, (def : LogicalFunctions.definition)) -> - match def.return_bt with - | BT.Record ms -> - [ (Cn_internal_to_ail.generate_sym_with_suffix ~suffix:"_record" sym, ms) ] - | _ -> []) - logical_predicates - in - let cn_record_info' = - List.map - (fun (sym, (def : ResourcePredicates.definition)) -> - match def.oarg_bt with - | BT.Record ms -> - [ (Cn_internal_to_ail.generate_sym_with_suffix ~suffix:"_record" sym, ms) ] - | _ -> []) - resource_predicates - in - let cn_record_info = List.concat (cn_record_info @ cn_record_info') in - let record_equality_functions = - List.concat - (List.map - (Cn_internal_to_ail.generate_record_equality_function sigm.cn_datatypes) - cn_record_info) - in - let record_default_functions = - List.concat - (List.map - (Cn_internal_to_ail.generate_record_default_function sigm.cn_datatypes) - cn_record_info) - in - let record_map_get_functions = - List.concat (List.map Cn_internal_to_ail.generate_record_map_get cn_record_info) - in - let eq_decls, eq_defs = List.split record_equality_functions in - let default_decls, default_defs = List.split record_default_functions in - let mapget_decls, mapget_defs = List.split record_map_get_functions in - let modified_prog1 : CF.GenTypes.genTypeCategory CF.AilSyntax.sigma = - { sigm with - declarations = eq_decls @ default_decls @ mapget_decls; - function_definitions = eq_defs @ default_defs @ mapget_defs - } - in - let fun_doc = - CF.Pp_ail.pp_program ~executable_spec:true ~show_include:true (None, modified_prog1) - in - let fun_strs = CF.Pp_utils.to_plain_pretty_string fun_doc in - let decl_docs = - List.map - (fun (sym, (_, _, decl)) -> - CF.Pp_ail.pp_function_prototype ~executable_spec:true sym decl) - (eq_decls @ default_decls @ mapget_decls) - in - let fun_prot_strs = - List.map (fun doc -> [ CF.Pp_utils.to_plain_pretty_string doc ]) decl_docs - in - let fun_prot_strs = String.concat "\n" (List.concat fun_prot_strs) in - (fun_strs, fun_prot_strs) - - let generate_c_functions_internal (sigm : CF.GenTypes.genTypeCategory CF.AilSyntax.sigma) - (logical_predicates : (Sym.t * LogicalFunctions.definition) list) + (logical_predicates : (Sym.t * Definition.Function.t) list) = let ail_funs_and_records = List.map @@ -512,7 +438,7 @@ let rec remove_duplicates eq_fun = function let generate_c_predicates_internal (sigm : CF.GenTypes.genTypeCategory CF.AilSyntax.sigma) - (resource_predicates : (Sym.t * ResourcePredicates.definition) list) + (resource_predicates : (Sym.t * Definition.Predicate.t) list) = (* let ail_info = List.map (fun cn_f -> Cn_internal_to_ail.cn_to_ail_predicate_internal cn_f sigm.cn_datatypes [] ownership_ctypes resource_predicates) resource_predicates @@ -554,7 +480,7 @@ let generate_c_predicates_internal let generate_ownership_functions - with_ownership_checking + without_ownership_checking ownership_ctypes (sigm : CF.GenTypes.genTypeCategory CF.AilSyntax.sigma) = @@ -572,8 +498,8 @@ let generate_ownership_functions let ail_funs = List.map (fun ctype -> - Cn_internal_to_ail.generate_check_ownership_function - ~with_ownership_checking + Cn_internal_to_ail.generate_get_or_put_ownership_function + ~without_ownership_checking ctype) ctypes in diff --git a/backend/cn/lib/executable_spec_records.ml b/backend/cn/lib/executable_spec_records.ml index 3e6deb460..bac5becf4 100644 --- a/backend/cn/lib/executable_spec_records.ml +++ b/backend/cn/lib/executable_spec_records.ml @@ -9,7 +9,7 @@ module LAT = LogicalArgumentTypes module AT = ArgumentTypes let rec add_records_to_map_from_it it = - match IT.term it with + match IT.get_term it with | IT.Sym _s -> () | Const _c -> () | Unop (_uop, t1) -> add_records_to_map_from_it t1 @@ -24,7 +24,7 @@ let rec add_records_to_map_from_it it = | StructUpdate ((t1, _member), t2) -> List.iter add_records_to_map_from_it [ t1; t2 ] | Record members -> (* Anonymous record instantiation -> add to records map *) - Cn_internal_to_ail.augment_record_map (IT.bt it); + Cn_internal_to_ail.augment_record_map (IT.get_bt it); List.iter (fun (_, it') -> add_records_to_map_from_it it') members | RecordMember (t, _member) -> add_records_to_map_from_it t | RecordUpdate ((t1, _member), t2) -> List.iter add_records_to_map_from_it [ t1; t2 ] @@ -56,7 +56,7 @@ let rec add_records_to_map_from_it it = let add_records_to_map_from_resource = function - | ResourceTypes.P p -> List.iter add_records_to_map_from_it (p.pointer :: p.iargs) + | Request.P p -> List.iter add_records_to_map_from_it (p.pointer :: p.iargs) | Q q -> List.iter add_records_to_map_from_it (q.pointer :: q.step :: q.permission :: q.iargs) @@ -83,7 +83,7 @@ let add_records_to_map_from_cnprogs (_, cn_progs) = List.iter aux cn_progs -let add_records_to_map_from_instrumentation (i : Core_to_mucore.instrumentation) = +let add_records_to_map_from_instrumentation (i : Executable_spec_extract.instrumentation) = let rec aux_lrt = function | LRT.Define ((_, it), _, t) -> add_records_to_map_from_it it; @@ -96,6 +96,7 @@ let add_records_to_map_from_instrumentation (i : Core_to_mucore.instrumentation) aux_lrt t | I -> () in + let aux_rt = function ReturnTypes.Computational (_, _, t) -> aux_lrt t in let rec aux_lat = function | LAT.Define ((_, it), _, lat) -> add_records_to_map_from_it it; @@ -107,33 +108,133 @@ let add_records_to_map_from_instrumentation (i : Core_to_mucore.instrumentation) add_records_to_map_from_lc lc; aux_lat lat (* Postcondition *) - | I (ReturnTypes.Computational (_, _, t), stats) -> - List.iter add_records_to_map_from_cnprogs stats; - aux_lrt t + | I i -> i in let rec aux_at = function | AT.Computational ((_, _), _, at) -> aux_at at | L lat -> aux_lat lat in - match i.internal with Some instr -> aux_at instr | None -> () + match i.internal with + | None -> () + | Some instr -> + let rt, (stmts, loops) = aux_at instr in + aux_rt rt; + List.iter add_records_to_map_from_cnprogs stmts; + List.iter + (fun (_loc, loop_at) -> + let loop_stmts = aux_at loop_at in + List.iter add_records_to_map_from_cnprogs loop_stmts) + loops + + +let rec populate ?cn_sym bt = + match bt with + | BT.Record members -> + (match cn_sym with + (* Naming convention only needed for top-level records returned from CN functions and predicates *) + | Some cn_sym' -> Cn_internal_to_ail.augment_record_map ~cn_sym:cn_sym' bt + | None -> Cn_internal_to_ail.augment_record_map bt); + List.iter (fun bt' -> populate bt') (List.map snd members) + | _ -> () + + +let add_records_to_map_from_fns_and_preds cn_funs cn_preds = + let fun_syms_and_ret_types = + List.map (fun (sym, (def : Definition.Function.t)) -> (sym, def.return_bt)) cn_funs + in + let pred_syms_and_ret_types = + List.map (fun (sym, (def : Definition.Predicate.t)) -> (sym, def.oarg_bt)) cn_preds + in + List.iter + (fun (cn_sym, bt) -> populate ~cn_sym bt) + (fun_syms_and_ret_types @ pred_syms_and_ret_types) + + +let add_records_to_map_from_datatype (dt : Mucore.datatype) = + let bts = List.map (fun (_, ms) -> List.map snd ms) dt.cases in + let bts = List.concat bts in + List.iter populate bts + + +let add_records_to_map_from_struct (tag_def : Mucore.tag_definition) = + match tag_def with + | Mucore.StructDef sl -> + List.iter + (fun (sp : Memory.struct_piece) -> + match sp.member_or_padding with + | Some (_, sct) -> + populate + (BT.of_sct Memory.is_signed_integer_type Memory.size_of_integer_type sct) + | None -> ()) + sl + | UnionDef -> () (* Populate record table *) let populate_record_map - (instrumentation : Core_to_mucore.instrumentation list) + (instrumentation : Executable_spec_extract.instrumentation list) (prog5 : unit Mucore.file) = - let fun_syms_and_ret_types = - List.map - (fun (sym, (def : LogicalFunctions.definition)) -> (sym, def.return_bt)) - prog5.logical_predicates + add_records_to_map_from_fns_and_preds prog5.logical_predicates prog5.resource_predicates; + List.iter add_records_to_map_from_datatype (List.map snd prog5.datatypes); + List.iter + add_records_to_map_from_struct + (List.map snd (Pmap.bindings_list prog5.tagDefs)); + List.iter add_records_to_map_from_instrumentation instrumentation + + +let generate_all_record_strs () = + let ail_records = + Cn_internal_to_ail.cn_to_ail_records + (Cn_internal_to_ail.RecordMap.bindings !Cn_internal_to_ail.records) in - let pred_syms_and_ret_types = + let record_def_strs, record_decl_strs = + Executable_spec_internal.generate_c_records ail_records + in + (record_def_strs, record_decl_strs) + + +let generate_c_record_funs (sigm : CF.GenTypes.genTypeCategory CF.AilSyntax.sigma) = + let cn_record_info = + Cn_internal_to_ail.RecordMap.bindings !Cn_internal_to_ail.records + in + let cn_record_info = List.map (fun (ms, sym) -> (sym, ms)) cn_record_info in + let record_equality_functions = + List.concat + (List.map + (Cn_internal_to_ail.generate_record_equality_function sigm.cn_datatypes) + cn_record_info) + in + let record_default_functions = + List.concat + (List.map + (Cn_internal_to_ail.generate_record_default_function sigm.cn_datatypes) + cn_record_info) + in + let record_map_get_functions = + List.concat (List.map Cn_internal_to_ail.generate_record_map_get cn_record_info) + in + let eq_decls, eq_defs = List.split record_equality_functions in + let default_decls, default_defs = List.split record_default_functions in + let mapget_decls, mapget_defs = List.split record_map_get_functions in + let modified_prog1 : CF.GenTypes.genTypeCategory CF.AilSyntax.sigma = + { sigm with + declarations = eq_decls @ default_decls @ mapget_decls; + function_definitions = eq_defs @ default_defs @ mapget_defs + } + in + let fun_doc = + CF.Pp_ail.pp_program ~executable_spec:true ~show_include:true (None, modified_prog1) + in + let fun_strs = CF.Pp_utils.to_plain_pretty_string fun_doc in + let decl_docs = List.map - (fun (sym, (def : ResourcePredicates.definition)) -> (sym, def.oarg_bt)) - prog5.resource_predicates + (fun (sym, (_, _, decl)) -> + CF.Pp_ail.pp_function_prototype ~executable_spec:true sym decl) + (eq_decls @ default_decls @ mapget_decls) in - List.iter - (fun (cn_sym, bt) -> Cn_internal_to_ail.augment_record_map ~cn_sym bt) - (fun_syms_and_ret_types @ pred_syms_and_ret_types); - List.iter add_records_to_map_from_instrumentation instrumentation + let fun_prot_strs = + List.map (fun doc -> [ CF.Pp_utils.to_plain_pretty_string doc ]) decl_docs + in + let fun_prot_strs = String.concat "\n" (List.concat fun_prot_strs) in + (fun_strs, fun_prot_strs) diff --git a/backend/cn/lib/explain.ml b/backend/cn/lib/explain.ml index 9297d5cf2..6425863d5 100644 --- a/backend/cn/lib/explain.ml +++ b/backend/cn/lib/explain.ml @@ -1,24 +1,15 @@ -open Report -module IT = IndexTerms +module Rp = Report module BT = BaseTypes -module RE = Resources -module REP = ResourcePredicates -module RET = ResourceTypes -module LC = LogicalConstraints -module LF = LogicalFunctions +module IT = IndexTerms +module Def = Definition +module Req = Request +module Res = Resource +module LF = Definition.Function module LAT = LogicalArgumentTypes -module LS = LogicalSorts -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) -module StringMap = Map.Make (String) -module C = Context +module LC = LogicalConstraints module Loc = Locations -module S = Solver -open ResourceTypes -open IndexTerms +module C = Context open Pp -open C -open Resources (* perhaps somehow unify with above *) type action = @@ -38,22 +29,20 @@ type log = log_entry list (* most recent first *) let clause_has_resource req c = let open LogicalArgumentTypes in let rec f = function - | Resource ((_, (r, _)), _, c) -> RET.same_predicate_name req r || f c + | Resource ((_, (r, _)), _, c) -> Req.same_name req r || f c | Constraint (_, _, c) -> f c | Define (_, _, c) -> f c | I _ -> false in - let open ResourcePredicates in - f c.packing_ft + f c.Def.Clause.packing_ft let relevant_predicate_clauses global name req = let open Global in - let open ResourcePredicates in let clauses = - let defs = SymMap.bindings global.resource_predicates in + let defs = Sym.Map.bindings global.resource_predicates in List.concat_map - (fun (nm, def) -> + (fun (nm, (def : Def.Predicate.t)) -> match def.clauses with | Some clauses -> List.map (fun c -> (nm, c)) clauses | None -> []) @@ -63,7 +52,7 @@ let relevant_predicate_clauses global name req = type state_extras = - { request : RET.t option; + { request : Req.t option; unproven_constraint : LC.t option } @@ -78,13 +67,13 @@ module ITSet = struct end let subterms_without_bound_variables bindings = - fold_subterms + IT.fold_subterms ~bindings (fun bindings acc t -> let pats = List.map fst bindings in - let bound = List.concat_map bound_by_pattern pats in - let bound = SymSet.of_list (List.map fst bound) in - if SymSet.(is_empty (inter bound (IT.free_vars t))) then + let bound = List.concat_map IT.bound_by_pattern pats in + let bound = Sym.Set.of_list (List.map fst bound) in + if Sym.Set.(is_empty (inter bound (IT.free_vars t))) then ITSet.add t acc else acc) @@ -94,11 +83,11 @@ let subterms_without_bound_variables bindings = (** Simplify a constraint in the context of a model. *) let simp_constraint eval lct = let eval_to_bool it = - match eval it with Some (IT (Const (Bool b1), _, _)) -> Some b1 | _ -> None + match eval it with Some (IT.IT (Const (Bool b1), _, _)) -> Some b1 | _ -> None in let is b it = match eval_to_bool it with Some b1 -> Bool.equal b b1 | _ -> false in - let rec go (IT (term, bt, loc)) = - let mk x = IT (x, bt, loc) in + let rec go (IT.IT (term, bt, loc)) = + let mk x = IT.IT (x, bt, loc) in let ands xs = IT.and_ xs loc in let go1 t = ands (go t) in match term with @@ -126,7 +115,7 @@ let rec simp_resource eval r = let is_true = match ct with | LC.T ct -> - (match eval ct with Some (IT (Const (Bool b), _, _)) -> b | _ -> false) + (match eval ct with Some (IT.IT (Const (Bool b), _, _)) -> b | _ -> false) | _ -> false in if is_true then @@ -140,7 +129,7 @@ let rec simp_resource eval r = | I i -> I i -let state ctxt log model_with_q extras = +let state (ctxt : C.t) log model_with_q extras = let where = let cur_colour = !Cerb_colour.do_colour in Cerb_colour.do_colour := false; @@ -163,17 +152,17 @@ let state ctxt log model_with_q extras = result in let model, quantifier_counter_model = model_with_q in - let evaluate it = Solver.eval ctxt.global model it in + let evaluate it = Solver.eval model it in (* let _mevaluate it = *) (* match evaluate it with *) (* | Some v -> IT.pp v *) (* | None -> parens !^"not evaluated" *) (* in *) let render_constraints c = - { original = LC.pp c; simplified = List.map LC.pp (simp_constraint evaluate c) } + Rp.{ original = LC.pp c; simplified = List.map LC.pp (simp_constraint evaluate c) } in let render_sympair p = - { original = Sym.pp (fst p); simplified = [ Sym.pp (fst p) ] } + Rp.{ original = Sym.pp (fst p); simplified = [ Sym.pp (fst p) ] } (*Symbols do not need simplification*) in let interesting, uninteresting = @@ -184,7 +173,7 @@ let state ctxt log model_with_q extras = | LC.T (IT (Representable _, _, _)) -> false | LC.T (IT (Good _, _, _)) -> false | _ -> true) - (LCSet.elements ctxt.constraints) + (LC.Set.elements ctxt.constraints) in let not_given_to_solver = (* get predicates from past steps of trace not given to solver *) @@ -192,13 +181,13 @@ let state ctxt log model_with_q extras = let log_comb acc entry = match entry with | State ctxt -> - let _, _, ps = not_given_to_solver ctxt in + let _, _, ps = C.not_given_to_solver ctxt in List.append ps acc | Action _ -> acc in List.fold_left log_comb [] log in - let forall_constraints, funs, ctxt_preds = not_given_to_solver ctxt in + let forall_constraints, funs, ctxt_preds = C.not_given_to_solver ctxt in let preds = let pred_compare (s1, _) (s2, _) = Sym.compare s1 s2 in (*CHT TODO: deriving this would require changing a lot of files *) @@ -211,40 +200,40 @@ let state ctxt log model_with_q extras = List.partition (fun (_, v) -> LF.is_interesting v) funs in let interesting_preds, uninteresting_preds = - List.partition (fun (_, v) -> REP.is_interesting v) preds + List.partition (fun (_, v) -> Def.is_interesting v) preds in - add_labeled - lab_interesting + Rp.add_labeled + Rp.lab_interesting (List.concat [ List.map render_sympair interesting_preds; List.map render_sympair interesting_funs; List.map render_constraints interesting_constraints ]) - (add_labeled - lab_uninteresting + (Rp.add_labeled + Rp.lab_uninteresting (List.concat [ List.map render_sympair uninteresting_preds; List.map render_sympair uninteresting_funs; List.map render_constraints uninteresting_constraints ]) - labeled_empty) + Rp.labeled_empty) in let terms = let variables = - let make s ls = sym_ (s, ls, Locations.other __FUNCTION__) in + let make s ls = IT.sym_ (s, ls, Locations.other __LOC__) in let basetype_binding (s, (binding, _)) = - match binding with Value _ -> None | BaseType ls -> Some (make s ls) + match binding with C.Value _ -> None | BaseType ls -> Some (make s ls) in ITSet.of_list (List.map (fun (s, ls) -> make s ls) quantifier_counter_model - @ List.filter_map basetype_binding (SymMap.bindings ctxt.computational) - @ List.filter_map basetype_binding (SymMap.bindings ctxt.logical)) + @ List.filter_map basetype_binding (Sym.Map.bindings ctxt.computational) + @ List.filter_map basetype_binding (Sym.Map.bindings ctxt.logical)) in let unproven = match extras.unproven_constraint with | Some (T lc) -> subterms_without_bound_variables [] lc | Some (Forall ((s, bt), lc)) -> - let binder = (Pat (PSym s, bt, Loc.other __FUNCTION__), None) in + let binder = IT.(Pat (PSym s, bt, Loc.other __LOC__), None) in subterms_without_bound_variables [ binder ] lc | None -> ITSet.empty in @@ -253,7 +242,7 @@ let state ctxt log model_with_q extras = | Some (P ret) -> ITSet.bigunion_map (subterms_without_bound_variables []) (ret.pointer :: ret.iargs) | Some (Q ret) -> - let binder = (Pat (PSym (fst ret.q), snd ret.q, Loc.other __FUNCTION__), None) in + let binder = IT.(Pat (PSym (fst ret.q), snd ret.q, Loc.other __LOC__), None) in ITSet.union (ITSet.bigunion_map (subterms_without_bound_variables []) @@ -271,7 +260,7 @@ let state ctxt log model_with_q extras = (fun it -> match evaluate it with | Some value when not (IT.equal value it) -> - Some (it, { term = IT.pp it; value = IT.pp value }) + Some (it, Rp.{ term = IT.pp it; value = IT.pp value }) | Some _ -> None | None -> None) (ITSet.elements subterms) @@ -279,56 +268,56 @@ let state ctxt log model_with_q extras = let interesting, uninteresting = List.partition (fun (it, _entry) -> - match IT.bt it with BT.Unit -> false | BT.Loc () -> false | _ -> true) + match IT.get_bt it with BT.Unit -> false | BT.Loc () -> false | _ -> true) filtered in - add_labeled - lab_interesting + Rp.add_labeled + Rp.lab_interesting (List.map snd interesting) - (add_labeled lab_uninteresting (List.map snd uninteresting) labeled_empty) + (Rp.add_labeled Rp.lab_uninteresting (List.map snd uninteresting) Rp.labeled_empty) in let constraints = - add_labeled - lab_interesting + Rp.add_labeled + Rp.lab_interesting (List.map render_constraints interesting) - (add_labeled - lab_uninteresting + (Rp.add_labeled + Rp.lab_uninteresting (List.map render_constraints uninteresting) - labeled_empty) + Rp.labeled_empty) in let resources = let same_res, diff_res = match extras.request with - | None -> ([], get_rs ctxt) - | Some req -> - List.partition (fun r -> RET.same_predicate_name req (RE.request r)) (get_rs ctxt) + | None -> ([], C.get_rs ctxt) + | Some req -> List.partition (fun (r, _) -> Req.same_name req r) (C.get_rs ctxt) in let interesting_diff_res, uninteresting_diff_res = List.partition (fun (ret, _o) -> match ret with - | P ret when equal_predicate_name ret.name ResourceTypes.alloc -> false + | Req.P ret when Req.equal_name ret.name Req.Predicate.alloc -> false | _ -> true) diff_res in let with_suff mb x = match mb with None -> x | Some d -> d ^^^ x in let pp_res mb_suff (rt, args) = - { original = with_suff mb_suff (RE.pp (rt, args)); - simplified = - [ with_suff mb_suff (RE.pp (Interval.Solver.simp_rt evaluate rt, args)) ] - } + Rp. + { original = with_suff mb_suff (Res.pp (rt, args)); + simplified = + [ with_suff mb_suff (Res.pp (Interval.Solver.simp_rt evaluate rt, args)) ] + } in let interesting = List.map (fun re -> pp_res (Some (parens !^"same type")) re) same_res @ List.map (pp_res None) interesting_diff_res in let uninteresting = List.map (pp_res None) uninteresting_diff_res in - add_labeled - lab_interesting + Rp.add_labeled + Rp.lab_interesting interesting - (add_labeled lab_uninteresting uninteresting labeled_empty) + (Rp.add_labeled Rp.lab_uninteresting uninteresting Rp.labeled_empty) in - { where; not_given_to_solver; terms; resources; constraints } + Rp.{ where; not_given_to_solver; terms; resources; constraints } let trace (ctxt, log) (model_with_q : Solver.model_with_q) (extras : state_extras) = @@ -337,17 +326,17 @@ let trace (ctxt, log) (model_with_q : Solver.model_with_q) (extras : state_extra (* let req_cmp = Option.bind extras.request (Spans.spans_compare_for_pp model ctxt.global) in *) (* let req_entry req_cmp req = { *) - (* res = RET.pp req; *) + (* res = Req.pp req; *) (* res_span = Spans.pp_model_spans model ctxt.global req_cmp req *) (* } *) (* in *) (* let res_entry req_cmp same res = { *) - (* res = RE.pp res; *) - (* res_span = Spans.pp_model_spans model ctxt.global req_cmp (RE.request res) *) + (* res = Res.pp res; *) + (* res_span = Spans.pp_model_spans model ctxt.global req_cmp (Res.request res) *) (* ^^ (if same then !^" - same-type" else !^"") *) (* } *) (* in *) - let req_entry ret = RET.pp ret in + let req_entry ret = Req.pp ret in let trace = let statef ctxt = state ctxt log model_with_q extras in List.rev @@ -355,19 +344,20 @@ let trace (ctxt, log) (model_with_q : Solver.model_with_q) (extras : state_extra :: List.filter_map (function State ctxt -> Some (statef ctxt) | _ -> None) log) in let model, _quantifier_counter_model = model_with_q in - let evaluate it = Solver.eval ctxt.global model it in + let evaluate it = Solver.eval model it in let predicate_hints = match extras.request with | None -> [] | Some req -> - let open ResourcePredicates in - (match predicate_name req with + (match Req.get_name req with | Owned _ -> [] | PName pname -> - let doc_clause (_name, c) = - { cond = IT.pp c.guard; - clause = LogicalArgumentTypes.pp IT.pp (simp_resource evaluate c.packing_ft) - } + let doc_clause (_name, (c : Def.Clause.t)) = + Rp. + { cond = IT.pp c.guard; + clause = + LogicalArgumentTypes.pp IT.pp (simp_resource evaluate c.packing_ft) + } in List.map doc_clause (relevant_predicate_clauses ctxt.global pname req)) in @@ -380,4 +370,4 @@ let trace (ctxt, log) (model_with_q : Solver.model_with_q) (extras : state_extra | None -> None in Pp.html_escapes := prev; - { requested; unproven; predicate_hints; trace } + Rp.{ requested; unproven; predicate_hints; trace } diff --git a/backend/cn/lib/explain.mli b/backend/cn/lib/explain.mli index d9f419abc..ceba45947 100644 --- a/backend/cn/lib/explain.mli +++ b/backend/cn/lib/explain.mli @@ -17,7 +17,7 @@ type log = log_entry list (** Additional information about what went wrong. *) type state_extras = - { request : ResourceTypes.t option; (** Requested resource *) + { request : Request.t option; (** Requested resource *) unproven_constraint : LogicalConstraints.t option (** Unproven constraint *) } diff --git a/backend/cn/lib/false.ml b/backend/cn/lib/false.ml index 25798d91c..9455323f2 100644 --- a/backend/cn/lib/false.ml +++ b/backend/cn/lib/false.ml @@ -1,12 +1,11 @@ open Pp -module SymSet = Set.Make (Sym) type t = False (* [@@deriving eq, ord] *) let subst _substitution = function False -> False -let free_vars = function False -> SymSet.empty +let free_vars = function False -> Sym.Set.empty let pp = function False -> if !unicode then !^"\u{22A5}" else !^"false" diff --git a/backend/cn/lib/false.mli b/backend/cn/lib/false.mli index 75363d614..624a78eb4 100644 --- a/backend/cn/lib/false.mli +++ b/backend/cn/lib/false.mli @@ -7,6 +7,4 @@ val subst : 'a -> t -> t val pp : t -> Pp.document -module SymSet : Set.S with type elt = Sym.t - -val free_vars : t -> SymSet.t +val free_vars : t -> Sym.Set.t diff --git a/backend/cn/lib/global.ml b/backend/cn/lib/global.ml index 9194de9c2..3b18160c2 100644 --- a/backend/cn/lib/global.ml +++ b/backend/cn/lib/global.ml @@ -1,45 +1,143 @@ open Pp -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) module IdMap = Map.Make (Id) module RT = ReturnTypes module AT = ArgumentTypes type t = { struct_decls : Memory.struct_decls; - datatypes : BaseTypes.dt_info SymMap.t; - datatype_constrs : BaseTypes.constr_info SymMap.t; + datatypes : BaseTypes.dt_info Sym.Map.t; + datatype_constrs : BaseTypes.constr_info Sym.Map.t; datatype_order : Sym.t list list option; - fun_decls : (Locations.t * AT.ft option * Sctypes.c_concrete_sig) SymMap.t; - resource_predicates : ResourcePredicates.definition SymMap.t; - logical_functions : LogicalFunctions.definition SymMap.t; - lemmata : (Locations.t * AT.lemmat) SymMap.t + fun_decls : (Locations.t * AT.ft option * Sctypes.c_concrete_sig) Sym.Map.t; + resource_predicates : Definition.Predicate.t Sym.Map.t; + logical_functions : Definition.Function.t Sym.Map.t; + lemmata : (Locations.t * AT.lemmat) Sym.Map.t } let empty = - { struct_decls = SymMap.empty; - datatypes = SymMap.empty; - datatype_constrs = SymMap.empty; + { struct_decls = Sym.Map.empty; + datatypes = Sym.Map.empty; + datatype_constrs = Sym.Map.empty; datatype_order = None; - fun_decls = SymMap.empty; - resource_predicates = - SymMap.(empty |> add Alloc.Predicate.sym ResourcePredicates.alloc); - logical_functions = SymMap.empty; - lemmata = SymMap.empty + fun_decls = Sym.Map.empty; + resource_predicates = Sym.Map.(empty |> add Alloc.Predicate.sym Definition.alloc); + logical_functions = Sym.Map.empty; + lemmata = Sym.Map.empty } -let get_resource_predicate_def global id = SymMap.find_opt id global.resource_predicates +let get_resource_predicate_def global id = Sym.Map.find_opt id global.resource_predicates -let get_logical_function_def global id = SymMap.find_opt id global.logical_functions +let get_logical_function_def global id = Sym.Map.find_opt id global.logical_functions -let get_fun_decl global sym = SymMap.find_opt sym global.fun_decls +let get_fun_decl global sym = Sym.Map.find_opt sym global.fun_decls -let get_lemma global sym = SymMap.find_opt sym global.lemmata +let get_lemma global sym = Sym.Map.find_opt sym global.lemmata + +let get_struct_decl global sym = Sym.Map.find_opt sym global.struct_decls + +let get_datatype global sym = Sym.Map.find_opt sym global.datatypes + +let get_datatype_constr global sym = Sym.Map.find_opt sym global.datatype_constrs let sym_map_from_bindings xs = - List.fold_left (fun m (nm, x) -> SymMap.add nm x m) SymMap.empty xs + List.fold_left (fun m (nm, x) -> Sym.Map.add nm x m) Sym.Map.empty xs + + +type error = + | Unknown_function of Sym.t + | Unknown_struct of Sym.t + | Unknown_datatype of Sym.t + | Unknown_datatype_constr of Sym.t + | Unknown_resource_predicate of + { id : Sym.t; + logical : bool + } + | Unknown_logical_function of + { id : Sym.t; + resource : bool + } + | Unknown_lemma of Sym.t + | Unexpected_member of Id.t list * Id.t (** TODO replace with actual terms *) + +type global_t_alias_do_not_use = t + +module type ErrorReader = sig + type 'a t + + val return : 'a -> 'a t + + val bind : 'a t -> ('a -> 'b t) -> 'b t + + val get_global : unit -> global_t_alias_do_not_use t + + val fail : Locations.t -> error -> 'a t +end + +module type Lifted = sig + type 'a t + + val get_resource_predicate_def : Locations.t -> Sym.t -> Definition.Predicate.t t + + val get_logical_function_def : Locations.t -> Sym.t -> Definition.Function.t t + + val get_fun_decl + : Locations.t -> + Sym.t -> + (Cerb_location.t * AT.ft option * Sctypes.c_concrete_sig) t + + val get_lemma : Locations.t -> Sym.t -> (Cerb_location.t * AT.lemmat) t + + val get_struct_decl : Locations.t -> Sym.t -> Memory.struct_layout t + + val get_member_type : Locations.t -> Id.t -> Memory.struct_piece list -> Sctypes.ctype t + + val get_datatype : Locations.t -> Sym.t -> BaseTypes.dt_info t + + val get_datatype_constr : Locations.t -> Sym.t -> BaseTypes.constr_info t +end + +module Lift (M : ErrorReader) : Lifted with type 'a t := 'a M.t = struct + let lift f loc sym msg = + let ( let@ ) = M.bind in + let@ global = M.get_global () in + match f global sym with Some x -> M.return x | None -> M.fail loc (msg global) + + + let get_logical_function_def_opt id = get_logical_function_def id + + let get_logical_function_def loc id = + lift get_logical_function_def loc id (fun global -> + let res = get_resource_predicate_def global id in + Unknown_logical_function { id; resource = Option.is_some res }) + + + let get_resource_predicate_def loc id = + lift get_resource_predicate_def loc id (fun global -> + let log = get_logical_function_def_opt global id in + Unknown_resource_predicate { id; logical = Option.is_some log }) + + + let get_fun_decl loc fsym = lift get_fun_decl loc fsym (fun _ -> Unknown_function fsym) + + let get_lemma loc lsym = lift get_lemma loc lsym (fun _ -> Unknown_lemma lsym) + + let get_struct_decl loc tag = lift get_struct_decl loc tag (fun _ -> Unknown_struct tag) + + let get_member_type loc member layout = + let member_types = Memory.member_types layout in + match List.assoc_opt Id.equal member member_types with + | Some membertyp -> M.return membertyp + | None -> M.fail loc (Unexpected_member (List.map fst member_types, member)) + + + let get_datatype loc tag = + lift get_datatype loc tag (fun _ -> Unknown_datatype_constr tag) + + let get_datatype_constr loc tag = + lift get_datatype_constr loc tag (fun _ -> Unknown_datatype_constr tag) +end let pp_struct_layout (tag, layout) = item @@ -59,19 +157,19 @@ let pp_struct_layout (tag, layout) = layout) -let pp_struct_decls decls = Pp.list pp_struct_layout (SymMap.bindings decls) +let pp_struct_decls decls = Pp.list pp_struct_layout (Sym.Map.bindings decls) let pp_fun_decl (sym, (_, t, _)) = item (plain (Sym.pp sym)) (Pp.option (AT.pp RT.pp) "(no spec)" t) -let pp_fun_decls decls = flow_map hardline pp_fun_decl (SymMap.bindings decls) +let pp_fun_decls decls = flow_map hardline pp_fun_decl (Sym.Map.bindings decls) let pp_resource_predicate_definitions defs = separate_map hardline - (fun (name, def) -> item (Sym.pp_string name) (ResourcePredicates.pp_definition def)) - (SymMap.bindings defs) + (fun (name, def) -> item (Sym.pp_string name) (Definition.Predicate.pp def)) + (Sym.Map.bindings defs) let pp global = @@ -84,15 +182,15 @@ let pp global = let mutual_datatypes (global : t) tag = let deps tag = - let info = SymMap.find tag global.datatypes in + let info = Sym.Map.find tag global.datatypes in info.all_params |> List.filter_map (fun (_, bt) -> BaseTypes.is_datatype_bt bt) in let rec seek tags = function | [] -> tags | new_tag :: new_tags -> - if SymSet.mem new_tag tags then + if Sym.Set.mem new_tag tags then seek tags new_tags else - seek (SymSet.add new_tag tags) (deps new_tag @ new_tags) + seek (Sym.Set.add new_tag tags) (deps new_tag @ new_tags) in - seek SymSet.empty [ tag ] |> SymSet.elements + seek Sym.Set.empty [ tag ] |> Sym.Set.elements diff --git a/backend/cn/lib/id.ml b/backend/cn/lib/id.ml index 10b7587fc..f11e000b8 100644 --- a/backend/cn/lib/id.ml +++ b/backend/cn/lib/id.ml @@ -2,25 +2,18 @@ module CF = Cerb_frontend type t = CF.Symbol.identifier -let s (CF.Symbol.Identifier (_, s)) = s +let get_string (CF.Symbol.Identifier (_, s)) = s -let loc (CF.Symbol.Identifier (loc, _)) = loc +let get_loc (CF.Symbol.Identifier (loc, _)) = loc -let pp_string id = s id - -let pp id = PPrint.( !^ ) (s id) +let pp id = PPrint.( !^ ) (get_string id) let equal = CF.Symbol.idEqual -let compare id id' = String.compare (s id) (s id') - -let parse loc id = CF.Symbol.Identifier (loc, id) - -let id id = - let here = Locations.other __FUNCTION__ in - CF.Symbol.Identifier (here, id) +let compare id id' = String.compare (get_string id) (get_string id') +let make loc id = CF.Symbol.Identifier (loc, id) -let is_str str id = String.equal (s id) str +let equal_string str id = String.equal (get_string id) str let subst _ id = id diff --git a/backend/cn/lib/id.mli b/backend/cn/lib/id.mli index 5c3edccb6..a903acf30 100644 --- a/backend/cn/lib/id.mli +++ b/backend/cn/lib/id.mli @@ -3,20 +3,11 @@ This module adds a number of useful functions on identifiers to the ones already provided by Cerberus. *) -(* TODO: BCP: I'm a bit surprised that some of these are not already provided by - Cerberus! *) -(* TODO: DCM: Id.s should IMO be to_string Id.pp_string should be deleted or deprecated - Id.parse would be clearer as Id.make Id.id should really be deprecated/deleted since - the location info is not useful unless used at the call site. Id.is_str can maybe stay - as is or be renamed to Id.equal_string *) - type t = Cerb_frontend.Symbol.identifier -val s : t -> string - -val loc : t -> Cerb_location.t +val get_string : t -> string -val pp_string : t -> string +val get_loc : t -> Cerb_location.t val pp : t -> PPrint.document @@ -24,10 +15,8 @@ val equal : t -> t -> bool val compare : t -> t -> int -val parse : Cerb_location.t -> string -> t - -val id : string -> t +val make : Cerb_location.t -> string -> t -val is_str : String.t -> t -> bool +val equal_string : String.t -> t -> bool val subst : 'a -> 'b -> 'b diff --git a/backend/cn/lib/indexTerms.ml b/backend/cn/lib/indexTerms.ml index 3212a1978..669b1aa10 100644 --- a/backend/cn/lib/indexTerms.ml +++ b/backend/cn/lib/indexTerms.ml @@ -1,7 +1,5 @@ module BT = BaseTypes module CF = Cerb_frontend -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) include Terms let equal = equal_annot BT.equal @@ -17,27 +15,22 @@ module Surface = struct type t = BaseTypes.Surface.t annot - let compare = Terms.compare_annot BaseTypes.Surface.compare + let compare = compare_annot BaseTypes.Surface.compare - let proj = Terms.map_annot BaseTypes.Surface.proj + let proj = map_annot BaseTypes.Surface.proj - let inj x = Terms.map_annot BaseTypes.Surface.inj x + let inj x = map_annot BaseTypes.Surface.inj x end -let basetype : 'a. 'a annot -> 'a = function IT (_, bt, _) -> bt +let get_bt : 'a. 'a annot -> 'a = function IT (_, bt, _) -> bt -(* TODO rename this get_bt *) -let bt = basetype +let get_term (IT (t, _, _)) = t -(* TODO rename this get_term *) -let term (IT (t, _, _)) = t +let get_loc (IT (_, _, l)) = l -(* TODO rename this get_loc *) -let loc (IT (_, _, l)) = l +let pp ?(prec = 0) = pp ~prec -let pp ?(prec = 0) = Terms.pp ~prec - -let pp_with_typf f it = Pp.typ (pp it) (f (bt it)) +let pp_with_typf f it = Pp.typ (pp it) (f (get_bt it)) let pp_with_typ = pp_with_typf BT.pp @@ -63,14 +56,14 @@ let rec bound_by_pattern (Pat (pat_, bt, _)) = List.concat_map (fun (_id, pat) -> bound_by_pattern pat) args -let rec free_vars_bts (it : 'a annot) : BT.t SymMap.t = - match term it with - | Const _ -> SymMap.empty - | Sym s -> SymMap.singleton s (bt it) +let rec free_vars_bts (it : 'a annot) : BT.t Sym.Map.t = + match get_term it with + | Const _ -> Sym.Map.empty + | Sym s -> Sym.Map.singleton s (get_bt it) | Unop (_uop, t1) -> free_vars_bts t1 | Binop (_bop, t1, t2) -> free_vars_bts_list [ t1; t2 ] | ITE (t1, t2, t3) -> free_vars_bts_list [ t1; t2; t3 ] - | EachI ((_, (s, _), _), t) -> SymMap.remove s (free_vars_bts t) + | EachI ((_, (s, _), _), t) -> Sym.Map.remove s (free_vars_bts t) | Tuple ts -> free_vars_bts_list ts | NthTuple (_, t) -> free_vars_bts t | Struct (_tag, members) -> free_vars_bts_list (List.map snd members) @@ -84,9 +77,9 @@ let rec free_vars_bts (it : 'a annot) : BT.t SymMap.t = | ArrayShift { base; ct = _; index } -> free_vars_bts_list [ base; index ] | CopyAllocId { addr; loc } -> free_vars_bts_list [ addr; loc ] | HasAllocId loc -> free_vars_bts_list [ loc ] - | SizeOf _t -> SymMap.empty - | OffsetOf (_tag, _member) -> SymMap.empty - | Nil _bt -> SymMap.empty + | SizeOf _t -> Sym.Map.empty + | OffsetOf (_tag, _member) -> Sym.Map.empty + | Nil _bt -> Sym.Map.empty | Cons (t1, t2) -> free_vars_bts_list [ t1; t2 ] | Head t -> free_vars_bts t | Tail t -> free_vars_bts t @@ -99,23 +92,25 @@ let rec free_vars_bts (it : 'a annot) : BT.t SymMap.t = | MapConst (_bt, t) -> free_vars_bts t | MapSet (t1, t2, t3) -> free_vars_bts_list [ t1; t2; t3 ] | MapGet (t1, t2) -> free_vars_bts_list [ t1; t2 ] - | MapDef ((s, _bt), t) -> SymMap.remove s (free_vars_bts t) + | MapDef ((s, _bt), t) -> Sym.Map.remove s (free_vars_bts t) | Apply (_pred, ts) -> free_vars_bts_list ts | Let ((nm, t1), t2) -> - SymMap.union + Sym.Map.union (fun _ bt1 bt2 -> assert (BT.equal bt1 bt2); Some bt1) (free_vars_bts t1) - (SymMap.remove nm (free_vars_bts t2)) + (Sym.Map.remove nm (free_vars_bts t2)) | Match (e, cases) -> let rec aux acc = function | [] -> acc | (pat, body) :: cases -> - let bound = SymSet.of_list (List.map fst (bound_by_pattern pat)) in - let more = SymMap.filter (fun x _ -> SymSet.mem x bound) (free_vars_bts body) in + let bound = Sym.Set.of_list (List.map fst (bound_by_pattern pat)) in + let more = + Sym.Map.filter (fun x _ -> not (Sym.Set.mem x bound)) (free_vars_bts body) + in aux - (SymMap.union + (Sym.Map.union (fun _ bt1 bt2 -> assert (BT.equal bt1 bt2); Some bt1) @@ -127,34 +122,34 @@ let rec free_vars_bts (it : 'a annot) : BT.t SymMap.t = | Constructor (_s, args) -> free_vars_bts_list (List.map snd args) -and free_vars_bts_list : 'a annot list -> BT.t SymMap.t = +and free_vars_bts_list : 'a annot list -> BT.t Sym.Map.t = fun xs -> List.fold_left (fun ss t -> - SymMap.union + Sym.Map.union (fun _ bt1 bt2 -> assert (BT.equal bt1 bt2); Some bt1) ss (free_vars_bts t)) - SymMap.empty + Sym.Map.empty xs -let free_vars (it : 'a annot) : SymSet.t = - it |> free_vars_bts |> SymMap.bindings |> List.map fst |> SymSet.of_list +let free_vars (it : 'a annot) : Sym.Set.t = + it |> free_vars_bts |> Sym.Map.bindings |> List.map fst |> Sym.Set.of_list -let free_vars_ (t_ : 'a Terms.term) : SymSet.t = +let free_vars_ (t_ : 'a term) : Sym.Set.t = IT (t_, Unit, Locations.other "") |> free_vars_bts - |> SymMap.bindings + |> Sym.Map.bindings |> List.map fst - |> SymSet.of_list + |> Sym.Set.of_list -let free_vars_list (its : 'a annot list) : SymSet.t = - its |> free_vars_bts_list |> SymMap.bindings |> List.map fst |> SymSet.of_list +let free_vars_list (its : 'a annot list) : Sym.Set.t = + its |> free_vars_bts_list |> Sym.Map.bindings |> List.map fst |> Sym.Set.of_list type 'bt bindings = ('bt pattern * 'bt annot option) list @@ -169,7 +164,7 @@ let rec fold_ f binders acc = function | ITE (t1, t2, t3) -> fold_list f binders acc [ t1; t2; t3 ] | EachI ((_, (s, bt), _), t) -> (* TODO - add location information to binders *) - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in fold f (binders @ [ (Pat (PSym s, bt, here), None) ]) acc t | Tuple ts -> fold_list f binders acc ts | NthTuple (_, t) -> fold f binders acc t @@ -201,14 +196,14 @@ let rec fold_ f binders acc = function | MapGet (t1, t2) -> fold_list f binders acc [ t1; t2 ] | MapDef ((s, bt), t) -> (* TODO - add location information to binders *) - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in fold f (binders @ [ (Pat (PSym s, bt, here), None) ]) acc t | Apply (_pred, ts) -> fold_list f binders acc ts | Let ((nm, t1), t2) -> let acc' = fold f binders acc t1 in (* TODO - add location information to binders *) - let here = Locations.other __FUNCTION__ in - fold f (binders @ [ (Pat (PSym nm, basetype t1, here), Some t1) ]) acc' t2 + let here = Locations.other __LOC__ in + fold f (binders @ [ (Pat (PSym nm, get_bt t1, here), Some t1) ]) acc' t2 | Match (e, cases) -> (* TODO: check this is good *) let acc' = fold f binders acc e in @@ -259,15 +254,15 @@ let mentions_call f = fold_subterms (fun _binders acc it -> acc || is_call f it) let mentions_good ct = fold_subterms (fun _binders acc it -> acc || is_good ct it) false let preds_of t = - let add_p s = function IT (Apply (id, _), _, _) -> SymSet.add id s | _ -> s in - fold_subterms (fun _ -> add_p) SymSet.empty t + let add_p s = function IT (Apply (id, _), _, _) -> Sym.Set.add id s | _ -> s in + fold_subterms (fun _ -> add_p) Sym.Set.empty t let json it : Yojson.Safe.t = `String (Pp.plain (pp it)) let free_vars_with_rename = function | `Term t -> free_vars t - | `Rename s -> SymSet.singleton s + | `Rename s -> Sym.Set.singleton s let make_rename ~from ~to_ = Subst.make free_vars_with_rename [ (from, `Rename to_) ] @@ -283,7 +278,7 @@ let rec subst (su : [ `Term of t | `Rename of Sym.t ] Subst.t) (IT (it, bt, loc) | Sym sym -> (match List.assoc_opt Sym.equal sym su.replace with | Some (`Term after) -> - if BT.equal bt (basetype after) then + if BT.equal bt (get_bt after) then () else failwith @@ -335,7 +330,7 @@ let rec subst (su : [ `Term of t | `Rename of Sym.t ] Subst.t) (IT (it, bt, loc) IT (MapDef ((s, abt), subst su body), bt, loc) | Apply (name, args) -> IT (Apply (name, List.map (subst su) args), bt, loc) | Let ((name, t1), t2) -> - if SymSet.mem substitute_lets_flag su.flags then ( + if Sym.Set.mem substitute_lets_flag su.flags then ( let t1 = subst su t1 in subst (Subst.add free_vars_with_rename (name, `Term t1) su) t2) else ( @@ -356,7 +351,7 @@ and alpha_rename s body = and suitably_alpha_rename syms s body = - if SymSet.mem s syms then + if Sym.Set.mem s syms then alpha_rename s body else (s, body) @@ -386,7 +381,7 @@ and suitably_alpha_rename_pattern su (Pat (pat_, bt, loc), body) = let substitute_lets = - let flags = SymSet.of_list [ substitute_lets_flag ] in + let flags = Sym.Set.of_list [ substitute_lets_flag ] in subst { (make_subst []) with flags } @@ -397,7 +392,7 @@ let is_z = function IT (Const (Z z), _bt, _loc) -> Some z | _ -> None let is_z_ it = Option.is_some (is_z it) let get_num_z it = - match term it with + match get_term it with | Const (Z _) -> is_z it | Const (Bits (info, z)) -> Some (BT.normalise_to_range info z) | _ -> None @@ -512,7 +507,7 @@ let const_ctype_ ct loc = IT (Const (CType_const ct), BT.CType, loc) (* cmp_op *) let lt_ (it, it') loc = - if BT.equal (bt it) (bt it') then + if BT.equal (get_bt it) (get_bt it') then () else failwith ("lt_: type mismatch: " ^ Pp.plain (Pp.list pp_with_typ [ it; it' ])); @@ -520,7 +515,7 @@ let lt_ (it, it') loc = let le_ (it, it') loc = - if BT.equal (bt it) (bt it') then + if BT.equal (get_bt it) (get_bt it') then () else failwith ("le_: type mismatch: " ^ Pp.plain (Pp.list pp_with_typ [ it; it' ])); @@ -547,14 +542,14 @@ let or_ its loc = vargs_binop (bool_ false loc) (Tools.curry (fun p -> or2_ p lo let impl_ (it, it') loc = IT (Binop (Implies, it, it'), BT.Bool, loc) -let not_ it loc = IT (Unop (Not, it), bt it, loc) +let not_ it loc = IT (Unop (Not, it), get_bt it, loc) -let bw_compl_ it loc = IT (Unop (BW_Compl, it), bt it, loc) +let bw_compl_ it loc = IT (Unop (BW_Compl, it), get_bt it, loc) -let ite_ (it, it', it'') loc = IT (ITE (it, it', it''), bt it', loc) +let ite_ (it, it', it'') loc = IT (ITE (it, it', it''), get_bt it', loc) let eq_ (it, it') loc = - if BT.equal (bt it) (bt it') then + if BT.equal (get_bt it) (get_bt it') then () else failwith ("eq_: type mismatch: " ^ Pp.plain (Pp.list pp_with_typ [ it; it' ])); @@ -583,7 +578,7 @@ let or_sterm_ its loc = vargs_binop (bool_sterm_ true loc) (Tools.curry (fun p -> or2_sterm_ p loc)) its -let let_ ((nm, x), y) loc = IT (Let ((nm, x), y), basetype y, loc) +let let_ ((nm, x), y) loc = IT (Let ((nm, x), y), get_bt y, loc) (* let disperse_not_ it = *) (* match term it with *) @@ -596,55 +591,55 @@ let eachI_ (i1, (s, bt), i2) t loc = IT (EachI ((i1, (s, bt), i2), t), BT.Bool, (* let existsI_ (i1, s, i2) t = not_ (eachI_ (i1, s, i2) (not_ t)) *) (* arith_op *) -let negate it loc = IT (Unop (Negate, it), bt it, loc) +let negate it loc = IT (Unop (Negate, it), get_bt it, loc) -let add_ (it, it') loc = IT (Binop (Add, it, it'), bt it, loc) +let add_ (it, it') loc = IT (Binop (Add, it, it'), get_bt it, loc) -let sub_ (it, it') loc = IT (Binop (Sub, it, it'), bt it, loc) +let sub_ (it, it') loc = IT (Binop (Sub, it, it'), get_bt it, loc) let mul_ (it, it') loc = - if BT.equal (bt it) (bt it') then - IT (Binop (Mul, it, it'), bt it, loc) + if BT.equal (get_bt it) (get_bt it') then + IT (Binop (Mul, it, it'), get_bt it, loc) else failwith ("mul_: type mismatch: " ^ Pp.plain (Pp.list pp_with_typ [ it; it' ])) -let mul_no_smt_ (it, it') loc = IT (Binop (MulNoSMT, it, it'), bt it, loc) +let mul_no_smt_ (it, it') loc = IT (Binop (MulNoSMT, it, it'), get_bt it, loc) -let div_ (it, it') loc = IT (Binop (Div, it, it'), bt it, loc) +let div_ (it, it') loc = IT (Binop (Div, it, it'), get_bt it, loc) -let div_no_smt_ (it, it') loc = IT (Binop (DivNoSMT, it, it'), bt it, loc) +let div_no_smt_ (it, it') loc = IT (Binop (DivNoSMT, it, it'), get_bt it, loc) -let exp_ (it, it') loc = IT (Binop (Exp, it, it'), bt it, loc) +let exp_ (it, it') loc = IT (Binop (Exp, it, it'), get_bt it, loc) -let exp_no_smt_ (it, it') loc = IT (Binop (ExpNoSMT, it, it'), bt it, loc) +let exp_no_smt_ (it, it') loc = IT (Binop (ExpNoSMT, it, it'), get_bt it, loc) -let rem_ (it, it') loc = IT (Binop (Rem, it, it'), bt it, loc) +let rem_ (it, it') loc = IT (Binop (Rem, it, it'), get_bt it, loc) -let rem_no_smt_ (it, it') loc = IT (Binop (RemNoSMT, it, it'), bt it, loc) +let rem_no_smt_ (it, it') loc = IT (Binop (RemNoSMT, it, it'), get_bt it, loc) -let mod_ (it, it') loc = IT (Binop (Mod, it, it'), bt it, loc) +let mod_ (it, it') loc = IT (Binop (Mod, it, it'), get_bt it, loc) -let mod_no_smt_ (it, it') loc = IT (Binop (ModNoSMT, it, it'), bt it, loc) +let mod_no_smt_ (it, it') loc = IT (Binop (ModNoSMT, it, it'), get_bt it, loc) -let divisible_ (it, it') loc = eq_ (mod_ (it, it') loc, int_lit_ 0 (bt it) loc) loc +let divisible_ (it, it') loc = eq_ (mod_ (it, it') loc, int_lit_ 0 (get_bt it) loc) loc let rem_f_ (it, it') loc = mod_ (it, it') loc -let min_ (it, it') loc = IT (Binop (Min, it, it'), bt it, loc) +let min_ (it, it') loc = IT (Binop (Min, it, it'), get_bt it, loc) -let max_ (it, it') loc = IT (Binop (Max, it, it'), bt it, loc) +let max_ (it, it') loc = IT (Binop (Max, it, it'), get_bt it, loc) let intToReal_ it loc = IT (Cast (Real, it), BT.Real, loc) let realToInt_ it loc = IT (Cast (Integer, it), BT.Integer, loc) -let arith_binop op (it, it') loc = IT (Binop (op, it, it'), bt it, loc) +let arith_binop op (it, it') loc = IT (Binop (op, it, it'), get_bt it, loc) -let arith_unop op it loc = IT (Unop (op, it), bt it, loc) +let arith_unop op it loc = IT (Unop (op, it), get_bt it, loc) let arith_binop_check op (it, it') loc = - assert (BT.equal (bt it) (bt it')); + assert (BT.equal (get_bt it) (get_bt it')); arith_binop op (it, it') loc @@ -671,7 +666,7 @@ let ( %> ) t t' = gt_ (t, t') let ( %>= ) t t' = ge_ (t, t') (* tuple_op *) -let tuple_ its loc = IT (Tuple its, BT.Tuple (List.map bt its), loc) +let tuple_ its loc = IT (Tuple its, BT.Tuple (List.map get_bt its), loc) let nthTuple_ ~item_bt (n, it) loc = IT (NthTuple (n, it), item_bt, loc) @@ -682,24 +677,24 @@ let member_ ~member_bt (it, member) loc = IT (StructMember (it, member), member_ let ( %. ) struct_decls t member = let tag = - match bt t with + match get_bt t with | BT.Struct tag -> tag | _ -> Cerb_debug.error "illtyped index term. not a struct" in let member_bt = match - List.assoc_opt Id.equal member (Memory.member_types (SymMap.find tag struct_decls)) + List.assoc_opt Id.equal member (Memory.member_types (Sym.Map.find tag struct_decls)) with | Some sct -> Memory.bt_of_sct sct | None -> Cerb_debug.error - ("struct " ^ Sym.pp_string tag ^ " does not have member " ^ Id.pp_string member) + ("struct " ^ Sym.pp_string tag ^ " does not have member " ^ Id.get_string member) in member_ ~member_bt (t, member) let record_ members loc = - IT (Record members, BT.Record (List.map (fun (s, t) -> (s, basetype t)) members), loc) + IT (Record members, BT.Record (List.map (fun (s, t) -> (s, get_bt t)) members), loc) let recordMember_ ~member_bt (t, member) loc = @@ -717,7 +712,9 @@ let gtPointer_ (it, it') loc = ltPointer_ (it', it) loc let gePointer_ (it, it') loc = lePointer_ (it', it) loc -let cast_ bt' it loc = if BT.equal bt' (bt it) then it else IT (Cast (bt', it), bt', loc) +let cast_ bt' it loc = + if BT.equal bt' (get_bt it) then it else IT (Cast (bt', it), bt', loc) + let uintptr_const_ n loc = num_lit_ n Memory.uintptr_bt loc @@ -725,10 +722,18 @@ let uintptr_int_ n loc = uintptr_const_ (Z.of_int n) loc (* for integer-mode: z_ n *) let addr_ it loc = - assert (BT.equal (bt it) (Loc ())); + assert (BT.equal (get_bt it) (Loc ())); cast_ Memory.uintptr_bt it loc +let upper_bound addr ct loc = + let range_size ct = + let size = Memory.size_of_ctype ct in + num_lit_ (Z.of_int size) Memory.uintptr_bt loc + in + add_ (addr, range_size ct) loc + + (* for integer-mode: cast_ Integer it *) let allocId_ it loc = cast_ Alloc_id it loc @@ -767,26 +772,26 @@ let pointer_offset_ (base, offset) loc = (* list_op *) let nil_ ~item_bt loc = IT (Nil item_bt, BT.List item_bt, loc) -let cons_ (it, it') loc = IT (Cons (it, it'), bt it', loc) +let cons_ (it, it') loc = IT (Cons (it, it'), get_bt it', loc) let list_ ~item_bt its ~nil_loc = let rec aux = function | [] -> IT (Nil item_bt, BT.List item_bt, nil_loc) - | x :: xs -> IT (Cons (x, aux xs), BT.List item_bt, loc x) + | x :: xs -> IT (Cons (x, aux xs), BT.List item_bt, get_loc x) in aux its let head_ ~item_bt it loc = IT (Head it, item_bt, loc) -let tail_ it loc = IT (Tail it, bt it, loc) +let tail_ it loc = IT (Tail it, get_bt it, loc) -let nthList_ (n, it, d) loc = IT (NthList (n, it, d), bt d, loc) +let nthList_ (n, it, d) loc = IT (NthList (n, it, d), get_bt d, loc) let array_to_list_ (arr, i, len) bt loc = IT (ArrayToList (arr, i, len), bt, loc) let rec dest_list it = - match term it with + match get_term it with | Nil _bt -> Some [] | Cons (x, xs) -> Option.map (fun ys -> x :: ys) (dest_list xs) (* TODO: maybe include Tail, if we ever actually use it? *) @@ -798,7 +803,7 @@ let setMember_ (it, it') loc = IT (Binop (SetMember, it, it'), BT.Bool, loc) (* let setUnion_ its = IT (Set_op (SetUnion its), bt (hd its)) * let setIntersection_ its = IT (Set_op (SetIntersection its), bt (hd its)) *) -let setDifference_ (it, it') loc = IT (Binop (SetDifference, it, it'), bt it, loc) +let setDifference_ (it, it') loc = IT (Binop (SetDifference, it, it'), get_bt it, loc) let subset_ (it, it') loc = IT (Binop (Subset, it, it'), BT.Bool, loc) @@ -812,8 +817,8 @@ let wrapI_ (ity, arg) loc = let alignedI_ ~t ~align loc = - assert (BT.equal (bt t) (Loc ())); - assert (BT.equal Memory.uintptr_bt (bt align)); + assert (BT.equal (get_bt t) (Loc ())); + assert (BT.equal Memory.uintptr_bt (get_bt align)); IT (Aligned { t; align }, BT.Bool, loc) @@ -821,14 +826,16 @@ let aligned_ (t, ct) loc = alignedI_ ~t ~align:(int_lit_ (Memory.align_of_ctype ct) Memory.uintptr_bt loc) loc -let const_map_ index_bt t loc = IT (MapConst (index_bt, t), BT.Map (index_bt, bt t), loc) +let const_map_ index_bt t loc = + IT (MapConst (index_bt, t), BT.Map (index_bt, get_bt t), loc) + -let map_set_ t1 (t2, t3) loc = IT (MapSet (t1, t2, t3), bt t1, loc) +let map_set_ t1 (t2, t3) loc = IT (MapSet (t1, t2, t3), get_bt t1, loc) let map_get_ v arg loc = - match bt v with + match get_bt v with | BT.Map (dt, rbt) -> - if BT.equal dt (bt arg) then + if BT.equal dt (get_bt arg) then () else failwith ("mag_get_: type mismatch: " ^ Pp.plain (Pp.list pp_with_typ [ v; arg ])); @@ -836,7 +843,9 @@ let map_get_ v arg loc = | _ -> Cerb_debug.error "illtyped index term" -let map_def_ (s, abt) body loc = IT (MapDef ((s, abt), body), BT.Map (abt, bt body), loc) +let map_def_ (s, abt) body loc = + IT (MapDef ((s, abt), body), BT.Map (abt, get_bt body), loc) + let make_array_ ~index_bt ~item_bt items (* assumed all of item_bt *) loc = let base_value = const_map_ index_bt (default_ item_bt loc) loc in @@ -871,17 +880,17 @@ let fresh_same bt symbol' loc = (symbol, sym_ (symbol, bt, loc)) -let def_ sym e loc = eq_ (sym_ (sym, bt e, loc), e) loc +let def_ sym e loc = eq_ (sym_ (sym, get_bt e, loc), e) loc let in_range within (min, max) loc = and_ [ le_ (min, within) loc; le_ (within, max) loc ] loc let rec in_z_range within (min_z, max_z) loc = - match bt within with + match get_bt within with | BT.Integer -> in_range within (z_ min_z loc, z_ max_z loc) loc | BT.Bits (sign, sz) -> - let the_bt = bt within in + let the_bt = get_bt within in let min_possible, max_possible = BT.bits_range (sign, sz) in let min_c = if Z.leq min_z min_possible then @@ -981,7 +990,7 @@ let value_check mode (struct_layouts : Memory.struct_decls) ct about loc = (); (* let partiality = partiality_check_array ~length:n ~item_ct about in *) let ix_bt = - match BT.is_map_bt (bt about) with + match BT.is_map_bt (get_bt about) with | Some (abt, _) -> abt | _ -> failwith ("value_check: argument not a map: " ^ Pp.plain (pp_with_typ about)) @@ -991,7 +1000,7 @@ let value_check mode (struct_layouts : Memory.struct_decls) ct about loc = () else Pp.warn - (Locations.other __FUNCTION__) + (Locations.other __LOC__) (Pp.item "unexpected type of array arg" (pp_with_typ about)) in let i_s, i = fresh ix_bt loc in @@ -1007,7 +1016,7 @@ let value_check mode (struct_layouts : Memory.struct_decls) ct about loc = let member_it = member_ ~member_bt (about, member) loc in Some (aux mct member_it) | None -> None) - (SymMap.find tag struct_layouts)) + (Sym.Map.find tag struct_layouts)) loc | Function _ -> Cerb_debug.error "todo: function types" in @@ -1022,7 +1031,7 @@ let good_pointer = value_check_pointer `Good let promote_to_compare it it' loc = let res_bt = - match (bt it, bt it') with + match (get_bt it, get_bt it') with | bt1, bt2 when BT.equal bt1 bt2 -> bt1 | BT.Bits (_, sz), BT.Bits (_, sz') -> BT.Bits (BT.Signed, sz + sz' + 2) | _ -> @@ -1030,20 +1039,20 @@ let promote_to_compare it it' loc = ("promote to compare: impossible types to compare: " ^ Pp.plain (Pp.list pp_with_typ [ it; it' ])) in - let cast it = if BT.equal (bt it) res_bt then it else cast_ res_bt it loc in + let cast it = if BT.equal (get_bt it) res_bt then it else cast_ res_bt it loc in (cast it, cast it') let nth_array_to_list_fact n xs d = - let here = Locations.other __FUNCTION__ in - match term xs with + let here = Locations.other __LOC__ in + match get_term xs with | ArrayToList (arr, i, len) -> let lt_n_len = lt_ (promote_to_compare n len here) here in let lhs = nthList_ (n, xs, d) here in let rhs = ite_ - ( and_ [ le_ (int_lit_ 0 (bt n) here, n) here; lt_n_len ] here, - map_get_ arr (add_ (i, cast_ (bt i) n here) here) here, + ( and_ [ le_ (int_lit_ 0 (get_bt n) here, n) here; lt_n_len ] here, + map_get_ arr (add_ (i, cast_ (get_bt i) n here) here) here, d ) here in @@ -1059,35 +1068,37 @@ let rec wrap_bindings_match bs default_v v = (match wrap_bindings_match bindings default_v v with | None -> None | Some v2 -> - let pat_ss = SymSet.of_list (List.map fst (bound_by_pattern pat)) in - if SymSet.is_empty (SymSet.inter pat_ss (free_vars v2)) then + let pat_ss = Sym.Set.of_list (List.map fst (bound_by_pattern pat)) in + if Sym.Set.is_empty (Sym.Set.inter pat_ss (free_vars v2)) then Some v2 else ( match x with | None -> None | Some match_e -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in Some (IT ( Match ( match_e, - [ (pat, v2); (Pat (PWild, basetype match_e, here), default_v) ] ), - basetype v2, + [ (pat, v2); (Pat (PWild, get_bt match_e, here), default_v) ] ), + get_bt v2, here )))) let nth_array_to_list_facts (binders_terms : (t_bindings * t) list) = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let nths = List.filter_map (fun (bs, it) -> - match term it with NthList (n, xs, d) -> Some (bs, (n, d, bt xs)) | _ -> None) + match get_term it with + | NthList (n, xs, d) -> Some (bs, (n, d, get_bt xs)) + | _ -> None) binders_terms in let arr_lists = List.filter_map (fun (bs, it) -> - match term it with ArrayToList _ -> Some (bs, (it, bt it)) | _ -> None) + match get_term it with ArrayToList _ -> Some (bs, (it, get_bt it)) | _ -> None) binders_terms in List.concat_map @@ -1197,3 +1208,113 @@ let rec map_term_post (f : t -> t) (it : t) : t = | Cast (bt', it') -> Cast (bt', loop it') in f (IT (it_, bt, here)) + + +module Bounds = struct + let get_lower_bound_opt ((x, bt) : Sym.sym * BT.t) (it : t) : t option = + let rec aux (it : t) : t option = + match it with + | IT (Binop (EQ, IT (Sym x', _, _), tm2), _, _) + | IT (Binop (EQ, tm2, IT (Sym x', _, _)), _, _) -> + if Sym.equal x x' then Some tm2 else None + | IT (Binop (LE, it', IT (Sym x', _, _)), _, _) when Sym.equal x x' -> Some it' + | IT (Binop (LT, it', IT (Sym x', _, _)), _, _) when Sym.equal x x' -> + Some + (IT + ( Binop (Add, it', num_lit_ Z.one bt Cerb_location.unknown), + bt, + Cerb_location.unknown )) + | IT (Binop (And, tm1, tm2), _, _) -> + (match (aux tm1, aux tm2) with + | None, None -> None + | None, it' | it', None -> it' + | Some tm1, Some tm2 -> + Some (IT (Binop (Max, tm1, tm2), bt, Cerb_location.unknown))) + | IT (Binop (Or, tm1, tm2), _, _) -> + (match (aux tm1, aux tm2) with + | None, None | None, _ | _, None -> None + | Some tm1, Some tm2 -> + Some (IT (Binop (Min, tm1, tm2), bt, Cerb_location.unknown))) + | _ -> None + in + aux it + + + let get_lower_bound ((x, bt) : Sym.sym * BT.t) (it : t) : t = + let min = + match bt with + | Bits (sign, sz) -> fst (BT.bits_range (sign, sz)) + | _ -> + Cerb_colour.with_colour + (fun () -> + print_endline + Pp.( + plain + (!^"unsupported type" + ^^^ squotes (BT.pp bt) + ^^^ !^"in permission" + ^^^ squotes (pp it) + ^^^ !^"at" + ^^^ Locations.pp (get_loc it)))) + (); + exit 2 + in + get_lower_bound_opt (x, bt) it + |> Option.value ~default:(num_lit_ min bt Cerb_location.unknown) + + + let get_upper_bound_opt ((x, bt) : Sym.sym * BT.t) (it : t) : t option = + let rec aux (it : t) : t option = + match it with + | IT (Binop (EQ, IT (Sym x', _, _), tm2), _, _) + | IT (Binop (EQ, tm2, IT (Sym x', _, _)), _, _) -> + if Sym.equal x x' then Some tm2 else None + | IT (Binop (LE, IT (Sym x', _, _), it'), _, _) when Sym.equal x x' -> Some it' + | IT (Binop (LT, IT (Sym x', _, _), it'), _, _) when Sym.equal x x' -> + Some + (IT + ( Binop (Sub, it', num_lit_ Z.one bt Cerb_location.unknown), + bt, + Cerb_location.unknown )) + | IT (Binop (And, tm1, tm2), _, _) -> + (match (aux tm1, aux tm2) with + | None, None -> None + | None, it' | it', None -> it' + | Some tm1, Some tm2 -> + Some (IT (Binop (Min, tm1, tm2), bt, Cerb_location.unknown))) + | IT (Binop (Or, tm1, tm2), _, _) -> + (match (aux tm1, aux tm2) with + | None, None | None, _ | _, None -> None + | Some tm1, Some tm2 -> + Some (IT (Binop (Max, tm1, tm2), bt, Cerb_location.unknown))) + | _ -> None + in + aux it + + + let get_upper_bound ((x, bt) : Sym.sym * BT.t) (it : t) : t = + let max = + match bt with + | Bits (sign, sz) -> snd (BT.bits_range (sign, sz)) + | _ -> + Cerb_colour.with_colour + (fun () -> + print_endline + Pp.( + plain + (!^"unsupported type" + ^^^ squotes (BT.pp bt) + ^^^ !^"in permission" + ^^^ squotes (pp it) + ^^^ !^"at" + ^^^ Locations.pp (get_loc it)))) + (); + exit 2 + in + get_upper_bound_opt (x, bt) it + |> Option.value ~default:(num_lit_ max bt Cerb_location.unknown) + + + let get_bounds ((x, bt) : Sym.sym * BT.t) (it : t) : t * t = + (get_lower_bound (x, bt) it, get_upper_bound (x, bt) it) +end diff --git a/backend/cn/lib/interval.ml b/backend/cn/lib/interval.ml index f2dd90264..26ba989c7 100644 --- a/backend/cn/lib/interval.ml +++ b/backend/cn/lib/interval.ml @@ -184,18 +184,18 @@ end module Solver = struct module IT = IndexTerms - module RT = ResourceTypes + module RT = Request open Terms open BaseTypes let interval_for (eval : IT.t -> IT.t option) q tyi = - let is_q i = match IT.term i with Sym y -> Sym.equal q y | _ -> false in + let is_q i = match IT.get_term i with Sym y -> Sym.equal q y | _ -> false in let eval_k e = - if IT.SymSet.mem q (IT.free_vars e) then + if Sym.Set.mem q (IT.free_vars e) then None else Option.bind (eval e) (fun v -> - match IT.term v with + match IT.get_term v with | Const (Z z) -> Some z | Const (Bits (_, z)) -> Some z | _ -> None) @@ -214,7 +214,7 @@ module Solver = struct let do_compl i = mkI (Intervals.complement i) in let do_impl i j = Intervals.union (do_compl i) j in let rec interval p = - match IT.term p with + match IT.get_term p with | Const (Bool true) -> Some tyi | Const (Bool false) -> Some (Intervals.of_interval Interval.empty) | Unop (Not, term) -> Option.map do_compl (interval term) @@ -244,12 +244,12 @@ module Solver = struct | _ -> None - let simp_rt eval (rt : RT.resource_type) : RT.resource_type = + let simp_rt eval (rt : RT.t) : RT.t = match rt with | RT.P _ -> rt | RT.Q qpred -> let x, t = qpred.q in - let loc = IT.loc qpred.permission in + let loc = IT.get_loc qpred.permission in (match supported_type loc t with | None -> rt | Some (tyi, k) -> diff --git a/backend/cn/lib/interval.mli b/backend/cn/lib/interval.mli index 569671875..7fec76865 100644 --- a/backend/cn/lib/interval.mli +++ b/backend/cn/lib/interval.mli @@ -98,8 +98,8 @@ end module Solver : sig module IT = IndexTerms - module RT = ResourceTypes + module RT = Request (** Try to simplify a resource type *) - val simp_rt : (IT.t -> IT.t option) -> RT.resource_type -> RT.resource_type + val simp_rt : (IT.t -> IT.t option) -> RT.t -> RT.t end diff --git a/backend/cn/lib/lemmata.ml b/backend/cn/lib/lemmata.ml index 4728398d9..69234c122 100644 --- a/backend/cn/lib/lemmata.ml +++ b/backend/cn/lib/lemmata.ml @@ -1,19 +1,16 @@ module IT = IndexTerms module BT = BaseTypes -module LS = LogicalSorts module LRT = LogicalReturnTypes module RT = ReturnTypes module AT = ArgumentTypes module LAT = LogicalArgumentTypes module TE = TypeErrors module Loc = Locations -module LF = LogicalFunctions +module LF = Definition.Function module LC = LogicalConstraints module IdSet = Set.Make (Id) module StringSet = Set.Make (String) module StringMap = Map.Make (String) -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) module StringList = struct type t = string list @@ -35,33 +32,34 @@ module PrevDefs = struct { present : Sym.t list StringListMap.t; defs : Pp.document list IntMap.t; dt_params : (IT.t * Id.t * Sym.t) list; - failures : TypeErrors.type_error list + failures : TypeErrors.t list } let init_t = { present = StringListMap.empty; defs = IntMap.empty; dt_params = []; failures = [] } +end +module PrevDefsMonad = struct + type 'a t = PrevDefs.t -> ('a * PrevDefs.t) Or_TypeError.t - type 'a m = t -> ('a * t, TypeErrors.t) Result.t - - let return (x : 'a) : 'a m = fun st -> Result.Ok (x, st) + let return (x : 'a) : 'a t = fun st -> Result.Ok (x, st) - let bind (x : 'a m) (f : 'a -> 'b m) : 'b m = + let bind (x : 'a t) (f : 'a -> 'b t) : 'b t = fun st -> match x st with Result.Error e -> Result.Error e | Result.Ok (xv, st) -> f xv st - let get : t m = fun st -> Result.Ok (st, st) + let get : PrevDefs.t t = fun st -> Result.Ok (st, st) - let set (st : t) : unit m = fun _ -> Result.Ok ((), st) + let set (st : PrevDefs.t) : unit t = fun _ -> Result.Ok ((), st) - let upd (f : t -> t) : unit m = bind get (fun st -> set (f st)) + let upd (f : PrevDefs.t -> PrevDefs.t) : unit t = bind get (fun st -> set (f st)) - let get_section section (st : t) = + let get_section section (st : PrevDefs.t) = match IntMap.find_opt section st.defs with None -> [] | Some docs -> docs - let add_to_section section doc (st : t) = + let add_to_section section doc (st : PrevDefs.t) = let current = get_section section st in let defs = IntMap.add section (doc :: current) st.defs in { st with defs } @@ -90,9 +88,10 @@ module PrevDefs = struct return ()) end -module PrevMonad = Effectful.Make (PrevDefs) +open Effectful.Make (PrevDefsMonad) + +open PrevDefsMonad open PrevDefs -open PrevMonad let with_reset_dt_params f = let@ st = get in @@ -165,7 +164,7 @@ let try_coerce_res (ftyp : AT.lemmat) = | LRT.Constraint (lc, info, t) -> LRT.Constraint (lc, info, erase_res r t) | LRT.Resource ((name, (re, bt)), ((loc, _) as info), t) -> let arg_name, arg_re = r in - if ResourceTypes.alpha_equivalent arg_re re then ( + if Request.alpha_equivalent arg_re re then ( Pp.debug 2 (lazy (Pp.item "erasing" (Sym.pp name))); LRT.subst (IT.make_subst [ (name, IT.sym_ (arg_name, bt, loc)) ]) t) else @@ -260,7 +259,7 @@ let struct_layout_field_bts xs = let get_struct_xs struct_decls tag = - match SymMap.find_opt tag struct_decls with + match Sym.Map.find_opt tag struct_decls with | Some def -> struct_layout_field_bts def | None -> fail "undefined struct" (Sym.pp tag) @@ -301,16 +300,17 @@ let add_list_mono_datatype (bt, nm) global = let bt_name = Sym.pp_string (Option.get (BT.is_datatype_bt bt)) in let nil = Sym.fresh_named ("Nil_of_" ^ bt_name) in let cons = Sym.fresh_named ("Cons_of_" ^ bt_name) in - let hd = Id.id ("hd_of_" ^ bt_name) in - let tl = Id.id ("tl_of_" ^ bt_name) in + let here = Locations.other __LOC__ in + let hd = Id.make here ("hd_of_" ^ bt_name) in + let tl = Id.make here ("tl_of_" ^ bt_name) in let mems = [ (hd, bt); (tl, BT.Datatype nm) ] in let datatypes = - SymMap.add nm Dt.{ constrs = [ nil; cons ]; all_params = mems } global.datatypes + Sym.Map.add nm Dt.{ constrs = [ nil; cons ]; all_params = mems } global.datatypes in let datatype_constrs = global.datatype_constrs - |> SymMap.add nil Dt.{ params = []; datatype_tag = nm } - |> SymMap.add cons Dt.{ params = mems; datatype_tag = nm } + |> Sym.Map.add nil Dt.{ params = []; datatype_tag = nm } + |> Sym.Map.add cons Dt.{ params = mems; datatype_tag = nm } in { global with datatypes; datatype_constrs } @@ -326,13 +326,13 @@ let monomorphise_dt_lists global = let dt_lists = function BT.List (BT.Datatype sym) -> Some sym | _ -> None in let module Dt = BT.Datatype in let all_dt_types = - SymMap.fold + Sym.Map.fold (fun _ dt_info ss -> List.filter_map dt_lists (List.map snd dt_info.Dt.all_params) @ ss) global.Global.datatypes [] in - let uniq_dt_types = SymSet.elements (SymSet.of_list all_dt_types) in + let uniq_dt_types = Sym.Set.elements (Sym.Set.of_list all_dt_types) in let new_sym sym = (sym, Sym.fresh_named ("list_of_" ^ Sym.pp_string sym)) in let new_syms = List.map new_sym uniq_dt_types in let list_mono = List.map (fun (s1, s2) -> (BT.Datatype s1, s2)) new_syms in @@ -340,12 +340,12 @@ let monomorphise_dt_lists global = let map_bt bt = Option.value ~default:bt (mono_list_bt list_mono bt) in let map_mems = List.map (fun (nm, bt) -> (nm, map_bt bt)) in let datatypes = - SymMap.map + Sym.Map.map (fun info -> Dt.{ info with all_params = map_mems info.all_params }) global.Global.datatypes in let datatype_constrs = - SymMap.map + Sym.Map.map (fun info -> Dt.{ info with params = map_mems info.params }) global.Global.datatype_constrs in @@ -364,7 +364,7 @@ let rec new_nm s nms i = let alpha_rename_if_pp_same s body = let vs = IT.free_vars body in let other_nms = - List.filter (fun sym -> not (Sym.equal sym s)) (SymSet.elements vs) + List.filter (fun sym -> not (Sym.equal sym s)) (Sym.Set.elements vs) |> List.map Sym.pp_string in if List.exists (String.equal (Sym.pp_string s)) other_nms then ( @@ -383,8 +383,8 @@ let alpha_rename_if_pp_same s body = let it_adjust (global : Global.t) it = let rec f t = - let loc = IT.loc t in - match IT.term t with + let loc = IT.get_loc t in + match IT.get_term t with | IT.Binop (And, x1, x2) -> let xs = List.map f [ x1; x2 ] |> List.partition IT.is_true |> snd in IT.and_ xs loc @@ -402,16 +402,16 @@ let it_adjust (global : Global.t) it = | IT.EachI ((i1, (s, bt), i2), x) -> let x = f x in let s, x, vs = alpha_rename_if_pp_same s x in - if not (SymSet.mem s vs) then ( + if not (Sym.Set.mem s vs) then ( assert (i1 <= i2); x) else IT.eachI_ (i1, (s, bt), i2) x loc | IT.Apply (name, args) -> - let open LogicalFunctions in - let def = SymMap.find name global.logical_functions in - (match (def.definition, def.emit_coq) with - | Def body, false -> f (open_fun def.args body args) + let open Definition.Function in + let def = Sym.Map.find name global.logical_functions in + (match (def.body, def.emit_coq) with + | Def body, false -> f (open_ def.args body args) | _ -> t) | IT.Good (ct, t2) -> if Option.is_some (Sctypes.is_struct_ctype ct) then @@ -430,7 +430,7 @@ let it_adjust (global : Global.t) it = let nm, y, vs = alpha_rename_if_pp_same nm y in if Option.is_some (IT.is_sym x) then IT.subst (IT.make_subst [ (nm, x) ]) y - else if not (SymSet.mem nm vs) then + else if not (Sym.Set.mem nm vs) then y else IT.let_ ((nm, x), y) loc @@ -442,10 +442,10 @@ let it_adjust (global : Global.t) it = let fun_prop_ret (global : Global.t) nm = - match SymMap.find_opt nm global.logical_functions with + match Sym.Map.find_opt nm global.logical_functions with | None -> fail "fun_prop_ret: not found" (Sym.pp nm) | Some def -> - let open LogicalFunctions in + let open Definition.Function in BaseTypes.equal BaseTypes.Bool def.return_bt && StringSet.mem (Sym.pp_string nm) prop_funs @@ -601,7 +601,7 @@ and ensure_datatype (global : Global.t) (list_mono : list_mono) loc dt_tag = (lazy (let open Pp in let cons_line dt_tag c_tag = - let info = SymMap.find c_tag global.datatype_constrs in + let info = Sym.Map.find c_tag global.datatype_constrs in let@ argTs = ListM.mapM (fun (_, bt) -> bt_to_coq2 bt) info.params in return (!^" | " @@ -612,7 +612,7 @@ and ensure_datatype (global : Global.t) (list_mono : list_mono) loc dt_tag = let@ dt_eqs = ListM.mapM (fun dt_tag -> - let info = SymMap.find dt_tag global.datatypes in + let info = Sym.Map.find dt_tag global.datatypes in let@ c_lines = ListM.mapM (cons_line dt_tag) info.constrs in return (!^" " @@ -637,12 +637,12 @@ and ensure_datatype (global : Global.t) (list_mono : list_mono) loc dt_tag = let ensure_datatype_member global list_mono loc dt_tag (mem_tag : Id.t) bt = let@ () = ensure_datatype global list_mono loc dt_tag in - let op_nm = Sym.pp_string dt_tag ^ "_" ^ Id.pp_string mem_tag in - let dt_info = SymMap.find dt_tag global.Global.datatypes in + let op_nm = Sym.pp_string dt_tag ^ "_" ^ Id.get_string mem_tag in + let dt_info = Sym.Map.find dt_tag global.Global.datatypes in let inf = (loc, Pp.typ (Pp.string "datatype acc for") (Sym.pp dt_tag)) in let@ bt_doc = bt_to_coq global list_mono inf bt in let cons_line c = - let c_info = SymMap.find c global.Global.datatype_constrs in + let c_info = Sym.Map.find c global.Global.datatype_constrs in let pats = List.map (fun (m2, _) -> @@ -665,7 +665,7 @@ let ensure_datatype_member global list_mono loc dt_tag (mem_tag : Id.t) bt = let@ () = gen_ensure 0 - [ "types"; "datatype acc"; Sym.pp_string dt_tag; Id.pp_string mem_tag ] + [ "types"; "datatype acc"; Sym.pp_string dt_tag; Id.get_string mem_tag ] (lazy (let open Pp in let eline = [ !^" end" ] in @@ -684,10 +684,10 @@ let ensure_datatype_member global list_mono loc dt_tag (mem_tag : Id.t) bt = let ensure_single_datatype_member global list_mono loc dt_tag (mem_tag : Id.t) bt = let@ () = ensure_datatype global list_mono loc dt_tag in - let op_nm = Sym.pp_string dt_tag ^ "_" ^ Id.pp_string mem_tag in - let dt_info = SymMap.find dt_tag global.Global.datatypes in + let op_nm = Sym.pp_string dt_tag ^ "_" ^ Id.get_string mem_tag in + let dt_info = Sym.Map.find dt_tag global.Global.datatypes in let cons_line c = - let c_info = SymMap.find c global.Global.datatype_constrs in + let c_info = Sym.Map.find c global.Global.datatype_constrs in let pats = List.map (fun (m2, _) -> @@ -703,7 +703,7 @@ let ensure_single_datatype_member global list_mono loc dt_tag (mem_tag : Id.t) b let@ () = gen_ensure 0 - [ "types"; "datatype acc"; Sym.pp_string dt_tag; Id.pp_string mem_tag ] + [ "types"; "datatype acc"; Sym.pp_string dt_tag; Id.get_string mem_tag ] (lazy (let inf = (loc, Pp.typ (Pp.string "datatype acc for") (Sym.pp dt_tag)) in let@ bt_doc = bt_to_coq global list_mono inf bt in @@ -729,7 +729,7 @@ let ensure_list global list_mono _loc bt = | None -> fail "ensure_list: not a monomorphised list" (BT.pp bt) in let dt_sym = Option.get (BT.is_datatype_bt dt_bt) in - let dt_info = SymMap.find dt_sym global.Global.datatypes in + let dt_info = Sym.Map.find dt_sym global.Global.datatypes in let nil_nm, cons_nm = match dt_info.constrs with [ nil; cons ] -> (nil, cons) | _ -> assert false in @@ -781,10 +781,10 @@ let ensure_tuple_op is_upd nm (ix, l) = let ensure_pred global list_mono loc name aux = - let open LogicalFunctions in - let def = SymMap.find name global.Global.logical_functions in + let open Definition.Function in + let def = Sym.Map.find name global.Global.logical_functions in let inf = (loc, Pp.typ (Pp.string "pred") (Sym.pp name)) in - match def.definition with + match def.body with | Uninterp -> gen_ensure 1 @@ -838,7 +838,7 @@ let ensure_struct_mem is_good global list_mono loc ct aux = (lazy (let@ ty = bt_to_coq global list_mono (loc, Pp.string op_nm) bt in let x = Pp.parens (Pp.typ (Pp.string "x") ty) in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let x_it = IT.sym_ (Sym.fresh_named "x", bt, here) in let@ rhs = aux (it_adjust global (IT.good_value global.struct_decls ct x_it here)) @@ -851,14 +851,14 @@ let ensure_struct_mem is_good global list_mono loc ct aux = let rec unfold_if_possible global it = let open IT in - let open LogicalFunctions in + let open Definition.Function in match it with | IT (IT.Apply (name, args), _, _) -> let def = Option.get (Global.get_logical_function_def global name) in - (match def.definition with + (match def.body with | Rec_Def _ -> it | Uninterp -> it - | Def body -> unfold_if_possible global (open_fun def.args body args)) + | Def body -> unfold_if_possible global (open_ def.args body args)) | _ -> it @@ -872,7 +872,7 @@ let mk_forall global list_mono loc sym bt doc = let add_dt_param_counted (it, (m_nm : Id.t)) = let@ st = get in let idx = List.length st.dt_params in - let sym = Sym.fresh_named (Id.pp_string m_nm ^ "_" ^ Int.to_string idx) in + let sym = Sym.fresh_named (Id.get_string m_nm ^ "_" ^ Int.to_string idx) in let@ () = add_dt_param (it, m_nm, sym) in return sym @@ -932,7 +932,7 @@ let it_to_coq loc global list_mono it = let abinop s x y = parensM (build [ aux x; rets s; aux y ]) in let enc_prop = Option.is_none comp_bool in let with_is_true x = - if enc_prop && BaseTypes.equal (IT.bt t) BaseTypes.Bool then + if enc_prop && BaseTypes.equal (IT.get_bt t) BaseTypes.Bool then f_appM "Is_true" [ x ] else x @@ -952,7 +952,7 @@ let it_to_coq loc global list_mono it = *) f in - match IT.term t with + match IT.get_term t with | IT.Sym sym -> return (Sym.pp sym) | IT.Const l -> (match l with @@ -962,7 +962,7 @@ let it_to_coq loc global list_mono it = | _ -> do_fail "const") | IT.Unop (op, x) -> norm_bv_op - (IT.bt t) + (IT.get_bt t) (match op with | IT.Not -> f_appM (if enc_prop then "~" else "negb") [ aux x ] | IT.BW_FFS_NoSMT -> f_appM "CN_Lib.find_first_set_z" [ aux x ] @@ -970,7 +970,7 @@ let it_to_coq loc global list_mono it = | _ -> do_fail "unary op") | IT.Binop (op, x, y) -> norm_bv_op - (IT.bt t) + (IT.get_bt t) (match op with | Add -> abinop "+" x y | Sub -> abinop "-" x y @@ -1030,48 +1030,48 @@ let it_to_coq loc global list_mono it = return (parens enc) | IT.MapSet (m, x, y) -> let@ () = ensure_fun_upd () in - let@ e = eq_of (IT.bt x) in + let@ e = eq_of (IT.get_bt x) in f_appM "fun_upd" [ return e; aux m; aux x; aux y ] | IT.MapGet (m, x) -> parensM (build [ aux m; aux x ]) | IT.RecordMember (t, m) -> - let flds = BT.record_bt (IT.bt t) in + let flds = BT.record_bt (IT.get_bt t) in if List.length flds == 1 then aux t else ( let ix = find_tuple_element Id.equal m Id.pp (List.map fst flds) in - let@ op_nm = ensure_tuple_op false (Id.pp_string m) ix in + let@ op_nm = ensure_tuple_op false (Id.get_string m) ix in parensM (build [ rets op_nm; aux t ])) | IT.RecordUpdate ((t, m), x) -> - let flds = BT.record_bt (IT.bt t) in + let flds = BT.record_bt (IT.get_bt t) in if List.length flds == 1 then aux x else ( let ix = find_tuple_element Id.equal m Id.pp (List.map fst flds) in - let@ op_nm = ensure_tuple_op true (Id.pp_string m) ix in + let@ op_nm = ensure_tuple_op true (Id.get_string m) ix in parensM (build [ rets op_nm; aux t; aux x ])) | IT.Record mems -> let@ xs = ListM.mapM aux (List.map snd mems) in parensM (return (flow (comma ^^ break 1) xs)) | IT.StructMember (t, m) -> - let tag = BaseTypes.struct_bt (IT.bt t) in + let tag = BaseTypes.struct_bt (IT.get_bt t) in let mems, _bts = get_struct_xs global.struct_decls tag in let ix = find_tuple_element Id.equal m Id.pp mems in if List.length mems == 1 then aux t else - let@ op_nm = ensure_tuple_op false (Id.pp_string m) ix in + let@ op_nm = ensure_tuple_op false (Id.get_string m) ix in parensM (build [ rets op_nm; aux t ]) | IT.StructUpdate ((t, m), x) -> - let tag = BaseTypes.struct_bt (IT.bt t) in + let tag = BaseTypes.struct_bt (IT.get_bt t) in let mems, _bts = get_struct_xs global.struct_decls tag in let ix = find_tuple_element Id.equal m Id.pp mems in if List.length mems == 1 then aux x else - let@ op_nm = ensure_tuple_op true (Id.pp_string m) ix in + let@ op_nm = ensure_tuple_op true (Id.get_string m) ix in parensM (build [ rets op_nm; aux t; aux x ]) | IT.Cast (cbt, t) -> - (match (IT.bt t, cbt) with + (match (IT.get_bt t, cbt) with | Integer, Loc () -> aux t | Loc (), Integer -> aux t | source, target -> @@ -1094,16 +1094,16 @@ let it_to_coq loc global list_mono it = let@ op_nm = ensure_struct_mem true global list_mono loc ct aux in parensM (build [ rets op_nm; aux t2 ]) | IT.Constructor (nm, id_args) -> - let info = SymMap.find nm global.datatype_constrs in + let info = Sym.Map.find nm global.datatype_constrs in let comp = Some (t, "datatype contents") in let@ () = ensure_datatype global list_mono loc info.datatype_tag in (* assuming here that the id's are in canonical order *) parensM (build ([ return (Sym.pp nm) ] @ List.map (f comp) (List.map snd id_args))) | IT.NthList (n, xs, d) -> - let@ _, _, dest = ensure_list global list_mono loc (IT.bt xs) in + let@ _, _, dest = ensure_list global list_mono loc (IT.get_bt xs) in parensM (build [ rets "CN_Lib.nth_list_z"; return dest; aux n; aux xs; aux d ]) | IT.ArrayToList (arr, i, len) -> - let@ nil, cons, _ = ensure_list global list_mono loc (IT.bt t) in + let@ nil, cons, _ = ensure_list global list_mono loc (IT.get_bt t) in parensM (build [ rets "CN_Lib.array_to_list"; @@ -1330,9 +1330,9 @@ let do_re_retype mu_file trusted_funs prev_mode pred_defs pre_retype_mu_file = | `CallByReference -> let prev_cut = let open Retype.Old in - let info2 = Pmap.filter (fun fsym _ -> SymSet.mem fsym trusted_funs) + let info2 = Pmap.filter (fun fsym _ -> Sym.Set.mem fsym trusted_funs) pre_retype_mu_file.mu_funinfo in - let funs2 = Pmap.filter (fun fsym _ -> SymSet.mem fsym trusted_funs) + let funs2 = Pmap.filter (fun fsym _ -> Sym.Set.mem fsym trusted_funs) pre_retype_mu_file.mu_funs in { pre_retype_mu_file with mu_funs = funs2; mu_funinfo = info2 } in @@ -1372,8 +1372,8 @@ let generate (global : Global.t) directions (lemmata : (Sym.t * (Loc.t * AT.lemm "skipping trusted fun with resource" (Sym.pp_string x.sym ^ ": " ^ Option.get x.scan_res.res)) skip; - (* let fun_info = List.fold_right (fun (s, def) m -> SymMap.add s def m) *) - (* mu_file.mu_logical_predicates SymMap.empty in *) + (* let fun_info = List.fold_right (fun (s, def) m -> Sym.Map.add s def m) *) + (* mu_file.mu_logical_predicates Sym.Map.empty in *) (* let struct_decls = get_struct_decls mu_file in *) (* let global = Global.{ctxt.Context.global with struct_decls} in *) let list_mono, global = monomorphise_dt_lists global in diff --git a/backend/cn/lib/logicalArgumentTypes.ml b/backend/cn/lib/logicalArgumentTypes.ml index c634fa4c5..b6ff88f17 100644 --- a/backend/cn/lib/logicalArgumentTypes.ml +++ b/backend/cn/lib/logicalArgumentTypes.ml @@ -1,15 +1,12 @@ open Locations module BT = BaseTypes module IT = IndexTerms -module LS = LogicalSorts -module RET = ResourceTypes +module Req = Request module LC = LogicalConstraints -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) type 'i t = | Define of (Sym.t * IT.t) * info * 'i t - | Resource of (Sym.t * (RET.t * BT.t)) * info * 'i t + | Resource of (Sym.t * (Req.t * BT.t)) * info * 'i t | Constraint of LC.t * info * 'i t | I of 'i @@ -33,7 +30,7 @@ let rec subst i_subst = let name, t = suitably_alpha_rename i_subst substitution.relevant name t in Define ((name, it), info, aux substitution t) | Resource ((name, (re, bt)), info, t) -> - let re = RET.subst substitution re in + let re = Req.subst substitution re in let name, t = suitably_alpha_rename i_subst substitution.relevant name t in let t = aux substitution t in Resource ((name, (re, bt)), info, t) @@ -54,7 +51,7 @@ and alpha_rename i_subst s t = and suitably_alpha_rename i_subst syms s t = - if SymSet.mem s syms then + if Sym.Set.mem s syms then alpha_rename i_subst s t else (s, t) @@ -62,18 +59,18 @@ and suitably_alpha_rename i_subst syms s t = let free_vars_bts i_free_vars_bts = let union = - SymMap.union (fun _ bt1 bt2 -> + Sym.Map.union (fun _ bt1 bt2 -> assert (BT.equal bt1 bt2); Some bt1) in let rec aux = function | Define ((s, it), _info, t) -> let it_vars = IT.free_vars_bts it in - let t_vars = SymMap.remove s (aux t) in + let t_vars = Sym.Map.remove s (aux t) in union it_vars t_vars | Resource ((s, (re, _bt)), _info, t) -> - let re_vars = RET.free_vars_bts re in - let t_vars = SymMap.remove s (aux t) in + let re_vars = Req.free_vars_bts re in + let t_vars = Sym.Map.remove s (aux t) in union re_vars t_vars | Constraint (lc, _info, t) -> let lc_vars = LC.free_vars_bts lc in @@ -88,16 +85,16 @@ let free_vars i_free_vars = let rec aux = function | Define ((s, it), _info, t) -> let it_vars = IT.free_vars it in - let t_vars = SymSet.remove s (aux t) in - SymSet.union it_vars t_vars + let t_vars = Sym.Set.remove s (aux t) in + Sym.Set.union it_vars t_vars | Resource ((s, (re, _bt)), _info, t) -> - let re_vars = RET.free_vars re in - let t_vars = SymSet.remove s (aux t) in - SymSet.union re_vars t_vars + let re_vars = Req.free_vars re in + let t_vars = Sym.Set.remove s (aux t) in + Sym.Set.union re_vars t_vars | Constraint (lc, _info, t) -> let lc_vars = LC.free_vars lc in let t_vars = aux t in - SymSet.union lc_vars t_vars + Sym.Set.union lc_vars t_vars | I i -> i_free_vars i in aux @@ -129,7 +126,7 @@ let rec pp_aux i_pp = function | Define ((name, it), _info, t) -> group (!^"let" ^^^ Sym.pp name ^^^ equals ^^^ IT.pp it ^^ semi) :: pp_aux i_pp t | Resource ((name, (re, _bt)), _info, t) -> - group (!^"take" ^^^ Sym.pp name ^^^ equals ^^^ RET.pp re ^^ semi) :: pp_aux i_pp t + group (!^"take" ^^^ Sym.pp name ^^^ equals ^^^ Req.pp re ^^ semi) :: pp_aux i_pp t | Constraint (lc, _info, t) -> let op = equals ^^ rangle () in group (LC.pp lc ^^^ op) :: pp_aux i_pp t @@ -154,11 +151,11 @@ let alpha_unique ss = match at with | Define ((name, it), info, t) -> let name, t = rename_if ss name t in - let t = f (SymSet.add name ss) t in + let t = f (Sym.Set.add name ss) t in Define ((name, it), info, t) | Resource ((name, (re, bt)), info, t) -> let name, t = rename_if ss name t in - let t = f (SymSet.add name ss) t in + let t = f (Sym.Set.add name ss) t in Resource ((name, (re, bt)), info, f ss t) | Constraint (lc, info, t) -> Constraint (lc, info, f ss t) | I i -> I (RT.alpha_unique ss i) @@ -167,13 +164,14 @@ let alpha_unique ss = let binders i_binders i_subst = + let here = Locations.other __LOC__ in let rec aux = function | Define ((s, it), _, t) -> let s, t = alpha_rename i_subst s t in - (Id.id (Sym.pp_string s), IT.bt it) :: aux t + (Id.make here (Sym.pp_string s), IT.get_bt it) :: aux t | Resource ((s, (_, bt)), _, t) -> let s, t = alpha_rename i_subst s t in - (Id.id (Sym.pp_string s), bt) :: aux t + (Id.make here (Sym.pp_string s), bt) :: aux t | Constraint (_, _, t) -> aux t | I i -> i_binders i in @@ -224,7 +222,7 @@ let dtree dtree_i = Dnode (pp_ctor "Define", [ Dleaf (Sym.pp s); IT.dtree it; aux t ]) | Resource ((s, (rt, bt)), _, t) -> Dnode - (pp_ctor "Resource", [ Dleaf (Sym.pp s); RET.dtree rt; Dleaf (BT.pp bt); aux t ]) + (pp_ctor "Resource", [ Dleaf (Sym.pp s); Req.dtree rt; Dleaf (BT.pp bt); aux t ]) | Constraint (lc, _, t) -> Dnode (pp_ctor "Constraint", [ LC.dtree lc; aux t ]) | I i -> Dnode (pp_ctor "I", [ dtree_i i ]) in diff --git a/backend/cn/lib/logicalConstraints.ml b/backend/cn/lib/logicalConstraints.ml index a979399a4..6ab216949 100644 --- a/backend/cn/lib/logicalConstraints.ml +++ b/backend/cn/lib/logicalConstraints.ml @@ -1,19 +1,17 @@ module IT = IndexTerms module BT = BaseTypes -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) open Pp -type logical_constraint = +type t = | T of IT.t | Forall of (Sym.t * BT.t) * IT.t [@@deriving eq, ord] -type t = logical_constraint +module Set = Set.Make (struct + type nonrec t = t -let equal = equal_logical_constraint - -let compare = compare_logical_constraint + let compare = compare + end) let pp = function | T it -> IT.pp it @@ -34,12 +32,12 @@ let subst_ su c = subst (IT.make_subst su) c let free_vars_bts = function | T c -> IT.free_vars_bts c - | Forall ((s, _), body) -> SymMap.remove s (IT.free_vars_bts body) + | Forall ((s, _), body) -> Sym.Map.remove s (IT.free_vars_bts body) let free_vars = function | T c -> IT.free_vars c - | Forall ((s, _), body) -> SymSet.remove s (IT.free_vars body) + | Forall ((s, _), body) -> Sym.Set.remove s (IT.free_vars body) let alpha_equivalent lc lc' = @@ -58,8 +56,6 @@ let alpha_equivalent lc lc' = | _ -> false -let t_ it = T it - let forall_ (s, bt) it = Forall ((s, bt), it) let is_sym_lhs_equality = function diff --git a/backend/cn/lib/logicalConstraints.mli b/backend/cn/lib/logicalConstraints.mli new file mode 100644 index 000000000..671e0eb04 --- /dev/null +++ b/backend/cn/lib/logicalConstraints.mli @@ -0,0 +1,39 @@ +type t = + | T of IndexTerms.t + | Forall of (Sym.t * BaseTypes.t) * IndexTerms.t + +val equal : t -> t -> bool + +val compare : t -> t -> int + +module Set : Set.S with type elt = t + +val pp : t -> Pp.document + +val json : t -> Yojson.Safe.t + +val subst : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> t -> t + +val subst_ : (Sym.t * IndexTerms.t) list -> t -> t + +val free_vars_bts : t -> BaseTypes.t Sym.Map.t + +val free_vars : t -> Sym.Set.t + +val alpha_equivalent : t -> t -> bool + +val forall_ : Sym.t * BaseTypes.t -> IndexTerms.t -> t + +val is_sym_lhs_equality : t -> (Sym.t * IndexTerms.t) option + +val is_sym_equality : t -> (Sym.t * Sym.t) option + +val is_equality : t -> ((IndexTerms.t * IndexTerms.t) * bool) option + +val equates_to : IndexTerms.t -> t -> IndexTerms.t option + +val dtree : t -> Cerb_frontend.Pp_ast.doc_tree + +val is_forall : t -> bool + +val is_interesting : t -> bool diff --git a/backend/cn/lib/logicalFunctions.ml b/backend/cn/lib/logicalFunctions.ml deleted file mode 100644 index 38751c045..000000000 --- a/backend/cn/lib/logicalFunctions.ml +++ /dev/null @@ -1,110 +0,0 @@ -module Loc = Locations -module IT = IndexTerms -module BT = BaseTypes -module AT = ArgumentTypes -module LAT = LogicalArgumentTypes -open IndexTerms -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) - -type def_or_uninterp = - | Def of IT.t - | Rec_Def of IT.t - | Uninterp - -let subst_def_or_uninterp subst = function - | Def it -> Def (IT.subst subst it) - | Rec_Def it -> Rec_Def (IT.subst subst it) - | Uninterp -> Uninterp - - -type definition = - { loc : Locations.t; - args : (Sym.t * LogicalSorts.t) list; - (* If the predicate is supposed to get used in a quantified form, one of the arguments - has to be the index/quantified variable. For now at least. *) - return_bt : BT.t; - emit_coq : bool; - definition : def_or_uninterp - } - -let is_recursive def = - match def.definition with Rec_Def _ -> true | Def _ -> false | Uninterp -> false - - -let given_to_solver def = - match def.definition with Rec_Def _ -> false | Def _ -> true | Uninterp -> false - - -let pp_args xs = - Pp.flow_map - (Pp.break 1) - (fun (sym, typ) -> Pp.parens (Pp.typ (Sym.pp sym) (BT.pp typ))) - xs - - -let pp_def nm def = - let open Pp in - nm - ^^ colon - ^^^ pp_args def.args - ^^ colon - ^/^ - match def.definition with - | Uninterp -> !^"uninterpreted" - | Def t -> IT.pp t - | Rec_Def t -> !^"rec:" ^^^ IT.pp t - - -let open_fun def_args def_body args = - let su = make_subst (List.map2 (fun (s, _) arg -> (s, arg)) def_args args) in - IT.subst su def_body - - -let unroll_once def args = - match def.definition with - | Def body | Rec_Def body -> Some (open_fun def.args body args) - | Uninterp -> None - - -let try_open_fun def args = - match def.definition with - | Def body -> Some (open_fun def.args body args) - | Rec_Def _ -> None - | Uninterp -> None - - -(* let try_open_fun_to_term def name args = Option.map (fun body -> Body.to_term - def.return_bt body ) (try_open_fun def name args) *) - -(* let add_unfolds_to_terms preds terms = let rec f acc t = match IT.term t with | - IT.Apply (name, ts) -> let def = SymMap.find name preds in begin match - try_open_fun_to_term def name ts with | None -> acc | Some t2 -> f (t2 :: acc) t2 end | - _ -> acc in IT.fold_list (fun _ acc t -> f acc t) [] terms terms *) - -(* (\* Check for cycles in the logical predicate graph, which would cause *) -(* the system to loop trying to unfold them. Predicates whose definition *) -(* are marked with Rec_Def aren't checked, as cycles there are expected. *\) *) -(* let cycle_check (defs : definition SymMap.t) = *) -(* let def_preds nm = *) -(* let def = SymMap.find nm defs in *) -(* begin match def.definition with *) -(* | Def t -> SymSet.elements (IT.preds_of (Body.to_term def.return_bt t)) *) -(* | _ -> [] *) -(* end *) -(* in *) -(* let rec search known_ok = function *) -(* | [] -> None *) -(* | (nm, Some path) :: q -> if SymSet.mem nm known_ok *) -(* then search known_ok q *) -(* else if List.exists (Sym.equal nm) path *) -(* then Some (List.rev path @ [nm]) *) -(* else *) -(* let deps = List.map (fun p -> (p, Some (nm :: path))) (def_preds nm) in *) -(* search known_ok (deps @ [(nm, None)] @ q) *) -(* | (nm, None) :: q -> search (SymSet.add nm known_ok) q *) -(* in search SymSet.empty (List.map (fun (p, _) -> (p, Some [])) (SymMap.bindings - defs)) *) - -(*Extensibility hook. For now, all functions are displayed as "interesting" in error reporting*) -let is_interesting : definition -> bool = fun _ -> true diff --git a/backend/cn/lib/logicalReturnTypes.ml b/backend/cn/lib/logicalReturnTypes.ml index f305a14ba..445ca9303 100644 --- a/backend/cn/lib/logicalReturnTypes.ml +++ b/backend/cn/lib/logicalReturnTypes.ml @@ -1,7 +1,6 @@ open Locations -module SymSet = Set.Make (Sym) module BT = BaseTypes -module RT = ResourceTypes +module RT = Request module IT = IndexTerms module LC = LogicalConstraints @@ -55,27 +54,27 @@ and alpha_rename from t = and suitably_alpha_rename syms s t = - if SymSet.mem s syms then + if Sym.Set.mem s syms then alpha_rename s t else (s, t) let rec bound = function - | Define ((s, _), _, lrt) -> SymSet.add s (bound lrt) - | Resource ((s, _), _, lrt) -> SymSet.add s (bound lrt) + | Define ((s, _), _, lrt) -> Sym.Set.add s (bound lrt) + | Resource ((s, _), _, lrt) -> Sym.Set.add s (bound lrt) | Constraint (_, _, lrt) -> bound lrt - | I -> SymSet.empty + | I -> Sym.Set.empty let alpha_unique ss = let rec f ss = function | Resource ((name, (re, bt)), info, t) -> - let t = f (SymSet.add name ss) t in + let t = f (Sym.Set.add name ss) t in let name, t = suitably_alpha_rename ss name t in Resource ((name, (re, bt)), info, t) | Define ((name, it), info, t) -> - let t = f (SymSet.add name ss) t in + let t = f (Sym.Set.add name ss) t in let name, t = suitably_alpha_rename ss name t in Define ((name, it), info, t) | Constraint (lc, info, t) -> Constraint (lc, info, f ss t) @@ -85,13 +84,14 @@ let alpha_unique ss = let binders = + let here = Locations.other __LOC__ in let rec aux = function | Define ((s, it), _, t) -> let s, t = alpha_rename s t in - (Id.id (Sym.pp_string s), IT.bt it) :: aux t + (Id.make here (Sym.pp_string s), IT.get_bt it) :: aux t | Resource ((s, (_, bt)), _, t) -> let s, t = alpha_rename s t in - (Id.id (Sym.pp_string s), bt) :: aux t + (Id.make here (Sym.pp_string s), bt) :: aux t | Constraint (_, _, t) -> aux t | I -> [] in @@ -100,11 +100,11 @@ let binders = let free_vars lrt = let rec f = function - | Define ((nm, it), _, t) -> SymSet.union (IT.free_vars it) (SymSet.remove nm (f t)) + | Define ((nm, it), _, t) -> Sym.Set.union (IT.free_vars it) (Sym.Set.remove nm (f t)) | Resource ((nm, (re, _)), _, t) -> - SymSet.union (RT.free_vars re) (SymSet.remove nm (f t)) - | Constraint (lc, _, t) -> SymSet.union (LogicalConstraints.free_vars lc) (f t) - | I -> SymSet.empty + Sym.Set.union (RT.free_vars re) (Sym.Set.remove nm (f t)) + | Constraint (lc, _, t) -> Sym.Set.union (LogicalConstraints.free_vars lc) (f t) + | I -> Sym.Set.empty in f lrt diff --git a/backend/cn/lib/logicalSorts.ml b/backend/cn/lib/logicalSorts.ml deleted file mode 100644 index da77f5c88..000000000 --- a/backend/cn/lib/logicalSorts.ml +++ /dev/null @@ -1,12 +0,0 @@ -module Loc = Locations -module SymSet = Set.Make (Sym) - -type t = BaseTypes.t - -type sort = t - -let pp bt = BaseTypes.pp bt - -let json bt : Yojson.Safe.t = BaseTypes.json bt - -let equal t1 t2 = BaseTypes.equal t1 t2 diff --git a/backend/cn/lib/memory.ml b/backend/cn/lib/memory.ml index 373a0bf09..785df6cfd 100644 --- a/backend/cn/lib/memory.ml +++ b/backend/cn/lib/memory.ml @@ -1,6 +1,5 @@ module CF = Cerb_frontend module BT = BaseTypes -module SymMap = Map.Make (Sym) module IM = struct include CF.Impl_mem @@ -80,7 +79,7 @@ type struct_layout = struct_piece list type struct_decl = struct_layout -type struct_decls = struct_layout SymMap.t +type struct_decls = struct_layout Sym.Map.t let members = List.filter_map (fun { member_or_padding; _ } -> Option.map fst member_or_padding) diff --git a/backend/cn/lib/mucore.ml b/backend/cn/lib/mucore.ml index 66d7dd68f..e5d915fa2 100644 --- a/backend/cn/lib/mucore.ml +++ b/backend/cn/lib/mucore.ml @@ -86,7 +86,7 @@ let fun_param_types mu_fun = let evaluate_fun mu_fun args = let module IT = IndexTerms in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in match mu_fun with | F_params_length -> (match args with @@ -322,8 +322,7 @@ type 'TY globs = type 'i arguments_l = | Define of (Sym.t * IndexTerms.t) * Locations.info * 'i arguments_l - | Resource of - (Sym.t * (ResourceTypes.t * BaseTypes.t)) * Locations.info * 'i arguments_l + | Resource of (Sym.t * (Request.t * BaseTypes.t)) * Locations.info * 'i arguments_l | Constraint of LogicalConstraints.t * Locations.info * 'i arguments_l | I of 'i @@ -352,7 +351,7 @@ let dtree_of_arguments_l dtree_i = | Resource ((s, (rt, bt)), _, t) -> Dnode ( pp_ctor "Resource", - [ Dleaf (Sym.pp s); ResourceTypes.dtree rt; Dleaf (BaseTypes.pp bt); aux t ] ) + [ Dleaf (Sym.pp s); Request.dtree rt; Dleaf (BaseTypes.pp bt); aux t ] ) | Constraint (lc, _, t) -> Dnode (pp_ctor "Constraint", [ LogicalConstraints.dtree lc; aux t ]) | I i -> Dnode (pp_ctor "I", [ dtree_i i ]) @@ -380,6 +379,9 @@ type 'TY label_def = * 'TY expr arguments * Cerb_frontend.Annot.annot list * parse_ast_label_spec + * [ `Loop of Locations.t * Locations.t ] +(*first loc is condition, second is whole loop*) +(*loop condition location, for executable checking *) type trusted = | Trusted of Locations.t @@ -424,10 +426,10 @@ type 'TY file = globs : (Sym.t * 'TY globs) list; funs : (Sym.t, 'TY fun_map_decl) Pmap.map; extern : Cerb_frontend.Core.extern_map; - stdlib_syms : Set.Make(Sym).t; + stdlib_syms : Sym.Set.t; mk_functions : function_to_convert list; - resource_predicates : (Sym.t * ResourcePredicates.definition) list; - logical_predicates : (Sym.t * LogicalFunctions.definition) list; + resource_predicates : (Sym.t * Definition.Predicate.t) list; + logical_predicates : (Sym.t * Definition.Function.t) list; datatypes : (Sym.t * datatype) list; lemmata : (Sym.t * (Locations.t * ArgumentTypes.lemmat)) list; call_funinfo : (Sym.t, Sctypes.c_concrete_sig) Pmap.map @@ -439,9 +441,7 @@ let empty_file : 'TY file = globs = []; funs = Pmap.empty Sym.compare; extern = Pmap.empty Id.compare; - stdlib_syms = - (let open Set.Make (Sym) in - empty); + stdlib_syms = Sym.Set.empty; mk_functions = []; resource_predicates = []; logical_predicates = []; diff --git a/backend/cn/lib/mucore.mli b/backend/cn/lib/mucore.mli index d0734931c..3d69d39c6 100644 --- a/backend/cn/lib/mucore.mli +++ b/backend/cn/lib/mucore.mli @@ -232,8 +232,7 @@ type 'TY globs = type 'i arguments_l = | Define of (Sym.t * IndexTerms.t) * Locations.info * 'i arguments_l - | Resource of - (Sym.t * (ResourceTypes.t * BaseTypes.t)) * Locations.info * 'i arguments_l + | Resource of (Sym.t * (Request.t * BaseTypes.t)) * Locations.info * 'i arguments_l | Constraint of LogicalConstraints.t * Locations.info * 'i arguments_l | I of 'i @@ -250,12 +249,12 @@ val mConstraints 'a arguments_l val mResource - : (Sym.t * (ResourceTypes.t * BaseTypes.t)) * Locations.info -> + : (Sym.t * (Request.t * BaseTypes.t)) * Locations.info -> 'a arguments_l -> 'a arguments_l val mResources - : ((Sym.t * (ResourceTypes.t * BaseTypes.t)) * Locations.info) list -> + : ((Sym.t * (Request.t * BaseTypes.t)) * Locations.info) list -> 'a arguments_l -> 'a arguments_l @@ -283,6 +282,9 @@ type 'TY label_def = * 'TY expr arguments * Cerb_frontend.Annot.annot list * parse_ast_label_spec + * [ `Loop of Locations.t * Locations.t ] +(*first loc is condition, second is whole loop*) +(*loop condition location, for executable checking *) type trusted = | Trusted of Locations.t @@ -327,10 +329,10 @@ type 'TY file = globs : (Sym.t * 'TY globs) list; funs : (Sym.t, 'TY fun_map_decl) Pmap.map; extern : Cerb_frontend.Core.extern_map; - stdlib_syms : Set.Make(Sym).t; + stdlib_syms : Sym.Set.t; mk_functions : function_to_convert list; - resource_predicates : (Sym.t * ResourcePredicates.definition) list; - logical_predicates : (Sym.t * LogicalFunctions.definition) list; + resource_predicates : (Sym.t * Definition.Predicate.t) list; + logical_predicates : (Sym.t * Definition.Function.t) list; datatypes : (Sym.t * datatype) list; lemmata : (Sym.t * (Locations.t * ArgumentTypes.lemmat)) list; call_funinfo : (Sym.t, Sctypes.c_concrete_sig) Pmap.map diff --git a/backend/cn/lib/resultat.ml b/backend/cn/lib/or_TypeError.ml similarity index 93% rename from backend/cn/lib/resultat.ml rename to backend/cn/lib/or_TypeError.ml index 096da12aa..cc3f03bde 100644 --- a/backend/cn/lib/resultat.ml +++ b/backend/cn/lib/or_TypeError.ml @@ -2,8 +2,6 @@ type 'a t = ('a, TypeErrors.t) Result.t -type 'a m = 'a t - let return (a : 'a) : 'a t = Ok a let fail (e : 'e) : 'a t = Error e diff --git a/backend/cn/lib/pack.ml b/backend/cn/lib/pack.ml index 3b4536192..d0a548040 100644 --- a/backend/cn/lib/pack.ml +++ b/backend/cn/lib/pack.ml @@ -1,19 +1,20 @@ -open IndexTerms -open ResourceTypes -open Resources -open ResourcePredicates +open Request +open Resource +open Definition open Memory module IT = IndexTerms module LAT = LogicalArgumentTypes +module LRT = LogicalReturnTypes +module LC = LogicalConstraints (* open Cerb_pp_prelude *) let resource_empty provable resource = - let loc = Cerb_location.other __FUNCTION__ in + let loc = Cerb_location.other __LOC__ in let constr = match resource with - | P _, _ -> LC.t_ (bool_ false loc) - | Q p, _ -> LC.forall_ p.q (not_ p.permission loc) + | P _, _ -> LC.T (IT.bool_ false loc) + | Q p, _ -> LC.forall_ p.q (IT.not_ p.permission loc) in match provable constr with | `True -> `Empty @@ -28,10 +29,11 @@ let unfolded_array loc init (ict, olength) pointer = pointer; q = (q_s, Memory.uintptr_bt); q_loc = loc; - step = uintptr_int_ (Memory.size_of_ctype ict) loc; + step = IT.uintptr_int_ (Memory.size_of_ctype ict) loc; iargs = []; permission = - and_ [ (uintptr_int_ 0 loc %<= q) loc; (q %< uintptr_int_ length loc) loc ] loc + IT.( + and_ [ (uintptr_int_ 0 loc %<= q) loc; (q %< uintptr_int_ length loc) loc ] loc) } @@ -43,10 +45,10 @@ let packing_ft loc global provable ret = | Owned ((Array (ict, olength) as ct), init) -> let qpred = unfolded_array loc init (ict, olength) ret.pointer in let o_s, o = IT.fresh_named (Memory.bt_of_sct ct) "value" loc in - let at = LAT.Resource ((o_s, (qpred, IT.bt o)), (loc, None), LAT.I o) in + let at = LAT.Resource ((o_s, (qpred, IT.get_bt o)), (loc, None), LAT.I o) in Some at | Owned (Struct tag, init) -> - let layout = SymMap.find tag global.Global.struct_decls in + let layout = Sym.Map.find tag global.Global.struct_decls in let lrt, value = List.fold_right (fun { offset; size; member_or_padding } (lrt, value) -> @@ -55,37 +57,38 @@ let packing_ft loc global provable ret = let request = P { name = Owned (mct, init); - pointer = memberShift_ (ret.pointer, tag, member) loc; + pointer = IT.memberShift_ (ret.pointer, tag, member) loc; iargs = [] } in let m_value_s, m_value = - IT.fresh_named (Memory.bt_of_sct mct) (Id.s member) loc + IT.fresh_named (Memory.bt_of_sct mct) (Id.get_string member) loc in - ( LRT.Resource ((m_value_s, (request, IT.bt m_value)), (loc, None), lrt), + ( LRT.Resource ((m_value_s, (request, IT.get_bt m_value)), (loc, None), lrt), (member, m_value) :: value ) | None -> let padding_ct = Sctypes.Array (Sctypes.char_ct, Some size) in let request = P { name = Owned (padding_ct, Uninit); - pointer = pointer_offset_ (ret.pointer, uintptr_int_ offset loc) loc; + pointer = + IT.pointer_offset_ (ret.pointer, IT.uintptr_int_ offset loc) loc; iargs = [] } in let padding_s, padding = IT.fresh_named (Memory.bt_of_sct padding_ct) "padding" loc in - ( LRT.Resource ((padding_s, (request, IT.bt padding)), (loc, None), lrt), + ( LRT.Resource ((padding_s, (request, IT.get_bt padding)), (loc, None), lrt), value )) layout (LRT.I, []) in - let at = LAT.of_lrt lrt (LAT.I (struct_ (tag, value) loc)) in + let at = LAT.of_lrt lrt (LAT.I (IT.struct_ (tag, value) loc)) in Some at | PName pn -> - let def = SymMap.find pn global.resource_predicates in - (match identify_right_clause provable def ret.pointer ret.iargs with + let def = Sym.Map.find pn global.resource_predicates in + (match Predicate.identify_right_clause provable def ret.pointer ret.iargs with | None -> None | Some right_clause -> Some right_clause.packing_ft)) | Q _ -> None @@ -97,7 +100,7 @@ let unpack_owned loc global (ct, init) pointer (O o) = | Void | Integer _ | Pointer _ | Function _ -> None | Array (ict, olength) -> Some [ (unfolded_array loc init (ict, olength) pointer, O o) ] | Struct tag -> - let layout = SymMap.find tag global.Global.struct_decls in + let layout = Sym.Map.find tag global.Global.struct_decls in let res = List.fold_right (fun { offset; size; member_or_padding } res -> @@ -106,10 +109,10 @@ let unpack_owned loc global (ct, init) pointer (O o) = let mresource = ( P { name = Owned (mct, init); - pointer = memberShift_ (pointer, tag, member) loc; + pointer = IT.memberShift_ (pointer, tag, member) loc; iargs = [] }, - O (member_ ~member_bt:(Memory.bt_of_sct mct) (o, member) loc) ) + O (IT.member_ ~member_bt:(Memory.bt_of_sct mct) (o, member) loc) ) in mresource :: res | None -> @@ -117,10 +120,10 @@ let unpack_owned loc global (ct, init) pointer (O o) = let mresource = ( P { name = Owned (padding_ct, Uninit); - pointer = pointer_offset_ (pointer, uintptr_int_ offset loc) loc; + pointer = IT.pointer_offset_ (pointer, IT.uintptr_int_ offset loc) loc; iargs = [] }, - O (default_ (Memory.bt_of_sct padding_ct) loc) ) + O (IT.default_ (Memory.bt_of_sct padding_ct) loc) ) in mresource :: res) layout @@ -138,46 +141,48 @@ let unpack loc global provable (ret, O o) = | _ -> (match packing_ft loc global provable ret with | None -> None - | Some packing_ft -> Some (`LRT (ResourcePredicates.clause_lrt o packing_ft))) + | Some packing_ft -> Some (`LRT (Definition.Clause.lrt o packing_ft))) let extractable_one (* global *) prove_or_model (predicate_name, index) (ret, O o) = (* let tmsg hd tail = *) (* if verb *) - (* then Pp.print stdout (Pp.item hd (ResourceTypes.pp ret ^^ Pp.hardline ^^ *) + (* then Pp.print stdout (Pp.item hd (Request.pp ret ^^ Pp.hardline ^^ *) (* Pp.string "--" ^^ Pp.hardline ^^ Lazy.force tail)) *) (* else () *) (* in *) match ret with | Q ret - when equal_predicate_name predicate_name ret.name - && BT.equal (IT.bt index) (snd ret.q) -> + when Request.equal_name predicate_name ret.name + && BT.equal (IT.get_bt index) (snd ret.q) -> let su = IT.make_subst [ (fst ret.q, index) ] in let index_permission = IT.subst su ret.permission in - (match prove_or_model (LC.t_ index_permission) with + (match prove_or_model (LC.T index_permission) with | `True -> - let loc = Cerb_location.other __FUNCTION__ in + let loc = Cerb_location.other __LOC__ in let at_index = ( P { name = ret.name; pointer = - pointer_offset_ - ( ret.pointer, - mul_ - ( cast_ Memory.uintptr_bt ret.step loc, - cast_ Memory.uintptr_bt index loc ) - loc ) - loc; + IT.( + pointer_offset_ + ( ret.pointer, + mul_ + ( cast_ Memory.uintptr_bt ret.step loc, + cast_ Memory.uintptr_bt index loc ) + loc ) + loc); iargs = List.map (IT.subst su) ret.iargs }, - O (map_get_ o index loc) ) + O (IT.map_get_ o index loc) ) in let ret_reduced = { ret with permission = - and_ - [ ret.permission; ne__ (sym_ (fst ret.q, snd ret.q, loc)) index loc ] - loc + IT.( + and_ + [ ret.permission; ne__ (sym_ (fst ret.q, snd ret.q, loc)) index loc ] + loc) } in (* tmsg "successfully extracted" (lazy (IT.pp index)); *) @@ -188,15 +193,15 @@ let extractable_one (* global *) prove_or_model (predicate_name, index) (ret, O (* (lazy (IndexTerms.pp_with_eval eval_f index_permission)); *) None) (* | Q qret -> *) - (* if not (equal_predicate_name predicate_name qret.name) *) + (* if not (Request.equal_name predicate_name qret.name) *) (* then () *) (* (\* tmsg "not extracting, predicate name differs" *\) *) - (* (\* (lazy (ResourceTypes.pp_predicate_name predicate_name)) *\) *) - (* else if not (BT.equal (IT.bt index) (snd qret.q)) *) + (* (\* (lazy (Request.pp_predicate_name predicate_name)) *\) *) + (* else if not (BT.equal (IT.get_bt index) (snd qret.q)) *) (* then *) (* () *) (* (\* tmsg "not extracting, index type differs" *\) *) - (* (\* (lazy (Pp.typ (BT.pp (IT.bt index)) (BT.pp (snd qret.q)))) *\) *) + (* (\* (lazy (Pp.typ (BT.pp (IT.get_bt index)) (BT.pp (snd qret.q)))) *\) *) (* else assert false; *) (* None *) | _ -> None diff --git a/backend/cn/lib/parse.ml b/backend/cn/lib/parse.ml index 9ec1dfa10..b6c5be29b 100644 --- a/backend/cn/lib/parse.ml +++ b/backend/cn/lib/parse.ml @@ -1,7 +1,7 @@ open Cerb_frontend.Annot -open Resultat +open Or_TypeError -open Effectful.Make (Resultat) +open Effectful.Make (Or_TypeError) open TypeErrors open Pp diff --git a/backend/cn/lib/pp.ml b/backend/cn/lib/pp.ml index 94836734c..787d533e4 100644 --- a/backend/cn/lib/pp.ml +++ b/backend/cn/lib/pp.ml @@ -335,3 +335,17 @@ let progress_simple title name = let of_total cur total = Printf.sprintf "[%d/%d]" cur total + +let document_to_yojson (doc : document) : Yojson.Safe.t = + let buf_size = 1024 (* chosen pretty arbitrarily *) in + let buf = Stdlib.Buffer.create buf_size in + PPrint.ToBuffer.compact buf doc; + let str = Stdlib.Buffer.contents buf in + `String str + + +let document_of_yojson (json : Yojson.Safe.t) : (document, string) Result.t = + match json with + | `String str -> Ok (PPrint.arbitrary_string str) + | _ -> + Error ("document_of_yojson: expected `String, found " ^ Yojson.Safe.to_string json) diff --git a/backend/cn/lib/pp.mli b/backend/cn/lib/pp.mli index 7bb43e9a4..cebf6bab8 100644 --- a/backend/cn/lib/pp.mli +++ b/backend/cn/lib/pp.mli @@ -347,3 +347,7 @@ val print_json : Yojson.Safe.t Lazy.t -> unit val progress_simple : string -> string -> unit val of_total : int -> int -> string + +val document_to_yojson : document -> Yojson.Safe.t + +val document_of_yojson : Yojson.Safe.t -> (document, string) Result.t diff --git a/backend/cn/lib/pp_mucore.ml b/backend/cn/lib/pp_mucore.ml index 312d8b1d0..db39e2022 100644 --- a/backend/cn/lib/pp_mucore.ml +++ b/backend/cn/lib/pp_mucore.ml @@ -656,7 +656,7 @@ module Make (Config : CONFIG) = struct Pp.parens (!^"let" ^^^ Sym.pp s ^^^ Pp.equals ^^^ IndexTerms.pp it) ^^^ pp_arguments_l ppf l | Resource ((s, (re, _bt)), _info, l) -> - Pp.parens (!^"let" ^^^ Sym.pp s ^^^ Pp.equals ^^^ ResourceTypes.pp re) + Pp.parens (!^"let" ^^^ Sym.pp s ^^^ Pp.equals ^^^ Request.pp re) ^^^ pp_arguments_l ppf l | Constraint (lc, _info, l) -> Pp.parens (LogicalConstraints.pp lc) ^^^ pp_arguments_l ppf l @@ -699,7 +699,12 @@ module Make (Config : CONFIG) = struct ^^ (match def with | Return _ -> P.break 1 ^^ !^"return label" ^^^ pp_symbol sym - | Label (_loc, label_args_and_body, _annots, _) -> + | Label + ( _loc, + label_args_and_body, + _annots, + _, + _loop_condition_loc ) -> P.break 1 ^^ !^"label" ^^^ pp_symbol sym diff --git a/backend/cn/lib/pp_mucore_ast.ml b/backend/cn/lib/pp_mucore_ast.ml index 3163fe93e..3792111e9 100644 --- a/backend/cn/lib/pp_mucore_ast.ml +++ b/backend/cn/lib/pp_mucore_ast.ml @@ -241,7 +241,7 @@ module PP = struct let dtree_of_label l def = match def with | Return loc -> Dleaf (!^"return" ^^^ Cerb_location.pp_location ~clever:false loc) - | Label (loc, args_and_body, _, _) -> + | Label (loc, args_and_body, _, _, _) -> Dnode ( pp_symbol l ^^^ Cerb_location.pp_location ~clever:false loc, [ dtree_of_arguments dtree_of_expr args_and_body ] ) diff --git a/backend/cn/lib/report.ml b/backend/cn/lib/report.ml index a41210634..ca5942b16 100644 --- a/backend/cn/lib/report.ml +++ b/backend/cn/lib/report.ml @@ -2,11 +2,13 @@ type term_entry = { term : Pp.document; value : Pp.document } +[@@deriving yojson] type predicate_clause_entry = { cond : Pp.document; clause : Pp.document } +[@@deriving yojson] type resource_entry = { res : Pp.document; @@ -19,12 +21,14 @@ type where_report = loc_cartesian : ((int * int) * (int * int)) option; loc_head : string (* loc_pos: string; *) } +[@@deriving yojson] (* Different forms of a document. *) type simp_view = { original : Pp.document; (* original view *) simplified : Pp.document list (* simplified based on model *) } +[@@deriving yojson] type label = string @@ -32,16 +36,56 @@ let lab_interesting : label = "interesting" let lab_uninteresting : label = "uninteresting" -module StrMap = Map.Make (String) +let sequence (xs : ('a, 'e) Result.t list) : ('a list, 'e) Result.t = + let ( let* ) = Result.bind in + let rcons e es = + let* v = e in + let* vs = es in + Ok (v :: vs) + in + List.fold_right rcons xs (Ok []) + + +module StrMap = struct + module M = Map.Make (String) + + let to_yojson (value_to_yojson : 'v -> Yojson.Safe.t) (map : 'v M.t) : Yojson.Safe.t = + `Assoc (List.map_snd value_to_yojson (M.bindings map)) + + + let of_yojson + (value_of_yojson : Yojson.Safe.t -> ('v, string) Result.t) + (json : Yojson.Safe.t) + : ('v M.t, string) Result.t + = + match json with + | `Assoc elems -> + let ( let* ) = Result.bind in + let elems' = + List.map + (fun (key, json_value) -> + let* value = value_of_yojson json_value in + Ok (key, value)) + elems + in + let* bindings = sequence elems' in + Ok (M.of_seq (List.to_seq bindings)) + | _ -> Error ("StrMap.of_yojson: expected `Assoc, found " ^ Yojson.Safe.to_string json) + + + include M +end (* Things classified in various ways. To start we just have "interesting" and "uninteresting", but we could add more *) -type 'a labeled_view = 'a list StrMap.t +type 'a labeled_view = 'a list StrMap.t [@@deriving yojson] let labeled_empty = StrMap.empty let add_labeled lab view mp = StrMap.add lab view mp +let get_labeled mp lab = StrMap.find_opt lab mp + type state_report = { where : where_report; not_given_to_solver : simp_view labeled_view; @@ -49,6 +93,7 @@ type state_report = constraints : simp_view labeled_view; terms : term_entry labeled_view } +[@@deriving yojson] type report = { trace : state_report list; @@ -56,6 +101,7 @@ type report = unproven : Pp.document (* * Pp.document *) option; predicate_hints : predicate_clause_entry list } +[@@deriving yojson] let list elements = String.concat "" elements diff --git a/backend/cn/lib/report.mli b/backend/cn/lib/report.mli index 98d691da2..ca26dca4a 100644 --- a/backend/cn/lib/report.mli +++ b/backend/cn/lib/report.mli @@ -44,9 +44,12 @@ type 'a labeled_view (** Empty collection of labeld things *) val labeled_empty : 'a labeled_view -(** Set the entities assocaited with a lable *) +(** Set the entities associated with a label *) val add_labeled : label -> 'a list -> 'a labeled_view -> 'a labeled_view +(** Get any entities associated with a label *) +val get_labeled : 'a labeled_view -> label -> 'a list option + (** Information about a specific state of the computation. The resources, constraints, and terms are pairs because they classify how relevant the thing might be: @@ -77,3 +80,7 @@ type report = The third argument is information about the various things that need to be saved. *) val make : string -> string Option.m -> report -> string + +val report_of_yojson : Yojson.Safe.t -> (report, string) Result.t + +val report_to_yojson : report -> Yojson.Safe.t diff --git a/backend/cn/lib/request.ml b/backend/cn/lib/request.ml new file mode 100644 index 000000000..b37fa7812 --- /dev/null +++ b/backend/cn/lib/request.ml @@ -0,0 +1,212 @@ +open Pp.Infix +module IT = IndexTerms + +let pp_maybe_oargs = function None -> Pp.empty | Some oargs -> Pp.parens (IT.pp oargs) + +type init = + | Init + | Uninit +[@@deriving eq, ord] + +let pp_init = function Init -> !^"Init" | Uninit -> !^"Uninit" + +type name = + | Owned of Sctypes.t * init + | PName of Sym.t +[@@deriving eq, ord] + +let pp_name = function + | Owned (ct, Init) -> !^"Owned" ^^ Pp.angles (Sctypes.pp ct) + | Owned (ct, Uninit) -> !^"Block" ^^ Pp.angles (Sctypes.pp ct) + | PName pn -> Sym.pp pn + + +let dtree_of_name = + let open Cerb_frontend.Pp_ast in + function + | Owned (ty, init) -> + Dleaf (!^"Owned" ^^ Pp.angles (Sctypes.pp ty ^^ Pp.comma ^^ pp_init init)) + | PName s -> Dleaf (Sym.pp s) + + +let subsumed p1 p2 = + (* p1 subsumed by p2 *) + equal_name p1 p2 + || + match (p1, p2) with + | Owned (ct, Uninit), Owned (ct', Init) when Sctypes.equal ct ct' -> true + | _ -> false + + +module Predicate = struct + let alloc = PName Alloc.Predicate.sym + + type t = + { name : name; + pointer : IT.t; (* I *) + iargs : IT.t list (* I *) + } + [@@deriving eq, ord] + + let pp_aux (p : t) oargs = + let args = List.map IT.pp (p.pointer :: p.iargs) in + Pp.c_app (pp_name p.name) args ^^ pp_maybe_oargs oargs + + + let subst substitution (p : t) = + { name = p.name; + pointer = IT.subst substitution p.pointer; + iargs = List.map (IT.subst substitution) p.iargs + } + + + let dtree (pred : t) = + let open Cerb_frontend.Pp_ast in + Dnode + ( pp_ctor "pred", + dtree_of_name pred.name :: IT.dtree pred.pointer :: List.map IT.dtree pred.iargs + ) +end + +let make_alloc pointer = Predicate.{ name = alloc; pointer; iargs = [] } + +module QPredicate = struct + type t = + { name : name; + pointer : IT.t; (* I *) + q : Sym.t * BaseTypes.t; + q_loc : Locations.t; [@equal fun _ _ -> true] [@compare fun _ _ -> 0] + step : IT.t; + permission : IT.t; (* I, function of q *) + iargs : IT.t list (* I, function of q *) + } + [@@deriving eq, ord] + + let pp_aux (p : t) oargs = + let open Pp in + (* ISD: this is `p + i * step` but that's "wrong" in a couple of ways: + - we are not using the correct precedences for `p` and `step` + - in C pointer arithmetic takes account of the types, but here + we seem to be doing it at the byte level. Would `step` ever + differ from the size of elements that `p` points to? + - perhaps print as `&p[i]` or `&p[j + i]` + *) + let pointer = + IT.pp p.pointer ^^^ plus ^^^ Sym.pp (fst p.q) ^^^ star ^^^ IT.pp p.step + in + let args = pointer :: List.map IT.pp p.iargs in + !^"each" + ^^ parens (BaseTypes.pp (snd p.q) ^^^ Sym.pp (fst p.q) ^^ semi ^^^ IT.pp p.permission) + ^/^ braces (c_app (pp_name p.name) args) + ^^ pp_maybe_oargs oargs + + + let alpha_rename_ (q' : Sym.t) (qp : t) = + let subst = IT.make_rename ~from:(fst qp.q) ~to_:q' in + { name = qp.name; + pointer = qp.pointer; + q = (q', snd qp.q); + q_loc = qp.q_loc; + step = qp.step; + permission = IT.subst subst qp.permission; + iargs = List.map (IT.subst subst) qp.iargs + } + + + let alpha_rename qp = alpha_rename_ (Sym.fresh_same (fst qp.q)) qp + + let subst substitution (qp : t) = + let qp = + if Sym.Set.mem (fst qp.q) substitution.Subst.relevant then + alpha_rename qp + else + qp + in + { name = qp.name; + pointer = IT.subst substitution qp.pointer; + q = qp.q; + q_loc = qp.q_loc; + step = IT.subst substitution qp.step; + permission = IT.subst substitution qp.permission; + iargs = List.map (IT.subst substitution) qp.iargs + } + + + let dtree (qpred : t) = + let open Cerb_frontend.Pp_ast in + Dnode + ( pp_ctor "qpred", + Dleaf (Pp.parens (Pp.typ (Sym.pp (fst qpred.q)) (BaseTypes.pp (snd qpred.q)))) + :: IT.dtree qpred.step + :: IT.dtree qpred.permission + :: dtree_of_name qpred.name + :: IT.dtree qpred.pointer + :: List.map IT.dtree qpred.iargs ) + + + let get_lower_bound (qpred : t) : IT.t = + IndexTerms.Bounds.get_lower_bound qpred.q qpred.permission + + + let get_upper_bound (qpred : t) : IT.t = + IndexTerms.Bounds.get_upper_bound qpred.q qpred.permission + + + let get_bounds (qpred : t) : IT.t * IT.t = (get_lower_bound qpred, get_upper_bound qpred) +end + +type t = + | P of Predicate.t + | Q of QPredicate.t +[@@deriving eq, ord] + +let get_name = function P p -> p.name | Q p -> p.name + +(* resources of the same type as a request, such that the resource coult potentially be + used to fulfil the request *) +let same_name r1 r2 = equal_name (get_name r1) (get_name r2) + +let pp_aux r o = + match r with P p -> Predicate.pp_aux p o | Q qp -> QPredicate.pp_aux qp o + + +let pp r = pp_aux r None + +let json re : Yojson.Safe.t = `String (Pp.plain (pp re)) + +let subst (substitution : _ Subst.t) = function + | P p -> P (Predicate.subst substitution p) + | Q qp -> Q (QPredicate.subst substitution qp) + + +let free_vars_bts = function + | P p -> IT.free_vars_bts_list (p.pointer :: p.iargs) + | Q p -> + Sym.Map.union + (fun _ bt1 bt2 -> + assert (BaseTypes.equal bt1 bt2); + Some bt1) + (IT.free_vars_bts_list [ p.pointer; p.step ]) + (Sym.Map.remove (fst p.q) (IT.free_vars_bts_list (p.permission :: p.iargs))) + + +let free_vars = function + | P p -> IT.free_vars_list (p.pointer :: p.iargs) + | Q p -> + Sym.Set.union + (Sym.Set.union (IT.free_vars p.pointer) (IT.free_vars p.step)) + (Sym.Set.remove (fst p.q) (IT.free_vars_list (p.permission :: p.iargs))) + + +let alpha_equivalent r1 r2 = + match (r1, r2) with + | P _, P _ -> equal r1 r2 + | Q x, Q y -> + let y2 = QPredicate.alpha_rename_ (fst x.q) y in + equal (Q x) (Q y2) + | _ -> false + + +let steps_constant = function Q qp -> Option.is_some (IT.is_const qp.step) | _ -> true + +let dtree = function P pred -> Predicate.dtree pred | Q qpred -> QPredicate.dtree qpred diff --git a/backend/cn/lib/request.mli b/backend/cn/lib/request.mli new file mode 100644 index 000000000..b7dcc3141 --- /dev/null +++ b/backend/cn/lib/request.mli @@ -0,0 +1,88 @@ +type init = + | Init + | Uninit + +val pp_init : init -> Pp.document + +type name = + | Owned of Sctypes.t * init + | PName of Sym.t +[@@deriving eq] + +val pp_name : name -> Pp.document + +val dtree_of_name : name -> Cerb_frontend.Pp_ast.doc_tree + +val subsumed : name -> name -> bool + +module Predicate : sig + type t = + { name : name; + pointer : IndexTerms.t; + iargs : IndexTerms.t list + } + + val alloc : name + + val subst : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> t -> t + + val dtree : t -> Cerb_frontend.Pp_ast.doc_tree +end + +val make_alloc : IndexTerms.t -> Predicate.t + +module QPredicate : sig + type t = + { name : name; + pointer : IndexTerms.t; + q : Sym.t * BaseTypes.t; + q_loc : Locations.t; + step : IndexTerms.t; + permission : IndexTerms.t; + iargs : IndexTerms.t list + } + + val alpha_rename_ : Sym.t -> t -> t + + val alpha_rename : t -> t + + val subst : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> t -> t + + val dtree : t -> Cerb_frontend.Pp_ast.doc_tree + + val get_lower_bound : t -> IndexTerms.t + + val get_upper_bound : t -> IndexTerms.t + + val get_bounds : t -> IndexTerms.t * IndexTerms.t +end + +type t = + | P of Predicate.t + | Q of QPredicate.t + +val equal : t -> t -> bool + +val compare : t -> t -> int + +val get_name : t -> name + +val same_name : t -> t -> bool + +val pp_aux : t -> 'a Terms.annot option -> Pp.document + +val pp : t -> Pp.document + +val json : t -> Yojson.Safe.t + +val subst : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> t -> t + +val free_vars_bts : t -> IndexTerms.BT.t Sym.Map.t + +val free_vars : t -> Sym.Set.t + +val alpha_equivalent : t -> t -> bool + +val steps_constant : t -> bool + +val dtree : t -> Cerb_frontend.Pp_ast.doc_tree diff --git a/backend/cn/lib/resource.ml b/backend/cn/lib/resource.ml new file mode 100644 index 000000000..7c2ff65fa --- /dev/null +++ b/backend/cn/lib/resource.ml @@ -0,0 +1,71 @@ +module IT = IndexTerms +module Req = Request + +type output = O of IT.t [@@ocaml.unboxed] + +let pp_output (O t) = IT.pp t + +type predicate = Req.Predicate.t * output + +type qpredicate = Req.QPredicate.t * output + +type t = Req.t * output + +let pp (r, O output) = Req.pp_aux r (Some output) + +let json re : Yojson.Safe.t = `String (Pp.plain (pp re)) + +let subst substitution ((r, O oargs) : t) = + (Req.subst substitution r, O (IT.subst substitution oargs)) + + +let free_vars (r, O oargs) = Sym.Set.union (Req.free_vars r) (IT.free_vars oargs) + +(* assumption: the resource is owned *) +let derived_lc1 ((resource : Req.t), O output) = + let here = Locations.other __LOC__ in + match resource with + | P { name = Owned (ct, _); pointer; iargs = _ } -> + let addr = IT.addr_ pointer here in + let upper = IT.upper_bound addr ct here in + let alloc_bounds = + if !IT.use_vip then + let module H = Alloc.History in + let H.{ base; size } = H.(split (lookup_ptr pointer here) here) in + [ IT.(le_ (base, addr) here); IT.(le_ (upper, add_ (base, size) here) here) ] + else + [] + in + [ IT.hasAllocId_ pointer here; IT.(le_ (addr, upper) here) ] @ alloc_bounds + | P { name; pointer; iargs = [] } + when !IT.use_vip && Req.(equal_name name Predicate.alloc) -> + let module H = Alloc.History in + let lookup = H.lookup_ptr pointer here in + let H.{ base; size } = H.split lookup here in + [ IT.(eq_ (lookup, output) here); IT.(le_ (base, add_ (base, size) here) here) ] + | Q { name = Owned _; pointer; _ } -> [ IT.hasAllocId_ pointer here ] + | P { name = PName _; pointer = _; iargs = _ } | Q { name = PName _; _ } -> [] + + +(* assumption: both resources are owned at the same *) +(* todo, depending on how much we need *) +let derived_lc2 ((resource : Req.t), _) ((resource' : Req.t), _) = + match (resource, resource') with + | ( P { name = Owned (ct1, _); pointer = p1; iargs = _ }, + P { name = Owned (ct2, _); pointer = p2; iargs = _ } ) -> + let here = Locations.other __LOC__ in + let addr1 = IT.addr_ p1 here in + let addr2 = IT.addr_ p2 here in + let up1 = IT.upper_bound addr1 ct1 here in + let up2 = IT.upper_bound addr2 ct2 here in + [ IT.(or2_ (le_ (up2, addr1) here, le_ (up1, addr2) here) here) ] + | _ -> [] + + +let disable_resource_derived_constraints = ref false + +let pointer_facts ~new_resource ~old_resources = + if !disable_resource_derived_constraints then + [] + else + derived_lc1 new_resource @ List.concat_map (derived_lc2 new_resource) old_resources diff --git a/backend/cn/lib/resource.mli b/backend/cn/lib/resource.mli new file mode 100644 index 000000000..8ffceae49 --- /dev/null +++ b/backend/cn/lib/resource.mli @@ -0,0 +1,25 @@ +type output = O of IndexTerms.t [@@unboxed] + +val pp_output : output -> Pp.document + +type predicate = Request.Predicate.t * output + +type qpredicate = Request.QPredicate.t * output + +type t = Request.t * output + +val pp : Request.t * output -> Pp.document + +val json : Request.t * output -> Yojson.Safe.t + +val subst : [ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> t -> t + +val free_vars : t -> Sym.Set.t + +val derived_lc1 : t -> IndexTerms.t list + +val derived_lc2 : t -> t -> IndexTerms.t list + +val disable_resource_derived_constraints : bool ref + +val pointer_facts : new_resource:t -> old_resources:t list -> IndexTerms.t list diff --git a/backend/cn/lib/resourceInference.ml b/backend/cn/lib/resourceInference.ml index a42957524..07e11f63a 100644 --- a/backend/cn/lib/resourceInference.ml +++ b/backend/cn/lib/resourceInference.ml @@ -1,15 +1,11 @@ module IT = IndexTerms module LC = LogicalConstraints -module RET = ResourceTypes - -type oargs = Resources.oargs = O of IT.t - +module Req = Request open Typing let debug_constraint_failure_diagnostics lvl (model_with_q : Solver.model_with_q) - global simp_ctxt c = @@ -17,7 +13,7 @@ let debug_constraint_failure_diagnostics if !Pp.print_level == 0 then () else ( - let pp_f = IT.pp_with_eval (Solver.eval global model) in + let pp_f = IT.pp_with_eval (Solver.eval model) in let diag msg c = match (c, model_with_q) with | LC.T tm, _ -> @@ -29,7 +25,7 @@ let debug_constraint_failure_diagnostics Pp.debug lvl (lazy (pp_f tm')) | _ -> Pp.warn - (Locations.other __FUNCTION__) + (Locations.other __LOC__) (Pp.bold "unexpected quantifier count with model") in diag "counterexample, expanding" c; @@ -51,7 +47,7 @@ module General = struct value : IT.t } - type uiinfo = TypeErrors.situation * TypeErrors.request_chain + type uiinfo = TypeErrors.situation * TypeErrors.RequestChain.t type case = | One of one @@ -62,7 +58,7 @@ module General = struct let add_case case (C cases) = C (cases @ [ case ]) let cases_to_map loc (situation, requests) a_bt item_bt (C cases) = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let update_with_ones base_array ones = List.fold_left (fun m { one_index; value } -> IT.map_set_ m (one_index, value) here) @@ -106,10 +102,10 @@ module General = struct let module LAT = LogicalArgumentTypes in match ftyp with | LAT.Resource ((s, (resource, _bt)), info, ftyp) -> - let resource = Simplify.ResourceTypes.simp simp_ctxt resource in + let resource = Simplify.Request.simp simp_ctxt resource in let situation, request_chain = uiinfo in let step = - TypeErrors. + TypeErrors.RequestChain. { resource; loc = Some (fst info); reason = Some ("arg " ^ Sym.pp_string s) } in let request_chain = step :: request_chain in @@ -117,7 +113,7 @@ module General = struct let@ o_re_oarg = resource_request loc uiinfo resource in (match o_re_oarg with | None -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ model = model_with loc (IT.bool_ true here) in let model = Option.get model in fail (fun ctxt -> @@ -127,8 +123,8 @@ module General = struct { requests = request_chain; situation; model; ctxt } in { loc; msg }) - | Some ((re, O oargs), changed_or_deleted') -> - assert (ResourceTypes.equal re resource); + | Some ((re, Resource.O oargs), changed_or_deleted') -> + assert (Request.equal re resource); let oargs = Simplify.IndexTerms.simp simp_ctxt oargs in let changed_or_deleted = changed_or_deleted @ changed_or_deleted' in return @@ -144,10 +140,9 @@ module General = struct | `True -> return (ftyp, changed_or_deleted) | `False -> let@ model = model () in - let@ global = get_global () in let@ all_cs = get_cs () in - let () = assert (not (Context.LCSet.mem c all_cs)) in - debug_constraint_failure_diagnostics 6 model global simp_ctxt c; + let () = assert (not (LC.Set.mem c all_cs)) in + debug_constraint_failure_diagnostics 6 model simp_ctxt c; let@ () = Diagnostics.investigate model c in fail (fun ctxt -> (* let ctxt = { ctxt with resources = original_resources } in *) @@ -160,11 +155,11 @@ module General = struct (* TODO: check that oargs are in the same order? *) - let rec predicate_request loc (uiinfo : uiinfo) (requested : RET.predicate_type) - : ((RET.predicate_type * Resources.oargs) * int list) option m + let rec predicate_request loc (uiinfo : uiinfo) (requested : Req.Predicate.t) + : (Resource.predicate * int list) option m = - Pp.(debug 7 (lazy (item __FUNCTION__ (RET.pp (P requested))))); - let start_timing = Pp.time_log_start __FUNCTION__ "" in + Pp.(debug 7 (lazy (item __LOC__ (Req.pp (P requested))))); + let start_timing = Pp.time_log_start __LOC__ "" in let@ oarg_bt = WellTyped.oarg_bt_of_pred loc requested.name in let@ provable = provable loc in let@ global = get_global () in @@ -175,8 +170,8 @@ module General = struct continue else ( match re with - | RET.P p', p'_oarg when RET.subsumed requested.name p'.name -> - let here = Locations.other __FUNCTION__ in + | Req.P p', p'_oarg when Req.subsumed requested.name p'.name -> + let here = Locations.other __LOC__ in let addr_iargs_eqs = IT.(eq_ ((addr_ requested.pointer) here, addr_ p'.pointer here) here) :: List.map2 (fun x y -> IT.eq__ x y here) requested.iargs p'.iargs @@ -186,14 +181,14 @@ module General = struct IT.(eq_ (allocId_ requested.pointer here, allocId_ p'.pointer here) here) in let debug_failure model msg term = - Pp.debug 9 (lazy (Pp.item msg (RET.pp (fst re)))); - debug_constraint_failure_diagnostics 9 model global simp_ctxt (LC.T term) + Pp.debug 9 (lazy (Pp.item msg (Req.pp (fst re)))); + debug_constraint_failure_diagnostics 9 model simp_ctxt (LC.T term) in (match provable (LC.T addr_iargs_match) with | `True -> (match provable (LC.T alloc_id_eq) with | `True -> - Pp.debug 9 (lazy (Pp.item "used resource" (RET.pp (fst re)))); + Pp.debug 9 (lazy (Pp.item "used resource" (Req.pp (fst re)))); (Deleted, (false, p'_oarg)) | `False -> debug_failure @@ -222,7 +217,7 @@ module General = struct | _re -> continue) in let needed = true in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ (needed, oarg), changed_or_deleted = map_and_fold_resources loc resource_scan (needed, O (IT.default_ oarg_bt here)) in @@ -241,9 +236,9 @@ module General = struct let@ o, changed_or_deleted = ftyp_args_request_for_pack loc uiinfo packing_ft in - return (Some ((requested, O o), changed_or_deleted)) + return (Some ((requested, Resource.O o), changed_or_deleted)) | None -> - let req_pp = lazy (RET.pp (P requested)) in + let req_pp = lazy (Req.pp (P requested)) in Pp.debug 9 (Lazy.map (Pp.item "no pack rule for resource, failing") req_pp); return None) in @@ -251,11 +246,10 @@ module General = struct return res - and qpredicate_request_aux loc uiinfo (requested : RET.qpredicate_type) = - Pp.(debug 7 (lazy (item __FUNCTION__ (RET.pp (Q requested))))); + and qpredicate_request_aux loc uiinfo (requested : Req.QPredicate.t) = + Pp.(debug 7 (lazy (item __LOC__ (Req.pp (Q requested))))); let@ provable = provable loc in let@ simp_ctxt = simp_ctxt () in - let@ global = get_global () in let needed = requested.permission in let step = Simplify.IndexTerms.simp simp_ctxt requested.step in let@ () = @@ -276,17 +270,17 @@ module General = struct loc (fun re (needed, oarg) -> let continue = (Unchanged, (needed, oarg)) in - assert (RET.steps_constant (fst re)); + assert (Req.steps_constant (fst re)); if IT.is_false needed then continue else ( match re with | Q p', O p'_oarg - when RET.subsumed requested.name p'.name + when Req.subsumed requested.name p'.name && IT.equal step p'.step && BaseTypes.equal (snd requested.q) (snd p'.q) -> - let p' = RET.alpha_rename_qpredicate_type_ (fst requested.q) p' in - let here = Locations.other __FUNCTION__ in + let p' = Req.QPredicate.alpha_rename_ (fst requested.q) p' in + let here = Locations.other __LOC__ in let pmatch = (* Work-around for https://github.com/Z3Prover/z3/issues/7352 *) Simplify.IndexTerms.simp simp_ctxt @@ -304,7 +298,7 @@ module General = struct | `False -> (match provable (LC.T pmatch) with | `True -> - Pp.debug 9 (lazy (Pp.item "used resource" (RET.pp (fst re)))); + Pp.debug 9 (lazy (Pp.item "used resource" (Req.pp (fst re)))); let open IT in let needed' = [ needed; not_ (and_ [ iarg_match; p'.permission ] here) here ] @@ -321,18 +315,13 @@ module General = struct let model = Solver.model () in Pp.debug 9 - (lazy (Pp.item "couldn't use q-resource" (RET.pp (fst re)))); - debug_constraint_failure_diagnostics - 9 - model - global - simp_ctxt - (LC.T pmatch); + (lazy (Pp.item "couldn't use q-resource" (Req.pp (fst re)))); + debug_constraint_failure_diagnostics 9 model simp_ctxt (LC.T pmatch); continue)) | _re -> continue)) (needed, C []) in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ needed, oarg = let@ movable_indices = get_movable_indices () in let module Eff = Effectful.Make (Typing) in @@ -341,12 +330,12 @@ module General = struct let continue = return (needed, oarg) in if (not (IT.is_false needed)) - && RET.subsumed requested.name predicate_name - && BaseTypes.equal (snd requested.q) (IT.bt index) + && Req.subsumed requested.name predicate_name + && BaseTypes.equal (snd requested.q) (IT.get_bt index) then ( let su = IT.make_subst [ (fst requested.q, index) ] in let needed_at_index = IT.subst su needed in - match provable (LC.t_ needed_at_index) with + match provable (LC.T needed_at_index) with | `False -> continue | `True -> let@ o_re_index = @@ -389,11 +378,11 @@ module General = struct | `True -> return (Some (oarg, rw_time)) | `False -> let@ model = model () in - debug_constraint_failure_diagnostics 9 model global simp_ctxt nothing_more_needed; + debug_constraint_failure_diagnostics 9 model simp_ctxt nothing_more_needed; return None - and qpredicate_request loc uiinfo (requested : RET.qpredicate_type) = + and qpredicate_request loc uiinfo (requested : Req.QPredicate.t) = let@ o_oarg = qpredicate_request_aux loc uiinfo requested in let@ oarg_item_bt = WellTyped.oarg_bt_of_pred loc requested.name in match o_oarg with @@ -401,7 +390,7 @@ module General = struct | Some (oarg, rw_time) -> let@ oarg = cases_to_map loc uiinfo (snd requested.q) oarg_item_bt oarg in let r = - RET. + Req.QPredicate. { name = requested.name; pointer = requested.pointer; q = requested.q; @@ -411,7 +400,7 @@ module General = struct iargs = requested.iargs } in - return (Some ((r, O oarg), rw_time)) + return (Some ((r, Resource.O oarg), rw_time)) and ftyp_args_request_for_pack loc uiinfo ftyp = @@ -437,19 +426,19 @@ module General = struct loop ftyp [] - and resource_request loc uiinfo (request : RET.t) : (Resources.t * int list) option m = + and resource_request loc uiinfo (request : Req.t) : (Resource.t * int list) option m = match request with | P request -> let@ result = predicate_request loc uiinfo request in return (Option.map - (fun ((p, o), changed_or_deleted) -> ((RET.P p, o), changed_or_deleted)) + (fun ((p, o), changed_or_deleted) -> ((Req.P p, o), changed_or_deleted)) result) | Q request -> let@ result = qpredicate_request loc uiinfo request in return (Option.map - (fun ((q, o), changed_or_deleted) -> ((RET.Q q, o), changed_or_deleted)) + (fun ((q, o), changed_or_deleted) -> ((Req.Q q, o), changed_or_deleted)) result) @@ -470,7 +459,7 @@ end module Special = struct let fail_missing_resource loc (situation, requests) = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ model = model_with loc (IT.bool_ true here) in let model = Option.get model in fail (fun ctxt -> @@ -480,7 +469,7 @@ module Special = struct let predicate_request loc situation (request, oinfo) = let requests = - [ TypeErrors. + [ TypeErrors.RequestChain. { resource = P request; loc = Option.map fst oinfo; reason = Option.map snd oinfo @@ -492,10 +481,15 @@ module Special = struct match result with Some r -> return r | None -> fail_missing_resource loc uiinfo + let has_predicate loc situation (request, oinfo) = + let@ result = sandbox @@ predicate_request loc situation (request, oinfo) in + return (Result.is_ok result) + + (** This function checks whether [ptr1] belongs to a live allocation. It searches the context (without modification) for either an Alloc(p) or an Owned(p) such that (alloc_id) p == (alloc_id) ptr. *) - let get_live_alloc reason loc ptr = + let check_live_alloc reason loc ptr = let module Ans = struct type t = | Found @@ -503,7 +497,7 @@ module Special = struct | Model of (Solver.model_with_q * IT.t) end in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let alloc_id_matches found res_ptr = let@ found in match found with @@ -520,10 +514,10 @@ module Special = struct let f res found = let found = match res with - | RET.Q _, _ -> found - | RET.P { name = Owned _; pointer; iargs = _ }, _ -> + | Req.Q _, _ -> found + | Req.P { name = Owned _; pointer; iargs = _ }, _ -> alloc_id_matches found pointer - | RET.P { name = PName name; pointer; iargs = _ }, _ -> + | Req.P { name = PName name; pointer; iargs = _ }, _ -> if Sym.equal name Alloc.Predicate.sym then alloc_id_matches found pointer else @@ -534,7 +528,7 @@ module Special = struct let@ found, _ = map_and_fold_resources loc f (return Ans.No_res) in let@ found in match found with - | Ans.Found -> return (Alloc.History.lookup_ptr ptr here) + | Ans.Found -> return () | No_res -> fail (fun ctxt -> let msg = @@ -550,13 +544,9 @@ module Special = struct { loc; msg }) - let predicate_request loc situation (request, oinfo) = - predicate_request loc situation (request, oinfo) - - let qpredicate_request loc situation (request, oinfo) = let requests = - [ TypeErrors. + [ TypeErrors.RequestChain. { resource = Q request; loc = Option.map fst oinfo; reason = Option.map snd oinfo diff --git a/backend/cn/lib/resourceInference.mli b/backend/cn/lib/resourceInference.mli index 395507afb..8b6829d53 100644 --- a/backend/cn/lib/resourceInference.mli +++ b/backend/cn/lib/resourceInference.mli @@ -1,13 +1,12 @@ val debug_constraint_failure_diagnostics : int -> Solver.model_with_q -> - Global.t -> Simplify.simp_ctxt -> - LogicalConstraints.logical_constraint -> + LogicalConstraints.t -> unit module General : sig - type uiinfo = TypeErrors.situation * TypeErrors.request_chain + type uiinfo = TypeErrors.situation * TypeErrors.RequestChain.t val ftyp_args_request_step : ([ `Rename of Sym.t | `Term of IndexTerms.t ] Subst.t -> 'a -> 'a) -> @@ -19,21 +18,27 @@ module General : sig end module Special : sig - val get_live_alloc - : [ `Copy_alloc_id | `Ptr_cmp | `Ptr_diff | `ISO_array_shift ] -> + val check_live_alloc + : [ `Copy_alloc_id | `Ptr_cmp | `Ptr_diff | `ISO_array_shift | `ISO_member_shift ] -> Locations.t -> IndexTerms.t -> - IndexTerms.t Typing.m + unit Typing.m val predicate_request : Locations.t -> TypeErrors.situation -> - ResourceTypes.predicate_type * (Locations.t * string) option -> - ((ResourceTypes.predicate_type * Resources.oargs) * int list) Typing.m + Request.Predicate.t * (Locations.t * string) option -> + (Resource.predicate * int list) Typing.m + + val has_predicate + : Locations.t -> + TypeErrors.situation -> + Request.Predicate.t * (Locations.t * string) option -> + bool Typing.m val qpredicate_request : Locations.t -> TypeErrors.situation -> - ResourceTypes.qpredicate_type * (Locations.t * string) option -> - ((ResourceTypes.qpredicate_type * Resources.oargs) * int list) Typing.m + Request.QPredicate.t * (Locations.t * string) option -> + (Resource.qpredicate * int list) Typing.m end diff --git a/backend/cn/lib/resourcePredicates.ml b/backend/cn/lib/resourcePredicates.ml deleted file mode 100644 index a8fade39f..000000000 --- a/backend/cn/lib/resourcePredicates.ml +++ /dev/null @@ -1,118 +0,0 @@ -module BT = BaseTypes -module IT = IndexTerms -module LS = LogicalSorts -module LRT = LogicalReturnTypes -module LC = LogicalConstraints -module AT = ArgumentTypes -module LAT = LogicalArgumentTypes -module StringMap = Map.Make (String) -module Loc = Locations -open Pp - -type clause = - { loc : Loc.t; - guard : IT.t; - packing_ft : LAT.packing_ft - } - -let pp_clause { loc = _; guard; packing_ft } = - item "condition" (IT.pp guard) ^^ comma ^^^ item "return type" (LAT.pp IT.pp packing_ft) - - -let subst_clause subst { loc; guard; packing_ft } = - { loc; guard = IT.subst subst guard; packing_ft = LAT.subst IT.subst subst packing_ft } - - -let clause_lrt (pred_oarg : IT.t) clause_packing_ft = - let rec aux = function - | LAT.Define (bound, info, lat) -> LRT.Define (bound, info, aux lat) - | LAT.Resource (bound, info, lat) -> LRT.Resource (bound, info, aux lat) - | LAT.Constraint (lc, info, lat) -> LRT.Constraint (lc, info, aux lat) - | I output -> - let loc = Loc.other __FUNCTION__ in - let lc = LC.t_ (IT.eq_ (pred_oarg, output) loc) in - LRT.Constraint (lc, (loc, None), LRT.I) - in - aux clause_packing_ft - - -type definition = - { loc : Loc.t; - pointer : Sym.t; - iargs : (Sym.t * LS.t) list; - oarg_bt : LS.t; - clauses : clause list option - } - -let alloc = - { loc = Locations.other (__FILE__ ^ ":" ^ string_of_int __LINE__); - pointer = Sym.fresh_named "ptr"; - iargs = []; - oarg_bt = Alloc.History.value_bt; - clauses = None - } - - -let pp_definition def = - item "pointer" (Sym.pp def.pointer) - ^/^ item "iargs" (Pp.list (fun (s, _) -> Sym.pp s) def.iargs) - ^/^ item "oarg_bt" (BT.pp def.oarg_bt) - ^/^ item - "clauses" - (match def.clauses with - | Some clauses -> Pp.list pp_clause clauses - | None -> !^"(uninterpreted)") - - -let instantiate_clauses def ptr_arg iargs = - match def.clauses with - | Some clauses -> - let subst = - IT.make_subst - ((def.pointer, ptr_arg) - :: List.map2 (fun (def_ia, _) ia -> (def_ia, ia)) def.iargs iargs) - in - Some (List.map (subst_clause subst) clauses) - | None -> None - - -open IndexTerms -open LogicalConstraints - -let identify_right_clause provable def pointer iargs = - match instantiate_clauses def pointer iargs with - | None -> - (* "uninterpreted" predicates cannot be un/packed *) - None - | Some clauses -> - let rec try_clauses = function - | [] -> None - | clause :: clauses -> - (match provable (t_ clause.guard) with - | `True -> Some clause - | `False -> - let loc = Loc.other __FUNCTION__ in - (match provable (t_ (not_ clause.guard loc)) with - | `True -> try_clauses clauses - | `False -> - Pp.debug - 5 - (lazy - (Pp.item "cannot prove or disprove clause guard" (IT.pp clause.guard))); - None)) - in - try_clauses clauses - - -(* determines if a resource predicate will be given to the solver - TODO: right now this is an overapproximation *) -let given_to_solver def = - match def.clauses with - | None -> false - | Some [] -> true - | Some [ _ ] -> true - | _ -> false - - -(*Extensibility hook. For now, all predicates are displayed as "interesting" in error reporting*) -let is_interesting : definition -> bool = fun _ -> true diff --git a/backend/cn/lib/resourceTypes.ml b/backend/cn/lib/resourceTypes.ml deleted file mode 100644 index 3efe60b13..000000000 --- a/backend/cn/lib/resourceTypes.ml +++ /dev/null @@ -1,220 +0,0 @@ -open Pp -module CF = Cerb_frontend -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) -module IT = IndexTerms -open IT -module LC = LogicalConstraints -module LCSet = Set.Make (LC) - -type init = - | Init - | Uninit -[@@deriving eq, ord] - -type predicate_name = - | Owned of Sctypes.t * init - | PName of Sym.t -[@@deriving eq, ord] - -let alloc = PName Alloc.Predicate.sym - -let pp_init = function Init -> !^"Init" | Uninit -> !^"Uninit" - -let pp_predicate_name = function - | Owned (ct, Init) -> !^"Owned" ^^ angles (Sctypes.pp ct) - | Owned (ct, Uninit) -> !^"Block" ^^ angles (Sctypes.pp ct) - | PName pn -> Sym.pp pn - - -type predicate_type = - { name : predicate_name; - pointer : IT.t; (* I *) - iargs : IT.t list (* I *) - } -[@@deriving eq, ord] - -let make_alloc pointer = { name = alloc; pointer; iargs = [] } - -type qpredicate_type = - { name : predicate_name; - pointer : IT.t; (* I *) - q : Sym.t * BT.t; - q_loc : Locations.t; [@equal fun _ _ -> true] [@compare fun _ _ -> 0] - step : IT.t; - permission : IT.t; (* I, function of q *) - iargs : IT.t list (* I, function of q *) - } -[@@deriving eq, ord] - -let subsumed p1 p2 = - (* p1 subsumed by p2 *) - equal_predicate_name p1 p2 - || - match (p1, p2) with - | Owned (ct, Uninit), Owned (ct', Init) when Sctypes.equal ct ct' -> true - | _ -> false - - -type resource_type = - | P of predicate_type - | Q of qpredicate_type -[@@deriving eq, ord] - -type t = resource_type - -let predicate_name = function P p -> p.name | Q p -> p.name - -let pp_maybe_oargs = function None -> Pp.empty | Some oargs -> parens (IT.pp oargs) - -let pp_predicate_type_aux (p : predicate_type) oargs = - let args = List.map IT.pp (p.pointer :: p.iargs) in - c_app (pp_predicate_name p.name) args ^^ pp_maybe_oargs oargs - - -let pp_qpredicate_type_aux (p : qpredicate_type) oargs = - (* XXX: this is `p + i * step` but that's "wrong" in a couple of ways: - - we are not using the correct precedences for `p` and `step` - - in C pointer arithmetic takes account of the types, but here - we seem to be doing it at the byte level. Would `step` ever - differ from the size of elements that `p` points to? - - perhaps print as `&p[i]` or `&p[j + i]` - *) - let pointer = IT.pp p.pointer ^^^ plus ^^^ Sym.pp (fst p.q) ^^^ star ^^^ IT.pp p.step in - let args = pointer :: List.map IT.pp p.iargs in - !^"each" - ^^ parens (BT.pp (snd p.q) ^^^ Sym.pp (fst p.q) ^^ semi ^^^ IT.pp p.permission) - ^/^ braces (c_app (pp_predicate_name p.name) args) - ^^ pp_maybe_oargs oargs - - -let pp_predicate_type p = pp_predicate_type_aux p None - -let pp_qpredicate_type p = pp_qpredicate_type_aux p None - -let pp_aux r o = - match r with P p -> pp_predicate_type_aux p o | Q qp -> pp_qpredicate_type_aux qp o - - -let pp r = pp_aux r None - -let equal = equal_resource_type - -let compare = compare_resource_type - -let json re : Yojson.Safe.t = `String (Pp.plain (pp re)) - -let alpha_rename_qpredicate_type_ (q' : Sym.t) (qp : qpredicate_type) = - let subst = make_rename ~from:(fst qp.q) ~to_:q' in - { name = qp.name; - pointer = qp.pointer; - q = (q', snd qp.q); - q_loc = qp.q_loc; - step = qp.step; - permission = IT.subst subst qp.permission; - iargs = List.map (IT.subst subst) qp.iargs - } - - -let alpha_rename_qpredicate_type qp = - alpha_rename_qpredicate_type_ (Sym.fresh_same (fst qp.q)) qp - - -let subst_predicate_type substitution (p : predicate_type) = - { name = p.name; - pointer = IT.subst substitution p.pointer; - iargs = List.map (IT.subst substitution) p.iargs - } - - -let subst_qpredicate_type substitution (qp : qpredicate_type) = - let qp = - if SymSet.mem (fst qp.q) substitution.Subst.relevant then - alpha_rename_qpredicate_type qp - else - qp - in - { name = qp.name; - pointer = IT.subst substitution qp.pointer; - q = qp.q; - q_loc = qp.q_loc; - step = IT.subst substitution qp.step; - permission = IT.subst substitution qp.permission; - iargs = List.map (IT.subst substitution) qp.iargs - } - - -let subst (substitution : _ Subst.t) = function - | P p -> P (subst_predicate_type substitution p) - | Q qp -> Q (subst_qpredicate_type substitution qp) - - -let free_vars_bts = function - | P p -> IT.free_vars_bts_list (p.pointer :: p.iargs) - | Q p -> - SymMap.union - (fun _ bt1 bt2 -> - assert (BT.equal bt1 bt2); - Some bt1) - (IT.free_vars_bts_list [ p.pointer; p.step ]) - (SymMap.remove (fst p.q) (IT.free_vars_bts_list (p.permission :: p.iargs))) - - -let free_vars = function - | P p -> IT.free_vars_list (p.pointer :: p.iargs) - | Q p -> - SymSet.union - (SymSet.union (IT.free_vars p.pointer) (IT.free_vars p.step)) - (SymSet.remove (fst p.q) (IT.free_vars_list (p.permission :: p.iargs))) - - -(* resources of the same type as a request, such that the resource coult potentially be - used to fulfil the request *) -let same_predicate_name r1 r2 = - equal_predicate_name (predicate_name r1) (predicate_name r2) - - -let alpha_equivalent r1 r2 = - match (r1, r2) with - | P _, P _ -> equal_resource_type r1 r2 - | Q x, Q y -> - let y2 = alpha_rename_qpredicate_type_ (fst x.q) y in - equal_resource_type (Q x) (Q y2) - | _ -> false - - -let steps_constant = function Q qp -> Option.is_some (IT.is_const qp.step) | _ -> true - -let pointer = function P pred -> pred.pointer | Q pred -> pred.pointer - -open Cerb_frontend.Pp_ast -open Pp - -let dtree_of_predicate_name = function - | Owned (ty, init) -> - Dleaf (!^"Owned" ^^ angles (Sctypes.pp ty ^^ comma ^^ pp_init init)) - | PName s -> Dleaf (Sym.pp s) - - -let dtree_of_predicate_type (pred : predicate_type) = - Dnode - ( pp_ctor "pred", - dtree_of_predicate_name pred.name - :: IT.dtree pred.pointer - :: List.map IT.dtree pred.iargs ) - - -let dtree_of_qpredicate_type (pred : qpredicate_type) = - Dnode - ( pp_ctor "qpred", - Dleaf (Pp.parens (Pp.typ (Sym.pp (fst pred.q)) (BT.pp (snd pred.q)))) - :: IT.dtree pred.step - :: IT.dtree pred.permission - :: dtree_of_predicate_name pred.name - :: IT.dtree pred.pointer - :: List.map IT.dtree pred.iargs ) - - -let dtree = function - | P pred -> dtree_of_predicate_type pred - | Q pred -> dtree_of_qpredicate_type pred diff --git a/backend/cn/lib/resources.ml b/backend/cn/lib/resources.ml deleted file mode 100644 index 6db544214..000000000 --- a/backend/cn/lib/resources.ml +++ /dev/null @@ -1,79 +0,0 @@ -module CF = Cerb_frontend -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) -module IT = IndexTerms -module LC = LogicalConstraints -module LCSet = Set.Make (LC) -open ResourceTypes - -type oargs = O of IT.t - -let pp_oargs (O t) = IT.pp t - -type resource = resource_type * oargs - -type t = resource - -let request (r, _oargs) = r - -let oargs_bt (_re, O oargs) = IT.bt oargs - -let pp (r, O oargs) = ResourceTypes.pp_aux r (Some oargs) - -let json re : Yojson.Safe.t = `String (Pp.plain (pp re)) - -let subst substitution ((r, O oargs) : t) = - (ResourceTypes.subst substitution r, O (IT.subst substitution oargs)) - - -let free_vars (r, O oargs) = SymSet.union (ResourceTypes.free_vars r) (IT.free_vars oargs) - -let range_size ct = - let here = Locations.other (__FUNCTION__ ^ ":" ^ string_of_int __LINE__) in - let size = Memory.size_of_ctype ct in - IT.num_lit_ (Z.of_int size) Memory.uintptr_bt here - - -let upper_bound addr ct loc = IT.add_ (addr, range_size ct) loc - -(* assumption: the resource is owned *) -let derived_lc1 (resource, O oarg) = - let here = Locations.other (__FUNCTION__ ^ ":" ^ string_of_int __LINE__) in - match resource with - | P { name = Owned (ct, _); pointer; iargs = _ } -> - let addr = IT.addr_ pointer here in - let upper = upper_bound addr ct here in - let alloc_bounds = - if !IT.use_vip then ( - let lookup = Alloc.History.lookup_ptr pointer here in - let base, size = Alloc.History.get_base_size lookup here in - [ IT.(le_ (base, addr) here); IT.(le_ (upper, add_ (base, size) here) here) ]) - else - [] - in - [ IT.hasAllocId_ pointer here; IT.(le_ (addr, upper) here) ] @ alloc_bounds - | P { name; pointer; iargs = [] } when !IT.use_vip && equal_predicate_name name alloc -> - let lookup = Alloc.History.lookup_ptr pointer here in - let base, size = Alloc.History.get_base_size lookup here in - [ IT.(eq_ (lookup, oarg) here); IT.(le_ (base, add_ (base, size) here) here) ] - | Q { name = Owned _; pointer; _ } -> [ IT.hasAllocId_ pointer here ] - | P { name = PName _; pointer = _; iargs = _ } | Q { name = PName _; _ } -> [] - - -(* assumption: both resources are owned at the same *) -(* todo, depending on how much we need *) -let derived_lc2 (resource, _) (resource', _) = - match (resource, resource') with - | ( P { name = Owned (ct1, _); pointer = p1; iargs = _ }, - P { name = Owned (ct2, _); pointer = p2; iargs = _ } ) -> - let here = Locations.other (__FUNCTION__ ^ ":" ^ string_of_int __LINE__) in - let addr1 = IT.addr_ p1 here in - let addr2 = IT.addr_ p2 here in - let up1 = upper_bound addr1 ct1 here in - let up2 = upper_bound addr2 ct2 here in - [ IT.(or2_ (le_ (up2, addr1) here, le_ (up1, addr2) here) here) ] - | _ -> [] - - -let pointer_facts ~new_resource ~old_resources = - derived_lc1 new_resource @ List.concat_map (derived_lc2 new_resource) old_resources diff --git a/backend/cn/lib/returnTypes.ml b/backend/cn/lib/returnTypes.ml index e653df197..a633e4529 100644 --- a/backend/cn/lib/returnTypes.ml +++ b/backend/cn/lib/returnTypes.ml @@ -1,5 +1,4 @@ open Locations -module SymSet = Set.Make (Sym) module IT = IndexTerms module LRT = LogicalReturnTypes @@ -22,7 +21,7 @@ and alpha_rename from t = and suitably_alpha_rename syms s t = - if SymSet.mem s syms then + if Sym.Set.mem s syms then alpha_rename s t else (s, t) @@ -30,7 +29,7 @@ and suitably_alpha_rename syms s t = let alpha_unique ss = function | Computational ((name, bt), oinfo, t) -> - let t = LRT.alpha_unique (SymSet.add name ss) t in + let t = LRT.alpha_unique (Sym.Set.add name ss) t in let name, t = LRT.suitably_alpha_rename ss name t in Computational ((name, bt), oinfo, t) @@ -44,14 +43,15 @@ let simp simp_it simp_lc simp_re = function let binders = function | Computational ((s, bt), _, t) -> let s, t = LRT.alpha_rename s t in - (Id.id (Sym.pp_string s), bt) :: LRT.binders t + let here = Locations.other __LOC__ in + (Id.make here (Sym.pp_string s), bt) :: LRT.binders t let map (f : LRT.t -> LRT.t) = function | Computational (param, oinfo, t) -> Computational (param, oinfo, f t) -let bound = function Computational ((s, _), _, lrt) -> SymSet.add s (LRT.bound lrt) +let bound = function Computational ((s, _), _, lrt) -> Sym.Set.add s (LRT.bound lrt) let pp_aux rt = let open Pp in diff --git a/backend/cn/lib/setup.ml b/backend/cn/lib/setup.ml index ee55d19ab..90885b9a1 100644 --- a/backend/cn/lib/setup.ml +++ b/backend/cn/lib/setup.ml @@ -35,10 +35,3 @@ let conf macros incl_dirs incl_files astprints = cpp_cmd = cpp_str macros incl_dirs incl_files; cpp_stderr = true } - - -let unfold_proxies = - StringSet.of_list [ "ffs_proxy"; "ffsl_proxy"; "ffsll_proxy"; "ctz_proxy" ] - - -let unfold_stdlib_name s = StringSet.mem s unfold_proxies diff --git a/backend/cn/lib/setup.mli b/backend/cn/lib/setup.mli index 61ac95f10..1eed831cb 100644 --- a/backend/cn/lib/setup.mli +++ b/backend/cn/lib/setup.mli @@ -12,5 +12,3 @@ val conf string list -> Cerb_backend.Pipeline.language list -> Cerb_backend.Pipeline.configuration - -val unfold_stdlib_name : string -> bool diff --git a/backend/cn/lib/simple_smt.ml b/backend/cn/lib/simple_smt.ml index b62e13b6a..7bd92dd68 100644 --- a/backend/cn/lib/simple_smt.ml +++ b/backend/cn/lib/simple_smt.ml @@ -489,6 +489,8 @@ type solver_log = type solver_config = { exe : string; opts : string list; + params : (string * string) list; + (* (parameter name * setting) list, the name without leading colon *) exts : solver_extensions; log : solver_log } @@ -811,6 +813,9 @@ let new_solver (cfg : solver_config) : solver = in ack_command s (set_option ":print-success" "true"); ack_command s (set_option ":produce-models" "true"); + List.iter + (fun (name, setting) -> ack_command s (set_option (":" ^ name) setting)) + cfg.params; Gc.finalise (fun me -> me.stop ()) s; s @@ -885,8 +890,16 @@ let printf_log = let cvc5 : solver_config = - { exe = "cvc5"; opts = [ "--incremental"; "--sets-ext" ]; exts = CVC5; log = quiet_log } + { exe = "cvc5"; + (* opts = [ "--incremental"; "--sets-ext"; "--force-logic=QF_AUFBVDTLIA" ]; *) + opts = [ "--incremental"; "--sets-ext"; "--force-logic=QF_ALL" ]; + params = []; + exts = CVC5; + log = quiet_log + } let z3 : solver_config = - { exe = "z3"; opts = [ "-in"; "-smt2" ]; exts = Z3; log = quiet_log } + (* let params = [ ("sat.smt", "true") ] in *) + let params = [ ("smt.relevancy", "0") ] in + { exe = "z3"; opts = [ "-in"; "-smt2" ]; params; exts = Z3; log = quiet_log } diff --git a/backend/cn/lib/simplify.ml b/backend/cn/lib/simplify.ml index 4640bedd3..71b52fc8d 100644 --- a/backend/cn/lib/simplify.ml +++ b/backend/cn/lib/simplify.ml @@ -15,15 +15,14 @@ end module ITPairMap = Map.Make (ITPair) module ITSet = Set.Make (IT) -module LCSet = Set.Make (LC) type simp_ctxt = { global : Global.t; - values : IT.t SymMap.t; + values : IT.t Sym.Map.t; simp_hook : IT.t -> IT.t option } -let default global = { global; values = SymMap.empty; simp_hook = (fun _ -> None) } +let default global = { global; values = Sym.Map.empty; simp_hook = (fun _ -> None) } let do_ctz_z z = let rec loop z found = @@ -37,13 +36,13 @@ let do_ctz_z z = module IndexTerms = struct - let z1 = z_ Z.one (Cerb_location.other __FUNCTION__) + let z1 = z_ Z.one (Cerb_location.other __LOC__) - let z0 = z_ Z.zero (Cerb_location.other __FUNCTION__) + let z0 = z_ Z.zero (Cerb_location.other __LOC__) let rec dest_int_addition ts it = - let loc = IT.loc it in - match IT.term it with + let loc = IT.get_loc it in + match IT.get_term it with | Const (Z i1) -> if fst ts || ITSet.mem z1 (snd ts) then ([ (z1, i1) ], z0) else ([], it) | Binop (Add, a, b) -> @@ -123,15 +122,15 @@ module IndexTerms = struct let simp_comp_if_int a b loc = - if BaseTypes.equal (IT.basetype a) BaseTypes.Integer then + if BaseTypes.equal (IT.get_bt a) BaseTypes.Integer then simp_int_comp a b loc else (a, b) let rec record_member_reduce it member = - let loc = IT.loc it in - match IT.term it with + let loc = IT.get_loc it in + match IT.get_term it with | Record members -> List.assoc Id.equal member members | RecordUpdate ((t, m), v) -> if Id.equal m member then @@ -141,15 +140,15 @@ module IndexTerms = struct | ITE (cond, it1, it2) -> ite_ (cond, record_member_reduce it1 member, record_member_reduce it2 member) loc | _ -> - let member_tys = BT.record_bt (IT.bt it) in + let member_tys = BT.record_bt (IT.get_bt it) in let member_bt = List.assoc Id.equal member member_tys in IT.recordMember_ ~member_bt (it, member) loc (* let rec datatype_member_reduce it member member_bt = *) - (* match IT.term it with *) + (* match IT.get_term it with *) (* | DatatypeCons (nm, members_rec) -> *) - (* let members = BT.record_bt (IT.bt members_rec) in *) + (* let members = BT.record_bt (IT.get_bt members_rec) in *) (* if List.exists (Id.equal member) (List.map fst members) *) (* then record_member_reduce members_rec member *) (* else IT.IT (DatatypeMember (it, member), member_bt) *) @@ -159,8 +158,8 @@ module IndexTerms = struct (* | _ -> IT.IT (DatatypeMember (it, member), member_bt) *) let rec tuple_nth_reduce it n item_bt = - let loc = IT.loc it in - match IT.term it with + let loc = IT.get_loc it in + match IT.get_term it with | Tuple items -> List.nth items n | ITE (cond, it1, it2) -> ite_ (cond, tuple_nth_reduce it1 n item_bt, tuple_nth_reduce it2 n item_bt) loc @@ -168,9 +167,9 @@ module IndexTerms = struct let rec accessor_reduce (f : IT.t -> IT.t option) it = - let bt = IT.bt it in + let bt = IT.get_bt it in let step, it2 = - match IT.term it with + match IT.get_term it with | RecordMember (t, m) -> (true, record_member_reduce (accessor_reduce f t) m) (* | DatatypeMember (t, m) -> *) (* (true, datatype_member_reduce (accessor_reduce f t) m bt) *) @@ -184,9 +183,9 @@ module IndexTerms = struct let cast_reduce bt it = - let loc = IT.loc it in + let loc = IT.get_loc it in match (bt, IT.is_const it) with - | _, _ when BT.equal (IT.bt it) bt -> it + | _, _ when BT.equal (IT.get_bt it) bt -> it | BT.Bits (sign, sz), Some (Terms.Bits ((sign2, sz2), z), _) -> let z = BT.normalise_to_range (sign, sz) (BT.normalise_to_range (sign2, sz2) z) in num_lit_ z bt loc @@ -207,7 +206,7 @@ module IndexTerms = struct match the_term_ with | Sym _ when BT.equal the_bt BT.Unit -> unit_ the_loc | Sym sym -> - (match SymMap.find_opt sym simp_ctxt.values with + (match Sym.Map.find_opt sym simp_ctxt.values with | Some (IT ((Const _ | Sym _), _, _) as v) -> v | _ -> the_term) | Const _ -> the_term @@ -377,7 +376,7 @@ module IndexTerms = struct | _ -> IT (Binop (Implies, a, b), the_bt, the_loc)) | Unop (op, a) -> let a = aux a in - (match (op, IT.term a) with + (match (op, IT.get_term a) with | Not, Const (Bool b) -> bool_ (not b) the_loc | Not, Unop (Not, x) -> x | Negate, Unop (Negate, x) -> x @@ -464,7 +463,7 @@ module IndexTerms = struct | Struct (tag, members) -> (match members with | (_, IT (StructMember (str, _), _, _)) :: _ - when BT.equal (Struct tag) (IT.bt str) + when BT.equal (Struct tag) (IT.get_bt str) && List.for_all (function | mem, IT (StructMember (str', mem'), _, _) -> @@ -506,7 +505,7 @@ module IndexTerms = struct let a = aux a in let b = aux b in if isIntegerToPointerCast a || isIntegerToPointerCast b then ( - let loc = Cerb_location.other __FUNCTION__ in + let loc = Cerb_location.other __LOC__ in aux (lt_ (addr_ a loc, addr_ b loc) the_loc)) else if IT.equal a b then bool_ false the_loc @@ -516,7 +515,7 @@ module IndexTerms = struct let a = aux a in let b = aux b in if isIntegerToPointerCast a || isIntegerToPointerCast b then ( - let loc = Cerb_location.other __FUNCTION__ in + let loc = Cerb_location.other __LOC__ in aux (le_ (addr_ a loc, addr_ b loc) the_loc)) else if IT.equal a b then bool_ true the_loc @@ -569,7 +568,7 @@ module IndexTerms = struct let rec make map index = match map with | IT (MapDef ((s, abt), body), _, _) -> - assert (BT.equal abt (IT.bt index)); + assert (BT.equal abt (IT.get_bt index)); aux (IT.subst (IT.make_subst [ (s, index) ]) body) | IT (MapSet (map', index', value'), _, _) -> (match (index, index') with @@ -597,8 +596,8 @@ module IndexTerms = struct if not inline_functions then t else ( - let def = SymMap.find name simp_ctxt.global.logical_functions in - match LogicalFunctions.try_open_fun def args with + let def = Sym.Map.find name simp_ctxt.global.logical_functions in + match Definition.Function.try_open def args with | Some inlined -> aux inlined | None -> t) | _ -> @@ -626,35 +625,39 @@ module LogicalConstraints = struct let q, body = IT.alpha_rename q body in let body = simp ~inline_functions simp_ctxt body in (match body with - | IT (Const (Bool true), _, _) -> LC.T (bool_ true (IT.loc body)) + | IT (Const (Bool true), _, _) -> LC.T (bool_ true (IT.get_loc body)) | _ -> LC.Forall ((q, qbt), body)) end -module ResourceTypes = struct - open IndexTerms - open ResourceTypes - - let simp_predicate_type simp_ctxt (p : predicate_type) = - { name = p.name; - pointer = simp simp_ctxt p.pointer; - iargs = List.map (simp simp_ctxt) p.iargs - } - - - let simp_qpredicate_type simp_ctxt (qp : qpredicate_type) = - let qp = alpha_rename_qpredicate_type qp in - let permission = simp_flatten simp_ctxt qp.permission in - { name = qp.name; - pointer = simp simp_ctxt qp.pointer; - q = qp.q; - q_loc = qp.q_loc; - step = simp simp_ctxt qp.step; - permission = and_ permission (IT.loc qp.permission); - iargs = List.map (simp simp_ctxt) qp.iargs - } - - - let simp simp_ctxt = function - | P p -> P (simp_predicate_type simp_ctxt p) - | Q qp -> Q (simp_qpredicate_type simp_ctxt qp) +module Request = struct + module Predicate = struct + open Request.Predicate + + let simp simp_ctxt (p : t) = + { name = p.name; + pointer = IndexTerms.simp simp_ctxt p.pointer; + iargs = List.map (IndexTerms.simp simp_ctxt) p.iargs + } + end + + module QPredicate = struct + open Request.QPredicate + + let simp simp_ctxt (qp : t) = + let qp = alpha_rename qp in + let permission = IndexTerms.simp_flatten simp_ctxt qp.permission in + Request.QPredicate. + { name = qp.name; + pointer = IndexTerms.simp simp_ctxt qp.pointer; + q = qp.q; + q_loc = qp.q_loc; + step = IndexTerms.simp simp_ctxt qp.step; + permission = and_ permission (IT.get_loc qp.permission); + iargs = List.map (IndexTerms.simp simp_ctxt) qp.iargs + } + end + + let simp simp_ctxt : Request.t -> Request.t = function + | P p -> P (Predicate.simp simp_ctxt p) + | Q qp -> Q (QPredicate.simp simp_ctxt qp) end diff --git a/backend/cn/lib/solver.ml b/backend/cn/lib/solver.ml index 0510254b2..74ce31f59 100644 --- a/backend/cn/lib/solver.ml +++ b/backend/cn/lib/solver.ml @@ -1,26 +1,16 @@ module SMT = Simple_smt module IT = IndexTerms -open IndexTerms -module BT = BaseTypes -open BaseTypes +open IT module LC = LogicalConstraints -open LogicalConstraints -module SymMap = Map.Make (Sym) -module SymSet = Set.Make (Sym) module Int_BT_Table = Map.Make (struct type t = int * BT.t let compare (int1, bt1) (int2, bt2) = let cmp = Int.compare int1 int2 in - if cmp != 0 then - cmp - else - BT.compare bt1 bt2 + if cmp != 0 then cmp else BT.compare bt1 bt2 end) -module BT_Table = Hashtbl.Make (BT) - module IntWithHash = struct (* For compatability with older ocamls *) include Int @@ -29,7 +19,6 @@ module IntWithHash = struct end module Int_Table = Hashtbl.Make (IntWithHash) -module LCSet = Set.Make (LC) module CTypeMap = Map.Make (Sctypes) open Global open Pp @@ -46,13 +35,13 @@ module CN_Names = struct let struct_con_name x = Sym.pp_string x ^ "_" ^ string_of_int (Sym.num x) - let struct_field_name x = Id.pp_string x ^ "_struct_fld" + let struct_field_name x = Id.get_string x ^ "_struct_fld" let datatype_name x = Sym.pp_string x ^ "_" ^ string_of_int (Sym.num x) let datatype_con_name x = Sym.pp_string x ^ "_" ^ string_of_int (Sym.num x) - let datatype_field_name x = Id.pp_string x ^ "_data_fld" + let datatype_field_name x = Id.get_string x ^ "_data_fld" end (** Names for constants that may be uninterpreted. See [bt_uninterpreted] *) @@ -76,7 +65,7 @@ end type solver_frame = { mutable commands : SMT.sexp list; (** Ack-style SMT commands, most recent first. *) - mutable uninterpreted : SMT.sexp SymMap.t; + mutable uninterpreted : SMT.sexp Sym.Map.t; (** Uninterpreted functions and variables that we've declared. *) mutable bt_uninterpreted : SMT.sexp Int_BT_Table.t; (** Uninterpreted constants, indexed by base type. *) @@ -86,7 +75,7 @@ type solver_frame = let empty_solver_frame () = { commands = []; - uninterpreted = SymMap.empty; + uninterpreted = Sym.Map.empty; bt_uninterpreted = Int_BT_Table.empty; ctypes = CTypeMap.empty } @@ -114,7 +103,7 @@ module Debug = struct rest ^/^ bar ^^^ BT.pp k ^^^ !^"|->" ^^^ !^(to_string v) in !^"# Symbols" - |> SymMap.fold dump_sym f.uninterpreted + |> Sym.Map.fold dump_sym f.uninterpreted |> append "# Basetypes " |> Int_BT_Table.fold dump_bts f.bt_uninterpreted |> append "+---------------------------------" @@ -209,7 +198,7 @@ let fresh_name s x = (** Declare an uninterpreted function. *) let declare_uninterpreted s name args_ts res_t = - let check f = SymMap.find_opt name f.uninterpreted in + let check f = Sym.Map.find_opt name f.uninterpreted in match search_frames s check with | Some e -> e | None -> @@ -217,7 +206,7 @@ let declare_uninterpreted s name args_ts res_t = ack_command s (SMT.declare_fun sname args_ts res_t); let e = SMT.atom sname in let f = !(s.cur_frame) in - f.uninterpreted <- SymMap.add name e f.uninterpreted; + f.uninterpreted <- Sym.Map.add name e f.uninterpreted; e @@ -240,9 +229,15 @@ let declare_bt_uninterpreted s (name, k) bt args_ts res_t = when we need them, with another piece of state in the solver to track which ones we have declared. *) module CN_Tuple = struct - let name arity = "cn_tuple_" ^ string_of_int arity + let max_arity = 15 + + let name arity = + assert (arity <= max_arity); + "cn_tuple_" ^ string_of_int arity + let selector arity field = + assert (arity <= max_arity); "cn_get_" ^ string_of_int field ^ "_of_" ^ string_of_int arity @@ -253,18 +248,21 @@ module CN_Tuple = struct (** Declare a datatype for a struct *) - let declare s arity = - let name = name arity in - let param i = "a" ^ string_of_int i in - let params = List.init arity param in - let field i = (selector arity i, SMT.atom (param i)) in - let fields = List.init arity field in - ack_command s (SMT.declare_datatype name params [ (name, fields) ]) + let declare s = + for arity = 0 to max_arity do + let name = name arity in + let param i = "a" ^ string_of_int i in + let params = List.init arity param in + let field i = (selector arity i, SMT.atom (param i)) in + let fields = List.init arity field in + ack_command s (SMT.declare_datatype name params [ (name, fields) ]) + done (** Make a tuple value *) let con es = let arity = List.length es in + assert (arity <= max_arity); SMT.app_ (name arity) es @@ -479,7 +477,7 @@ end (** Translate a base type to SMT *) let rec translate_base_type = function - | Unit -> CN_Tuple.t [] + | BT.Unit -> CN_Tuple.t [] | Bool -> SMT.t_bool | Integer -> SMT.t_int | MemByte -> CN_MemByte.t @@ -508,11 +506,11 @@ let rec get_ivalue gs ctys bt sexp = and get_value gs ctys bt (sexp : SMT.sexp) = match bt with - | Unit -> Const Unit + | BT.Unit -> Const Unit | Bool -> Const (Bool (SMT.to_bool sexp)) | Integer -> Const (Z (SMT.to_z sexp)) | Bits (sign, n) -> - let signed = equal_sign sign Signed in + let signed = BT.(equal_sign sign Signed) in Const (Bits ((sign, n), SMT.to_bits n signed sexp)) | Real -> Const (Q (SMT.to_q sexp)) | MemByte -> @@ -564,20 +562,23 @@ and get_value gs ctys bt (sexp : SMT.sexp) = Tuple (List.map2 (get_ivalue gs ctys) bts vals) | Struct tag -> let _con, vals = SMT.to_con sexp in - let decl = SymMap.find tag gs.struct_decls in + let decl = Sym.Map.find tag gs.struct_decls in let fields = List.filter_map (fun x -> x.Memory.member_or_padding) decl in let mk_field (l, t) v = (l, get_ivalue gs ctys (Memory.bt_of_sct t) v) in Struct (tag, List.map2 mk_field fields vals) | Datatype tag -> let con, vals = SMT.to_con sexp in - let cons = (SymMap.find tag gs.datatypes).constrs in + let cons = (Sym.Map.find tag gs.datatypes).constrs in let do_con c = - let fields = (SymMap.find c gs.datatype_constrs).params in + let fields = (Sym.Map.find c gs.datatype_constrs).params in let mk_field (l, t) v = (l, get_ivalue gs ctys t v) in Constructor (c, List.map2 mk_field fields vals) in let try_con c = - if String.equal con (CN_Names.datatype_con_name c) then Some (do_con c) else None + if String.equal con (CN_Names.datatype_con_name c) then + Some (do_con c) + else + None in (match List.find_map try_con cons with | Some yes -> yes @@ -675,7 +676,7 @@ let bv_ctz result_w = (** Translate a variable to SMT. Declare if needed. *) let translate_var s name bt = - let check f = SymMap.find_opt name f.uninterpreted in + let check f = Sym.Map.find_opt name f.uninterpreted in match search_frames s check with | Some e -> e | None -> @@ -683,13 +684,13 @@ let translate_var s name bt = ack_command s (SMT.declare sname (translate_base_type bt)); let e = SMT.atom sname in let f = !(s.cur_frame) in - f.uninterpreted <- SymMap.add name e f.uninterpreted; + f.uninterpreted <- Sym.Map.add name e f.uninterpreted; e (** Translate a CN term to SMT *) let rec translate_term s iterm = - let loc = IT.loc iterm in + let loc = IT.get_loc iterm in let struct_decls = s.globals.struct_decls in let maybe_name e k = if SMT.is_atom e then @@ -699,17 +700,17 @@ let rec translate_term s iterm = SMT.let_ [ (x, e) ] (k (SMT.atom x))) in let default bt = - let here = Locations.other (__FUNCTION__ ^ string_of_int __LINE__) in + let here = Locations.other __LOC__ in translate_term s (IT.default_ bt here) in - match IT.term iterm with + match IT.get_term iterm with | Const c -> translate_const s c - | Sym x -> translate_var s x (IT.basetype iterm) + | Sym x -> translate_var s x (IT.get_bt iterm) | Unop (op, e1) -> (match op with | BW_FFS_NoSMT -> (* NOTE: This desugaring duplicates e1 *) - let intl i = int_lit_ i (IT.bt e1) loc in + let intl i = int_lit_ i (IT.get_bt e1) loc in translate_term s (ite_ @@ -720,8 +721,8 @@ let rec translate_term s iterm = | BW_FLS_NoSMT -> (* copying and adjusting BW_FFS_NoSMT rule *) (* NOTE: This desugaring duplicates e1 *) - let sz = match IT.bt e1 with Bits (_sign, n) -> n | _ -> assert false in - let intl i = int_lit_ i (IT.bt e1) loc in + let sz = match IT.get_bt e1 with Bits (_sign, n) -> n | _ -> assert false in + let intl i = int_lit_ i (IT.get_bt e1) loc in translate_term s (ite_ @@ -731,20 +732,20 @@ let rec translate_term s iterm = loc) | Not -> SMT.bool_not (translate_term s e1) | Negate -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits _ -> SMT.bv_neg (translate_term s e1) | BT.Integer | BT.Real -> SMT.num_neg (translate_term s e1) - | _ -> failwith (__FUNCTION__ ^ ":Unop (Negate, _)")) + | _ -> failwith (__LOC__ ^ ":Unop (Negate, _)")) | BW_Compl -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits _ -> SMT.bv_compl (translate_term s e1) - | _ -> failwith (__FUNCTION__ ^ ":Unop (BW_Compl, _)")) + | _ -> failwith (__LOC__ ^ ":Unop (BW_Compl, _)")) | BW_CLZ_NoSMT -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits (_, w) -> maybe_name (translate_term s e1) (bv_clz w w) | _ -> failwith "solver: BW_CLZ_NoSMT: not a bitwise type") | BW_CTZ_NoSMT -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits (_, w) -> maybe_name (translate_term s e1) (bv_ctz w w) | _ -> failwith "solver: BW_CTZ_NoSMT: not a bitwise type")) | Binop (op, e1, e2) -> @@ -752,7 +753,7 @@ let rec translate_term s iterm = let s2 = translate_term s e2 in (* binary uninterpreted function, same type for arguments and result. *) let uninterp_same_type k = - let bt = IT.basetype iterm in + let bt = IT.get_bt iterm in let smt_t = translate_base_type bt in let f = declare_bt_uninterpreted s k bt [ smt_t; smt_t ] smt_t in SMT.app f [ s1; s2 ] @@ -762,23 +763,23 @@ let rec translate_term s iterm = | Or -> SMT.bool_or s1 s2 | Implies -> SMT.bool_implies s1 s2 | Add -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits _ -> SMT.bv_add s1 s2 | BT.Integer | BT.Real -> SMT.num_add s1 s2 | _ -> failwith "Add") | Sub -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits _ -> SMT.bv_sub s1 s2 | BT.Integer | BT.Real -> SMT.num_sub s1 s2 | _ -> failwith "Sub") | Mul -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits _ -> SMT.bv_mul s1 s2 | BT.Integer | BT.Real -> SMT.num_mul s1 s2 | _ -> failwith "Mul") | MulNoSMT -> uninterp_same_type CN_Constant.mul | Div -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits (BT.Signed, _) -> SMT.bv_sdiv s1 s2 | BT.Bits (BT.Unsigned, _) -> SMT.bv_udiv s1 s2 | BT.Integer | BT.Real -> SMT.num_div s1 s2 @@ -787,54 +788,52 @@ let rec translate_term s iterm = | Exp -> (match (get_num_z e1, get_num_z e2) with | Some z1, Some z2 when Z.fits_int z2 -> - translate_term s (num_lit_ (Z.pow z1 (Z.to_int z2)) (IT.bt e1) loc) + translate_term s (num_lit_ (Z.pow z1 (Z.to_int z2)) (IT.get_bt e1) loc) | _, _ -> failwith "Exp") | ExpNoSMT -> uninterp_same_type CN_Constant.exp | Rem -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits (BT.Signed, _) -> SMT.bv_srem s1 s2 | BT.Bits (BT.Unsigned, _) -> SMT.bv_urem s1 s2 | BT.Integer -> SMT.num_rem s1 s2 (* CVC5 ?? *) | _ -> failwith "Rem") | RemNoSMT -> uninterp_same_type CN_Constant.rem | Mod -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits (BT.Signed, _) -> SMT.bv_smod s1 s2 | BT.Bits (BT.Unsigned, _) -> SMT.bv_urem s1 s2 | BT.Integer -> SMT.num_mod s1 s2 | _ -> failwith "Mod") | ModNoSMT -> uninterp_same_type CN_Constant.mod' | BW_Xor -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits _ -> SMT.bv_xor s1 s2 | _ -> failwith "BW_Xor") | BW_And -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits _ -> SMT.bv_and s1 s2 | _ -> failwith "BW_And") | BW_Or -> - (match IT.basetype iterm with - | BT.Bits _ -> SMT.bv_or s1 s2 - | _ -> failwith "BW_Or") + (match IT.get_bt iterm with BT.Bits _ -> SMT.bv_or s1 s2 | _ -> failwith "BW_Or") (* Shift amount should be positive? *) | ShiftLeft -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits _ -> SMT.bv_shl s1 s2 | _ -> failwith "ShiftLeft") (* Amount should be positive? *) | ShiftRight -> - (match IT.basetype iterm with + (match IT.get_bt iterm with | BT.Bits (BT.Signed, _) -> SMT.bv_ashr s1 s2 | BT.Bits (BT.Unsigned, _) -> SMT.bv_lshr s1 s2 | _ -> failwith "ShiftRight") | LT -> - (match IT.basetype e1 with + (match IT.get_bt e1 with | BT.Bits (BT.Signed, _) -> SMT.bv_slt s1 s2 | BT.Bits (BT.Unsigned, _) -> SMT.bv_ult s1 s2 | BT.Integer | BT.Real -> SMT.num_lt s1 s2 | _ -> failwith "LT") | LE -> - (match IT.basetype e1 with + (match IT.get_bt e1 with | BT.Bits (BT.Signed, _) -> SMT.bv_sleq s1 s2 | BT.Bits (BT.Unsigned, _) -> SMT.bv_uleq s1 s2 | BT.Integer | BT.Real -> SMT.num_leq s1 s2 @@ -864,10 +863,7 @@ let rec translate_term s iterm = if i <= i2 then ( let su = make_subst [ (x, num_lit_ (Z.of_int i) bt loc) ] in let t1 = IT.subst su t in - if i = i2 then - t1 - else - IT.and2_ (t1, aux (i + 1)) loc) + if i = i2 then t1 else IT.and2_ (t1, aux (i + 1)) loc) else failwith "EachI" in @@ -878,7 +874,7 @@ let rec translate_term s iterm = (* Tuples *) | Tuple es -> CN_Tuple.con (List.map (translate_term s) es) | NthTuple (n, e1) -> - (match IT.basetype e1 with + (match IT.get_bt e1 with | Tuple ts -> CN_Tuple.get (List.length ts) n (translate_term s e1) | _ -> failwith "NthTuple: not a tuple") (* Structs *) @@ -890,8 +886,8 @@ let rec translate_term s iterm = | StructMember (e1, f) -> SMT.app_ (CN_Names.struct_field_name f) [ translate_term s e1 ] | StructUpdate ((t, member), v) -> - let tag = BT.struct_bt (IT.bt t) in - let layout = SymMap.find (struct_bt (IT.bt t)) struct_decls in + let tag = BT.struct_bt (IT.get_bt t) in + let layout = Sym.Map.find (BT.struct_bt (IT.get_bt t)) struct_decls in let members = Memory.member_types layout in let str = List.map @@ -907,15 +903,15 @@ let rec translate_term s iterm = in translate_term s (struct_ (tag, str) loc) | OffsetOf (tag, member) -> - let decl = SymMap.find tag struct_decls in + let decl = Sym.Map.find tag struct_decls in let v = Option.get (Memory.member_offset decl member) in - translate_term s (int_lit_ v (IT.basetype iterm) loc) + translate_term s (int_lit_ v (IT.get_bt iterm) loc) (* Records *) | Record members -> let field (_, e) = translate_term s e in CN_Tuple.con (List.map field members) | RecordMember (e1, f) -> - (match IT.basetype e1 with + (match IT.get_bt e1 with | Record members -> let check (x, _) = Id.equal f x in let arity = List.length members in @@ -924,7 +920,7 @@ let rec translate_term s iterm = | None -> failwith "Missing record field.") | _ -> failwith "RecordMemmber") | RecordUpdate ((t, member), v) -> - let members = BT.record_bt (IT.bt t) in + let members = BT.record_bt (IT.get_bt t) in let str = List.map (fun (member', bt) -> @@ -937,7 +933,7 @@ let rec translate_term s iterm = (member', value)) members in - translate_term s (IT (Record str, IT.bt t, loc)) + translate_term s (IT (Record str, IT.get_bt t, loc)) | MemberShift (t, tag, member) -> CN_Pointer.ptr_shift ~ptr:(translate_term s t) @@ -951,7 +947,7 @@ let rec translate_term s iterm = (let el_size = int_lit_ (Memory.size_of_ctype ct) Memory.uintptr_bt loc in (* locations don't matter here - we are translating straight away *) let ix = - if BT.equal (IT.bt index) Memory.uintptr_bt then + if BT.equal (IT.get_bt index) Memory.uintptr_bt then index else cast_ Memory.uintptr_bt index loc @@ -968,36 +964,36 @@ let rec translate_term s iterm = | Cons (e1, e2) -> CN_List.cons (translate_term s e1) (translate_term s e2) | Head e1 -> maybe_name (translate_term s e1) (fun xs -> - CN_List.head xs (translate_term s (default_ (IT.basetype iterm) loc))) + CN_List.head xs (translate_term s (default_ (IT.get_bt iterm) loc))) | Tail e1 -> maybe_name (translate_term s e1) (fun xs -> - CN_List.tail xs (translate_term s (default_ (IT.basetype iterm) loc))) + CN_List.tail xs (translate_term s (default_ (IT.get_bt iterm) loc))) | NthList (x, y, z) -> - let arg x = (translate_base_type (IT.basetype x), translate_term s x) in + let arg x = (translate_base_type (IT.get_bt x), translate_term s x) in let arg_ts, args = List.split (List.map arg [ x; y; z ]) in - let bt = IT.basetype iterm in + let bt = IT.get_bt iterm in let res_t = translate_base_type bt in let f = declare_bt_uninterpreted s CN_Constant.nth_list bt arg_ts res_t in SMT.app f args | ArrayToList (x, y, z) -> - let arg x = (translate_base_type (IT.basetype x), translate_term s x) in + let arg x = (translate_base_type (IT.get_bt x), translate_term s x) in let arg_ts, args = List.split (List.map arg [ x; y; z ]) in - let bt = IT.basetype iterm in + let bt = IT.get_bt iterm in let res_t = translate_base_type bt in let f = declare_bt_uninterpreted s CN_Constant.array_to_list bt arg_ts res_t in SMT.app f args | SizeOf ct -> - translate_term s (IT.int_lit_ (Memory.size_of_ctype ct) (IT.basetype iterm) loc) + translate_term s (IT.int_lit_ (Memory.size_of_ctype ct) (IT.get_bt iterm) loc) | Representable (ct, t) -> translate_term s (representable struct_decls ct t loc) | Good (ct, t) -> translate_term s (good_value struct_decls ct t loc) | Aligned t -> let addr = addr_ t.t loc in - assert (BT.equal (IT.bt addr) (IT.bt t.align)); + assert (BT.equal (IT.get_bt addr) (IT.get_bt t.align)); translate_term s (divisible_ (addr, t.align) loc) (* Maps *) | MapConst (bt, e1) -> let kt = translate_base_type bt in - let vt = translate_base_type (IT.basetype e1) in + let vt = translate_base_type (IT.get_bt e1) in SMT.arr_const kt vt (translate_term s e1) | MapSet (mp, k, v) -> SMT.arr_store (translate_term s mp) (translate_term s k) (translate_term s v) @@ -1005,10 +1001,10 @@ let rec translate_term s iterm = | MapDef _ -> failwith "MapDef" | Apply (name, args) -> let def = Option.get (get_logical_function_def s.globals name) in - (match def.definition with - | Def body -> translate_term s (LogicalFunctions.open_fun def.args body args) + (match def.body with + | Def body -> translate_term s (Definition.Function.open_ def.args body args) | _ -> - let do_arg arg = translate_base_type (IT.basetype arg) in + let do_arg arg = translate_base_type (IT.get_bt arg) in let args_ts = List.map do_arg args in let res_t = translate_base_type def.return_bt in let fu = declare_uninterpreted s name args_ts res_t in @@ -1044,7 +1040,7 @@ let rec translate_term s iterm = in let rec do_alts v alts = match alts with - | [] -> translate_term s (default_ (IT.basetype iterm) loc) + | [] -> translate_term s (default_ (IT.get_bt iterm) loc) | (pat, rhs) :: more -> let mb_cond, binds = match_pat v pat in let k = SMT.let_ binds (translate_term s rhs) in @@ -1056,17 +1052,17 @@ let rec translate_term s iterm = | WrapI (ity, arg) -> bv_cast ~to_:(Memory.bt_of_sct (Sctypes.Integer ity)) - ~from:(IT.bt arg) + ~from:(IT.get_bt arg) (translate_term s arg) | Cast (cbt, t) -> let smt_term = translate_term s t in - (match (IT.bt t, cbt) with + (match (IT.get_bt t, cbt) with | Bits _, Loc () -> let addr = - if BT.equal (IT.bt t) Memory.uintptr_bt then + if BT.equal (IT.get_bt t) Memory.uintptr_bt then smt_term else - bv_cast ~to_:Memory.uintptr_bt ~from:(IT.bt t) smt_term + bv_cast ~to_:Memory.uintptr_bt ~from:(IT.get_bt t) smt_term in CN_Pointer.bits_to_ptr ~bits:addr ~alloc_id:(default Alloc_id) | Loc (), Bits _ -> @@ -1090,7 +1086,7 @@ let rec translate_term s iterm = | MemByte, Alloc_id -> SMT.app_ CN_MemByte.alloc_id_name [ smt_term ] | Real, Integer -> SMT.real_to_int smt_term | Integer, Real -> SMT.int_to_real smt_term - | Bits _, Bits _ -> bv_cast ~to_:cbt ~from:(IT.bt t) smt_term + | Bits _, Bits _ -> bv_cast ~to_:cbt ~from:(IT.get_bt t) smt_term | _ -> assert false) @@ -1098,7 +1094,7 @@ let rec translate_term s iterm = let add_assumption solver global lc = let s1 = { solver with globals = global } in match lc with - | T it -> ack_command solver (SMT.assume (translate_term s1 it)) + | LC.T it -> ack_command solver (SMT.assume (translate_term s1 it)) | Forall _ -> () @@ -1110,10 +1106,10 @@ type reduction = } let translate_goal solver assumptions lc = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let instantiated = match lc with - | T it -> { expr = translate_term solver it; qs = []; extra = [] } + | LC.T it -> { expr = translate_term solver it; qs = []; extra = [] } | Forall ((s, bt), it) -> let v_s, v = IT.fresh_same bt s here in let it = IT.subst (make_subst [ (s, v) ]) it in @@ -1123,12 +1119,12 @@ let translate_goal solver assumptions lc = let v = sym_ (s, bt, here) in let check_asmp lc acc = match lc with - | Forall ((s', bt'), it') when BT.equal bt bt' -> + | LC.Forall ((s', bt'), it') when BT.equal bt bt' -> let new_asmp = IT.subst (make_subst [ (s', v) ]) it' in translate_term solver new_asmp :: acc | _ -> acc in - LCSet.fold check_asmp assumptions acc0 + LC.Set.fold check_asmp assumptions acc0 in { instantiated with extra = List.fold_left add_asmps [] instantiated.qs } @@ -1145,12 +1141,12 @@ let shortcut simp_ctxt lc = let declare_datatype_group s names = let mk_con_field (l, t) = (CN_Names.datatype_field_name l, translate_base_type t) in let mk_con c = - let ci = SymMap.find c s.globals.datatype_constrs in + let ci = Sym.Map.find c s.globals.datatype_constrs in (CN_Names.datatype_con_name c, List.map mk_con_field ci.params) in let cons (info : BT.dt_info) = List.map mk_con info.constrs in let to_smt (x : Sym.t) = - let info = SymMap.find x s.globals.datatypes in + let info = Sym.Map.find x s.globals.datatypes in (CN_Names.datatype_name x, [], cons info) in ack_command s (SMT.declare_datatypes (List.map to_smt names)) @@ -1160,15 +1156,15 @@ let declare_datatype_group s names = The `done_struct` keeps track of which structs we've already declared. *) let rec declare_struct s done_struct name decl = let mp = !done_struct in - if SymSet.mem name mp then + if Sym.Set.mem name mp then () else ( - done_struct := SymSet.add name mp; + done_struct := Sym.Set.add name mp; let mk_field (l, t) = let rec declare_nested ty = match ty with - | Struct name' -> - let decl = SymMap.find name' s.globals.struct_decls in + | BT.Struct name' -> + let decl = Sym.Map.find name' s.globals.struct_decls in declare_struct s done_struct name' decl | Map (_, el) -> declare_nested el | _ -> () @@ -1188,16 +1184,14 @@ let rec declare_struct s done_struct name decl = (** Declare various types always available to the solver. *) let declare_solver_basics s = - for arity = 0 to 8 do - CN_Tuple.declare s arity - done; + CN_Tuple.declare s; CN_List.declare s; CN_MemByte.declare s; CN_Pointer.declare s; (* structs may depend only on other structs. datatypes may depend on other datatypes and structs. *) - let done_structs = ref SymSet.empty in - SymMap.iter (declare_struct s done_structs) s.globals.struct_decls; + let done_structs = ref Sym.Set.empty in + Sym.Map.iter (declare_struct s done_structs) s.globals.struct_decls; List.iter (declare_datatype_group s) (Option.get s.globals.datatype_order) @@ -1302,7 +1296,7 @@ type model = int type model_fn = IT.t -> IT.t option -type model_with_q = model * (Sym.t * LogicalSorts.t) list +type model_with_q = model * (Sym.t * BaseTypes.t) list type model_table = (model, model_fn) Hashtbl.t @@ -1376,7 +1370,7 @@ let model_evaluator = | SMT.Sat -> let res = SMT.get_expr smt_solver inp in let ctys = get_ctype_table evaluator in - Some (get_ivalue gs ctys (basetype e) (SMT.no_let res)) + Some (get_ivalue gs ctys (get_bt e) (SMT.no_let res)) | _ -> None in Hashtbl.add models_tbl model_id model_fn; @@ -1432,16 +1426,6 @@ let provable ~loc ~solver ~global ~assumptions ~simp_ctxt lc = reason) *) (* ISD: Could these globs be different from the saved ones? *) -let eval _globs mo t = +let eval mo t = let model_fn = Hashtbl.find models_tbl mo in model_fn t - - -(* Dummy implementations *) -let random_seed = ref 0 - -let set_slow_smt_settings _ _ = () - -let debug_solver_to_string _ = () - -let debug_solver_query _ _ _ _ _ = () diff --git a/backend/cn/lib/solver.mli b/backend/cn/lib/solver.mli index 5537da5fe..6a3fdf06b 100644 --- a/backend/cn/lib/solver.mli +++ b/backend/cn/lib/solver.mli @@ -3,16 +3,11 @@ type solver type model -(* (TODO: BCP: The "with quantifiers" part will be the instantiations that the solver - found -- is that right?) *) -type model_with_q = model * (Sym.t * LogicalSorts.t) list +(** Model with quantifier instantiations *) +type model_with_q = model * (Sym.t * BaseTypes.t) list val empty_model : model -(* Global flags to pass to the solver (TODO: BCP: Could use a bit more documentation, - maybe) *) -val random_seed : int ref - module Logger : sig val to_file : bool ref @@ -36,7 +31,8 @@ val push : solver -> unit val pop : solver -> int -> unit -(* TODO: BCP: What is this? *) +(** Number of scopes in the solver. Currently only used by [Typing.sandbox], + but may be unnecessary https://github.com/rems-project/cerberus/issues/752 *) val num_scopes : solver -> int (* Run the solver. Note that we pass the assumptions explicitly even though they are also @@ -45,7 +41,7 @@ val provable : loc:Locations.t -> solver:solver -> global:Global.t -> - assumptions:Context.LCSet.t -> + assumptions:LogicalConstraints.Set.t -> simp_ctxt:Simplify.simp_ctxt -> LogicalConstraints.t -> [> `True | `False ] @@ -53,28 +49,7 @@ val provable (* Ask the solver for the model that it found in a call to [provable] *) val model : unit -> model_with_q -(* Ask the solver to evaluate a CN term in the context of a model. (Might return None in - case we ask for the value of a "don't care" value in the (minimal) model.) *) -(* TODO: BCP: I don't understand how this could ever be called -- how do we get a model to - pass it??? *) -val eval - : Global.t -> - (* TODO: BCP: IIUC Christopher thinks this is not needed? *) - model -> - IndexTerms.t -> - IndexTerms.t option - -(* TODO: BCP: What is this? *) -val set_slow_smt_settings : float option -> string option -> unit - -(* Debugging *) -(* TODO: BCP: This one seems misnamed -- it doesn't return a string...? *) -val debug_solver_to_string : solver -> unit - -val debug_solver_query - : solver -> - Global.t -> - Context.LCSet.t -> - IndexTerms.t list -> - LogicalConstraints.t -> - unit +(** Ask the solver to evaluate a CN term in the context of an already obtained + counter-example model (e.g. for evaluating sub-terms). Might return None in + case we ask for the value of a "don't care" value in the (minimal) model. *) +val eval : model -> IndexTerms.t -> IndexTerms.t option diff --git a/backend/cn/lib/source_injection.ml b/backend/cn/lib/source_injection.ml index f22bd4946..90718580f 100644 --- a/backend/cn/lib/source_injection.ml +++ b/backend/cn/lib/source_injection.ml @@ -39,7 +39,7 @@ end = struct let offset_col ~off pos = if pos.col + off < 0 then - Error (__FUNCTION__ ^ ": pos.col < off") + Error (__LOC__ ^ ": pos.col < off") else Ok { pos with col = pos.col + off } @@ -51,7 +51,7 @@ end = struct "\x1b[31mHEADER LOC: %s\x1b[0m\n" (Option.value ~default:"" (Cerb_location.get_filename loc)) ; *) match Cerb_location.to_cartesian loc with - | None -> Error (__FUNCTION__ ^ ": failed to get line/col positions") + | None -> Error (__LOC__ ^ ": failed to get line/col positions") | Some ((start_line, start_col), (end_line, end_col)) -> Ok (v (start_line + 1) (start_col + 1), v (end_line + 1) (end_col + 1)) end @@ -320,7 +320,7 @@ let pre_post_injs pre_post is_void is_main (A.AnnotatedStatement (loc, _, _)) = (* match stmt_ with | AilSblock (_bindings, []) -> Pos.of_location loc | AilSblock (_bindings, ss) -> let first = List.hd ss in let last = Lem_list_extra.last ss in let* (pre_pos, _) = posOf_stmt first in let* (_, post_pos) = posOf_stmt last in Ok - (pre_pos, post_pos) | _ -> Error (__FUNCTION__ ^ ": must be called on a function body + (pre_pos, post_pos) | _ -> Error (__LOC__ ^ ": must be called on a function body statement") in *) (* Printf.fprintf stderr "\x1b[35mPRE[%s], pos: %s\x1b[0m\n" (Cerb_location.location_to_string loc) (Pos.to_string pre_pos); Printf.fprintf stderr diff --git a/backend/cn/lib/subst.ml b/backend/cn/lib/subst.ml index c44755945..273ddcf8b 100644 --- a/backend/cn/lib/subst.ml +++ b/backend/cn/lib/subst.ml @@ -1,10 +1,9 @@ -module SymSet = Set.Make (Sym) open Pp type 'a t = { replace : (Sym.t * 'a) list; - relevant : SymSet.t; - flags : SymSet.t + relevant : Sym.Set.t; + flags : Sym.Set.t } type 'a subst = 'a t @@ -18,15 +17,15 @@ let pp ppf subst = let make free_vars replace = let relevant = List.fold_right - (fun (s, r) acc -> SymSet.union (free_vars r) (SymSet.add s acc)) + (fun (s, r) acc -> Sym.Set.union (free_vars r) (Sym.Set.add s acc)) replace - SymSet.empty + Sym.Set.empty in - { replace; relevant; flags = SymSet.empty } + { replace; relevant; flags = Sym.Set.empty } let add free_vars (s, r) subst = { subst with replace = (s, r) :: subst.replace; - relevant = SymSet.union (free_vars r) (SymSet.add s subst.relevant) + relevant = Sym.Set.union (free_vars r) (Sym.Set.add s subst.relevant) } diff --git a/backend/cn/lib/sym.ml b/backend/cn/lib/sym.ml index 182b3b3fe..d7eda8b10 100644 --- a/backend/cn/lib/sym.ml +++ b/backend/cn/lib/sym.ml @@ -4,13 +4,20 @@ include S let executable_spec_enabled = ref false -type t = S.sym +module Ord = struct + type t = S.sym + + let compare = S.symbol_compare +end + +include Ord type sym = t let equal = S.symbolEquality -let compare = S.symbol_compare +module Set = Set.Make (Ord) +module Map = Map.Make (Ord) type description = S.symbol_description diff --git a/backend/cn/lib/testGeneration/buildScript.ml b/backend/cn/lib/testGeneration/buildScript.ml new file mode 100644 index 000000000..97685cc43 --- /dev/null +++ b/backend/cn/lib/testGeneration/buildScript.ml @@ -0,0 +1,253 @@ +module Config = TestGenConfig +open Pp + +let setup ~output_dir = + string "#!/bin/bash" + ^^ twice hardline + ^^ string "# copied from cn-runtime-single-file.sh" + ^^ hardline + ^^ string "RUNTIME_PREFIX=\"$OPAM_SWITCH_PREFIX/lib/cn/runtime\"" + ^^ hardline + ^^ string "[ -d \"${RUNTIME_PREFIX}\" ]" + ^^ space + ^^ twice bar + ^^ space + ^^ parens + (nest + 4 + (hardline + ^^ string + "printf \"Could not find CN's runtime directory (looked at: \ + '${RUNTIME_PREFIX}')\"" + ^^ hardline + ^^ string "exit 1") + ^^ hardline) + ^^ twice hardline + ^^ string ("TEST_DIR=" ^ Filename.dirname (Filename.concat output_dir "junk")) + ^^ hardline + ^^ string "pushd $TEST_DIR > /dev/null" + ^^ hardline + + +let attempt cmd success failure = + separate_map space string [ "if"; cmd; ";"; "then" ] + ^^ nest 4 (hardline ^^ string ("echo \"" ^ success ^ "\"")) + ^^ hardline + ^^ string "else" + ^^ nest + 4 + (hardline ^^ string ("printf \"" ^ failure ^ "\"") ^^ hardline ^^ string "exit 1") + ^^ hardline + ^^ string "fi" + + +let compile ~filename_base = + string "# Compile" + ^^ hardline + ^^ attempt + (String.concat + " " + ([ "cc"; + "-g"; + "-c"; + "\"-I${RUNTIME_PREFIX}/include/\""; + "-o"; + "\"./" ^ filename_base ^ "_test.o\""; + "\"./" ^ filename_base ^ "_test.c\"" + ] + @ + if Config.is_coverage () then + [ "--coverage" ] + else + [])) + ("Compiled '" ^ filename_base ^ "_test.c'.") + ("Failed to compile '" ^ filename_base ^ "_test.c' in ${TEST_DIR}.") + ^^ (if Config.with_static_hack () then + empty + else + twice hardline + ^^ attempt + (String.concat + " " + ([ "cc"; + "-g"; + "-c"; + "\"-I${RUNTIME_PREFIX}/include/\""; + "-o"; + "\"./" ^ filename_base ^ "-exec.o\""; + "\"./" ^ filename_base ^ "-exec.c\"" + ] + @ + if Config.is_coverage () then + [ "--coverage" ] + else + [])) + ("Compiled '" ^ filename_base ^ "-exec.c'.") + ("Failed to compile '" ^ filename_base ^ "-exec.c' in ${TEST_DIR}.") + ^^ twice hardline + ^^ attempt + (String.concat + " " + ([ "cc"; + "-g"; + "-c"; + "\"-I${RUNTIME_PREFIX}/include/\""; + "-o"; + "\"./cn.o\""; + "\"./cn.c\"" + ] + @ + if Config.is_coverage () then + [ "--coverage" ] + else + [])) + "Compiled 'cn.c'." + "Failed to compile 'cn.c' in ${TEST_DIR}.") + ^^ hardline + + +let link ~filename_base = + string "# Link" + ^^ hardline + ^^ string "echo" + ^^ twice hardline + ^^ attempt + (String.concat + " " + ([ "cc"; + "-g"; + "\"-I${RUNTIME_PREFIX}/include\""; + "-o"; + "\"./tests.out\""; + (filename_base + ^ "_test.o" + ^ + if Config.with_static_hack () then + "" + else + " " ^ filename_base ^ "-exec.o cn.o"); + "\"${RUNTIME_PREFIX}/libcn.a\"" + ] + @ + if Config.is_coverage () then + [ "--coverage" ] + else + [])) + "Linked C *.o files." + "Failed to link *.o files in ${TEST_DIR}." + ^^ hardline + + +let run () = + let cmd = + separate_map + space + string + ([ "./tests.out" ] + @ (Config.has_input_timeout () + |> Option.map (fun input_timeout -> + [ "--input-timeout"; string_of_int input_timeout ]) + |> Option.to_list + |> List.flatten) + @ (Config.has_null_in_every () + |> Option.map (fun null_in_every -> + [ "--null-in-every"; string_of_int null_in_every ]) + |> Option.to_list + |> List.flatten) + @ (Config.has_seed () + |> Option.map (fun seed -> [ "--seed"; seed ]) + |> Option.to_list + |> List.flatten) + @ (Config.has_logging_level () + |> Option.map (fun level -> [ "--logging-level"; string_of_int level ]) + |> Option.to_list + |> List.flatten) + @ (Config.has_progress_level () + |> Option.map (fun level -> [ "--progress-level"; string_of_int level ]) + |> Option.to_list + |> List.flatten) + @ (if Config.is_interactive () then + [ "--interactive" ] + else + []) + @ (match Config.is_until_timeout () with + | Some timeout -> [ "--until-timeout"; string_of_int timeout ] + | None -> []) + @ (if Config.is_exit_fast () then + [ "--exit-fast" ] + else + []) + @ (Config.has_max_stack_depth () + |> Option.map (fun max_stack_depth -> + [ "--max-stack-depth"; string_of_int max_stack_depth ]) + |> Option.to_list + |> List.flatten) + @ (Config.has_max_generator_size () + |> Option.map (fun max_generator_size -> + [ "--max-generator-size"; string_of_int max_generator_size ]) + |> Option.to_list + |> List.flatten) + @ (if Config.is_sized_null () then + [ "--sized-null" ] + else + []) + @ (Config.has_allowed_depth_failures () + |> Option.map (fun allowed_depth_failures -> + [ "--allowed-depth-failures"; string_of_int allowed_depth_failures ]) + |> Option.to_list + |> List.flatten) + @ (Config.has_allowed_size_split_backtracks () + |> Option.map (fun allowed_size_split_backtracks -> + [ "--allowed-size-split-backtracks"; + string_of_int allowed_size_split_backtracks + ]) + |> Option.to_list + |> List.flatten)) + in + string "# Run" + ^^ hardline + ^^ string "echo" + ^^ twice hardline + ^^ cmd + ^^ hardline + ^^ string "test_exit_code=$? # Save tests exit code for later" + ^^ hardline + + +let coverage ~filename_base = + string "# Coverage" + ^^ hardline + ^^ attempt + ("gcov \"" ^ filename_base ^ "_test.c\"") + "Recorded coverage via gcov." + "Failed to record coverage." + ^^ twice hardline + ^^ attempt + "lcov --capture --directory . --output-file coverage.info" + "Collected coverage via lcov." + "Failed to collect coverage." + ^^ twice hardline + ^^ attempt + "genhtml --output-directory html \"coverage.info\"" + "Generated HTML report at '${TEST_DIR}/html/'." + "Failed to generate HTML report." + ^^ hardline + + +let generate ~(output_dir : string) ~(filename_base : string) : Pp.document = + setup ~output_dir + ^^ hardline + ^^ compile ~filename_base + ^^ hardline + ^^ link ~filename_base + ^^ hardline + ^^ run () + ^^ hardline + ^^ (if Config.is_coverage () then + coverage ~filename_base ^^ hardline + else + empty) + ^^ string "popd > /dev/null" + ^^ hardline + ^^ string "exit $test_exit_code" + ^^ hardline diff --git a/backend/cn/lib/testGeneration/buildScript.mli b/backend/cn/lib/testGeneration/buildScript.mli new file mode 100644 index 000000000..9d2928de2 --- /dev/null +++ b/backend/cn/lib/testGeneration/buildScript.mli @@ -0,0 +1 @@ +val generate : output_dir:string -> filename_base:string -> Pp.document diff --git a/backend/cn/lib/testGeneration/genAnalysis.ml b/backend/cn/lib/testGeneration/genAnalysis.ml index 38e2feaa0..8be2748ca 100644 --- a/backend/cn/lib/testGeneration/genAnalysis.ml +++ b/backend/cn/lib/testGeneration/genAnalysis.ml @@ -1,13 +1,12 @@ module CF = Cerb_frontend module BT = BaseTypes module IT = IndexTerms -module RET = ResourceTypes +module Req = Request module LC = LogicalConstraints -module RP = ResourcePredicates +module Def = Definition module LAT = LogicalArgumentTypes module GT = GenTerms -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) +module GD = GenDefinitions let rec is_pure (gt : GT.t) : bool = let (GT (gt_, _, _)) = gt in @@ -24,9 +23,9 @@ let rec is_pure (gt : GT.t) : bool = | Map _ -> false -let get_single_uses ?(pure : bool = false) (gt : GT.t) : SymSet.t = +let get_single_uses ?(pure : bool = false) (gt : GT.t) : Sym.Set.t = let union = - SymMap.union (fun _ oa ob -> + Sym.Map.union (fun _ oa ob -> Some (let open Option in let@ a = oa in @@ -34,172 +33,67 @@ let get_single_uses ?(pure : bool = false) (gt : GT.t) : SymSet.t = return (a + b))) in let it_value : int option = if pure then Some 1 else None in - let aux_it (it : IT.t) : int option SymMap.t = + let aux_it (it : IT.t) : int option Sym.Map.t = it |> IT.free_vars - |> SymSet.to_seq + |> Sym.Set.to_seq |> Seq.map (fun x -> (x, it_value)) - |> SymMap.of_seq + |> Sym.Map.of_seq in - let aux_lc (lc : LC.t) : int option SymMap.t = + let aux_lc (lc : LC.t) : int option Sym.Map.t = lc |> LC.free_vars - |> SymSet.to_seq + |> Sym.Set.to_seq |> Seq.map (fun x -> (x, it_value)) - |> SymMap.of_seq + |> Sym.Map.of_seq in - let rec aux (gt : GT.t) : int option SymMap.t = + let rec aux (gt : GT.t) : int option Sym.Map.t = let (GT (gt_, _, _)) = gt in match gt_ with - | Arbitrary | Uniform _ -> SymMap.empty + | Arbitrary | Uniform _ -> Sym.Map.empty | Pick wgts -> - wgts |> List.map snd |> List.map aux |> List.fold_left union SymMap.empty + wgts |> List.map snd |> List.map aux |> List.fold_left union Sym.Map.empty | Alloc it | Return it -> aux_it it | Call (_, iargs) -> - iargs |> List.map snd |> List.map aux_it |> List.fold_left union SymMap.empty + iargs |> List.map snd |> List.map aux_it |> List.fold_left union Sym.Map.empty | Asgn ((it_addr, _), it_val, gt') -> - aux gt' :: List.map aux_it [ it_addr; it_val ] |> List.fold_left union SymMap.empty - | Let (_, (x, gt1), gt2) -> SymMap.remove x (union (aux gt1) (aux gt2)) + aux gt' :: List.map aux_it [ it_addr; it_val ] |> List.fold_left union Sym.Map.empty + | Let (_, (x, gt1), gt2) -> Sym.Map.remove x (union (aux gt1) (aux gt2)) | Assert (lc, gt') -> union (aux gt') (aux_lc lc) | ITE (it_if, gt_then, gt_else) -> aux_it it_if :: List.map aux [ gt_then; gt_else ] - |> List.fold_left union SymMap.empty + |> List.fold_left union Sym.Map.empty | Map ((i, _, it_perm), gt') -> union (aux_it it_perm) - (gt' |> aux |> SymMap.remove i |> SymMap.map (Option.map (Int.add 1))) + (gt' |> aux |> Sym.Map.remove i |> Sym.Map.map (Option.map (Int.add 1))) in aux gt - |> SymMap.filter (fun _ -> Option.equal Int.equal (Some 1)) - |> SymMap.bindings + |> Sym.Map.filter (fun _ -> Option.equal Int.equal (Some 1)) + |> Sym.Map.bindings |> List.map fst - |> SymSet.of_list + |> Sym.Set.of_list -module Bounds = struct - let get_lower_bound ((x, bt) : Sym.sym * BT.t) (it : IT.t) : IT.t = - let min = - match bt with - | Bits (sign, sz) -> fst (BT.bits_range (sign, sz)) - | _ -> failwith "unsupported type for `each`" - in - let rec aux (it : IT.t) : IT.t option = - match it with - | IT (Binop (EQ, IT (Sym x', _, _), tm2), _, _) - | IT (Binop (EQ, tm2, IT (Sym x', _, _)), _, _) -> - if Sym.equal x x' then Some tm2 else None - | IT (Binop (LE, it', IT (Sym x', _, _)), _, _) when Sym.equal x x' -> Some it' - | IT (Binop (LT, it', IT (Sym x', _, _)), _, _) when Sym.equal x x' -> - Some - (IT - ( Binop (Add, it', IT.num_lit_ Z.one bt Cerb_location.unknown), - bt, - Cerb_location.unknown )) - | IT (Binop (And, tm1, tm2), _, _) -> - (match (aux tm1, aux tm2) with - | None, None -> None - | None, it' | it', None -> it' - | Some tm1, Some tm2 -> - Some (IT (Binop (Max, tm1, tm2), bt, Cerb_location.unknown))) - | IT (Binop (Or, tm1, tm2), _, _) -> - (match (aux tm1, aux tm2) with - | None, None | None, _ | _, None -> None - | Some tm1, Some tm2 -> - Some (IT (Binop (Min, tm1, tm2), bt, Cerb_location.unknown))) - | _ -> None - in - aux it |> Option.value ~default:(IT.num_lit_ min bt Cerb_location.unknown) - - - let get_upper_bound ((x, bt) : Sym.sym * BT.t) (it : IT.t) : IT.t = - let max = - match bt with - | Bits (sign, sz) -> snd (BT.bits_range (sign, sz)) - | _ -> failwith "unsupported type for `each`" - in - let rec aux (it : IT.t) : IT.t option = - match it with - | IT (Binop (EQ, IT (Sym x', _, _), tm2), _, _) - | IT (Binop (EQ, tm2, IT (Sym x', _, _)), _, _) -> - if Sym.equal x x' then Some tm2 else None - | IT (Binop (LE, IT (Sym x', _, _), it'), _, _) when Sym.equal x x' -> Some it' - | IT (Binop (LT, IT (Sym x', _, _), it'), _, _) when Sym.equal x x' -> - Some - (IT - ( Binop (Sub, it', IT.num_lit_ Z.one bt Cerb_location.unknown), - bt, - Cerb_location.unknown )) - | IT (Binop (And, tm1, tm2), _, _) -> - (match (aux tm1, aux tm2) with - | None, None -> None - | None, it' | it', None -> it' - | Some tm1, Some tm2 -> - Some (IT (Binop (Min, tm1, tm2), bt, Cerb_location.unknown))) - | IT (Binop (Or, tm1, tm2), _, _) -> - (match (aux tm1, aux tm2) with - | None, None | None, _ | _, None -> None - | Some tm1, Some tm2 -> - Some (IT (Binop (Max, tm1, tm2), bt, Cerb_location.unknown))) - | _ -> None - in - aux it |> Option.value ~default:(IT.num_lit_ max bt Cerb_location.unknown) - - - let get_bounds ((x, bt) : Sym.sym * BT.t) (it : IT.t) : IT.t * IT.t = - (get_lower_bound (x, bt) it, get_upper_bound (x, bt) it) -end - -let get_bounds = Bounds.get_bounds - -let get_addr_offset_opt (it : IT.t) : (Sym.t * IT.t) option = - let (IT (it_, _, loc)) = it in - match it_ with - | ArrayShift { base = IT (Sym p_sym, _, _); ct; index = it_offset } -> - let it_offset = - if BT.equal (IT.bt it_offset) Memory.size_bt then - it_offset - else - IT.cast_ Memory.size_bt it_offset loc - in - Some (p_sym, IT.mul_ (IT.sizeOf_ ct loc, it_offset) loc) - | Binop (Add, IT (Sym p_sym, _, _), it_offset) -> - let it_offset = - if BT.equal (IT.bt it_offset) Memory.size_bt then - it_offset - else - IT.cast_ Memory.size_bt it_offset loc - in - Some (p_sym, it_offset) - | Sym p_sym -> Some (p_sym, IT.num_lit_ Z.zero Memory.size_bt loc) - | _ -> None - - -let get_addr_offset (it : IT.t) : Sym.t * IT.t = - match get_addr_offset_opt it with - | Some r -> r - | None -> - failwith ("unsupported format for address: " ^ CF.Pp_utils.to_plain_string (IT.pp it)) - - -let get_recursive_preds (preds : (Sym.t * RP.definition) list) : SymSet.t = - let get_calls (pred : RP.definition) : SymSet.t = +let get_recursive_preds (preds : (Sym.t * Def.Predicate.t) list) : Sym.Set.t = + let get_calls (pred : Def.Predicate.t) : Sym.Set.t = pred.clauses |> Option.get - |> List.map (fun (cl : RP.clause) -> cl.packing_ft) + |> List.map (fun (cl : Def.Clause.t) -> cl.packing_ft) |> List.map LAT.r_resource_requests |> List.flatten |> List.map snd |> List.map fst - |> List.map ResourceTypes.predicate_name - |> List.filter_map (fun (n : RET.predicate_name) -> + |> List.map Req.get_name + |> List.filter_map (fun (n : Req.name) -> match n with PName name -> Some name | Owned _ -> None) - |> SymSet.of_list + |> Sym.Set.of_list in let module G = Graph.Persistent.Digraph.Concrete (Sym) in let g = List.fold_left (fun g (fsym, pred) -> - SymSet.fold (fun gsym g' -> G.add_edge g' fsym gsym) (get_calls pred) g) + Sym.Set.fold (fun gsym g' -> G.add_edge g' fsym gsym) (get_calls pred) g) G.empty preds in @@ -208,4 +102,37 @@ let get_recursive_preds (preds : (Sym.t * RP.definition) list) : SymSet.t = preds |> List.map fst |> List.filter (fun fsym -> G.mem_edge closure fsym fsym) - |> SymSet.of_list + |> Sym.Set.of_list + + +module SymGraph = Graph.Persistent.Digraph.Concrete (Sym) + +open struct + let get_calls (gd : GD.t) : Sym.Set.t = + let rec aux (gt : GT.t) : Sym.Set.t = + let (GT (gt_, _, _)) = gt in + match gt_ with + | Arbitrary | Uniform _ | Alloc _ | Return _ -> Sym.Set.empty + | Pick wgts -> + wgts |> List.map snd |> List.map aux |> List.fold_left Sym.Set.union Sym.Set.empty + | Call (fsym, _) -> Sym.Set.singleton fsym + | Asgn (_, _, gt') | Assert (_, gt') | Map (_, gt') -> aux gt' + | Let (_, (_, gt1), gt2) | ITE (_, gt1, gt2) -> Sym.Set.union (aux gt1) (aux gt2) + in + aux (Option.get gd.body) + + + module SymGraph = Graph.Persistent.Digraph.Concrete (Sym) + module Oper = Graph.Oper.P (SymGraph) +end + +let get_call_graph (ctx : GD.context) : SymGraph.t = + ctx + |> List.map_snd (List.map snd) + |> List.map_snd (fun gds -> match gds with [ gd ] -> gd | _ -> failwith __LOC__) + |> List.map_snd get_calls + |> List.fold_left + (fun cg (fsym, calls) -> + Sym.Set.fold (fun fsym' cg' -> SymGraph.add_edge cg' fsym fsym') calls cg) + SymGraph.empty + |> Oper.transitive_closure diff --git a/backend/cn/lib/testGeneration/genBuiltins.ml b/backend/cn/lib/testGeneration/genBuiltins.ml index 5babfce49..16a1d6dac 100644 --- a/backend/cn/lib/testGeneration/genBuiltins.ml +++ b/backend/cn/lib/testGeneration/genBuiltins.ml @@ -31,13 +31,15 @@ let gen_syms_bits (name : string) : (BT.t * Sym.t) list = let mult_check (it_mult : IT.t) gt loc = - GT.assert_ (T (IT.gt_ (it_mult, IT.num_lit_ Z.zero (IT.bt it_mult) loc) loc), gt) loc + GT.assert_ + (T (IT.gt_ (it_mult, IT.num_lit_ Z.zero (IT.get_bt it_mult) loc) loc), gt) + loc let lt_check (it_max : IT.t) gt loc = - let sgn, sz = Option.get (BT.is_bits_bt (IT.bt it_max)) in + let sgn, sz = Option.get (BT.is_bits_bt (IT.get_bt it_max)) in let min, _ = BT.bits_range (sgn, sz) in - GT.assert_ (T (IT.gt_ (it_max, IT.num_lit_ min (IT.bt it_max) loc) loc), gt) loc + GT.assert_ (T (IT.gt_ (it_max, IT.num_lit_ min (IT.get_bt it_max) loc) loc), gt) loc let range_check (it_min : IT.t) (it_max : IT.t) gt loc = @@ -139,13 +141,13 @@ let aligned_alloc_gen_sym = Sym.fresh_named "cn_gen_aligned_alloc" let aligned_alloc_gen (it_align : IT.t) (it_size : IT.t) loc : GT.t = let it_align = - if BT.equal (IT.bt it_align) Memory.size_bt then + if BT.equal (IT.get_bt it_align) Memory.size_bt then it_align else IT.cast_ Memory.size_bt it_align loc in let it_size = - if BT.equal (IT.bt it_size) Memory.size_bt then + if BT.equal (IT.get_bt it_size) Memory.size_bt then it_size else IT.cast_ Memory.size_bt it_align loc diff --git a/backend/cn/lib/testGeneration/genCodeGen.ml b/backend/cn/lib/testGeneration/genCodeGen.ml index e32911a4c..808624e28 100644 --- a/backend/cn/lib/testGeneration/genCodeGen.ml +++ b/backend/cn/lib/testGeneration/genCodeGen.ml @@ -6,9 +6,7 @@ module Utils = Executable_spec_utils module BT = BaseTypes module IT = IndexTerms module LC = LogicalConstraints -module GT = GenTerms module GR = GenRuntime -module SymSet = Set.Make (Sym) let mk_expr = Utils.mk_expr @@ -47,6 +45,7 @@ let compile_lc (sigma : CF.GenTypes.genTypeCategory A.sigma) (lc : LC.t) = let rec compile_term (sigma : CF.GenTypes.genTypeCategory A.sigma) + (ctx : GR.context) (name : Sym.t) (tm : GR.term) : A.bindings @@ -55,25 +54,22 @@ let rec compile_term = let loc = Locations.other __LOC__ in match tm with - | Uniform { bt; sz } -> + | Uniform { bt; sz = _ } -> ( [], [], A.( mk_expr (AilEcall ( mk_expr (AilEident (Sym.fresh_named "CN_GEN_UNIFORM")), - List.map - mk_expr - [ AilEident (Sym.fresh_named (name_of_bt name bt)); - AilEconst (ConstantInteger (IConstant (Z.of_int sz, Decimal, None))) - ] ))) ) + List.map mk_expr [ AilEident (Sym.fresh_named (name_of_bt name bt)) ] ))) + ) | Pick { bt; choice_var; choices; last_var } -> let var = Sym.fresh () in let bs, ss = List.split (List.mapi (fun i (_, gr) -> - let bs, ss, e = compile_term sigma name gr in + let bs, ss, e = compile_term sigma ctx name gr in ( bs, A.( [ AilSexpr @@ -131,13 +127,48 @@ let rec compile_term [ mk_expr (AilEident choice_var) ] ))) ], A.(mk_expr (AilEident var)) ) - | Alloc { bytes = it } -> - let alloc_sym = Sym.fresh_named "cn_gen_alloc" in + | Alloc { bytes = it; sized } -> + let alloc_sym = + Sym.fresh_named (if sized then "CN_GEN_ALLOC_SIZED" else "CN_GEN_ALLOC") + in let b, s, e = compile_it sigma name it in - (b, s, mk_expr (AilEcall (mk_expr (AilEident alloc_sym), [ e ]))) - | Call { fsym; iargs; oarg_bt } -> + let es = + if sized then + [ e; mk_expr (AilEident (Sym.fresh_named "cn_gen_rec_size")) ] + else + [ e ] + in + (b, s, mk_expr (AilEcall (mk_expr (AilEident alloc_sym), es))) + | Call { fsym; iargs; oarg_bt; path_vars; sized } -> let sym = GenUtils.get_mangled_name (fsym :: List.map fst iargs) in - let es = iargs |> List.map snd |> List.map (fun x -> A.(mk_expr (AilEident x))) in + let es = iargs |> List.map snd |> List.map (fun x -> A.(AilEident x)) in + let sized_call = + A.( + match sized with + | Some (n, _) when n <= 0 -> failwith "Invalid sized call" + | Some (1, _) -> + [ AilEbinary + ( mk_expr (AilEident (Sym.fresh_named "cn_gen_rec_size")), + Arithmetic Sub, + mk_expr (AilEconst (ConstantInteger (IConstant (Z.one, Decimal, None)))) + ) + ] + | Some (_, sym_size) when TestGenConfig.is_random_size_splits () -> + [ AilEident sym_size ] + | Some (n, _) -> + [ AilEbinary + ( mk_expr (AilEident (Sym.fresh_named "cn_gen_rec_size")), + Arithmetic Div, + mk_expr + (AilEconst (ConstantInteger (IConstant (Z.of_int n, Decimal, None)))) ) + ] + | None + when (not (GenBuiltins.is_builtin fsym)) + && (ctx |> List.assoc Sym.equal fsym |> List.hd |> snd).sized -> + [ AilEcall (mk_expr (AilEident (Sym.fresh_named "cn_gen_get_size")), []) ] + | None -> []) + in + let es = List.map mk_expr (es @ sized_call) in let x = Sym.fresh () in let b = Utils.create_binding x (bt_to_ctype fsym oarg_bt) in let wrap_to_string (sym : Sym.t) = @@ -156,21 +187,31 @@ let rec compile_term (AilEcall (mk_expr (AilEident (Sym.fresh_named name)), List.map mk_expr vars))) in ( [ b ], - [ AilSdeclaration [ (x, Some (mk_expr (AilEcall (mk_expr (AilEident sym), es)))) ]; - macro_call "CN_GEN_CALL_FROM" from_vars; - macro_call "CN_GEN_CALL_TO" to_vars - ], + ([ A.AilSdeclaration + [ (x, Some (mk_expr (AilEcall (mk_expr (AilEident sym), es)))) ] + ] + @ + if GenBuiltins.is_builtin sym then + [] + else + (if List.is_empty from_vars then + [] + else + [ macro_call "CN_GEN_CALL_FROM" from_vars; + macro_call "CN_GEN_CALL_TO" to_vars + ]) + @ + if Sym.Set.is_empty path_vars then + [] + else + [ macro_call + "CN_GEN_CALL_PATH_VARS" + (path_vars |> Sym.Set.to_seq |> List.of_seq |> List.map wrap_to_string) + ]), mk_expr (AilEident x) ) - | Asgn { pointer; offset; sct; value; last_var; rest } -> + | Asgn { pointer; addr; sct; value; last_var; rest } -> let tmp_sym = Sym.fresh () in - let bt = BT.Bits (Unsigned, 64) in - let offset = - if BT.equal (IT.bt offset) bt then - offset - else - IT.cast_ bt offset (Locations.other __LOC__) - in - let b1, s1, e1 = compile_it sigma name offset in + let b1, s1, e1 = compile_it sigma name addr in let b2, s2, AnnotatedExpression (_, _, _, e2_) = compile_it sigma name value in let b3 = [ Utils.create_binding tmp_sym C.(mk_ctype_pointer no_qualifiers void) ] in let s3 = @@ -189,7 +230,7 @@ let rec compile_term ~executable_spec:true C.no_qualifiers (Sctypes.to_ctype sct))))); - mk_expr (CtA.wrap_with_convert_from e2_ (IT.bt value)); + mk_expr (CtA.wrap_with_convert_from e2_ (IT.get_bt value)); mk_expr (AilEident (Sym.fresh ())); mk_expr (AilEcast @@ -210,12 +251,11 @@ let rec compile_term ( None, [ (Locations.other __LOC__, [ Sym.pp_string x ]) ] )) ))) - (List.of_seq - (SymSet.to_seq (SymSet.add pointer (IT.free_vars offset)))) + (List.of_seq (Sym.Set.to_seq (IT.free_vars addr))) @ [ mk_expr (AilEconst ConstantNull) ] ))) ] in - let b4, s4, e4 = compile_term sigma name rest in + let b4, s4, e4 = compile_term sigma ctx name rest in (b1 @ b2 @ b3 @ b4, s1 @ s2 @ s3 @ s4, e4) | Let { backtracks; x; x_bt; value; last_var; rest } -> let s1 = @@ -233,7 +273,7 @@ let rec compile_term ] ))) ] in - let b2, s2, e2 = compile_term sigma name value in + let b2, s2, e2 = compile_term sigma ctx name value in let s3 = A.( [ AilSexpr @@ -248,7 +288,13 @@ let rec compile_term (Option.value ~default:name (match value with - | Call { fsym; iargs; oarg_bt = _ } -> + | Call + { fsym; + iargs; + oarg_bt = _; + path_vars = _; + sized = _ + } -> Some (GenUtils.get_mangled_name (fsym :: List.map fst iargs)) @@ -281,11 +327,11 @@ let rec compile_term ( None, [ (Locations.other __LOC__, [ Sym.pp_string x ]) ] )) ))) - (List.of_seq (GR.SymSet.to_seq (GR.free_vars_term value))) + (List.of_seq (Sym.Set.to_seq (GR.free_vars_term value))) @ [ mk_expr (AilEconst ConstantNull) ] ))) ]) in - let b4, s4, e4 = compile_term sigma name rest in + let b4, s4, e4 = compile_term sigma ctx name rest in (b2 @ [ Utils.create_binding x (bt_to_ctype name x_bt) ] @ b4, s1 @ s2 @ s3 @ s4, e4) | Return { value } -> let b, s, e = compile_it sigma name value in @@ -311,16 +357,16 @@ let rec compile_term ( None, [ (Locations.other __LOC__, [ Sym.pp_string x ]) ] )) ))) - (List.of_seq (SymSet.to_seq (LC.free_vars prop))) + (List.of_seq (Sym.Set.to_seq (LC.free_vars prop))) @ [ mk_expr (AilEconst ConstantNull) ] ))) ] in - let b2, s2, e2 = compile_term sigma name rest in + let b2, s2, e2 = compile_term sigma ctx name rest in (b1 @ b2, s1 @ s_assert @ s2, e2) | ITE { bt; cond; t; f } -> let b_if, s_if, e_if = compile_it sigma name cond in - let b_then, s_then, e_then = compile_term sigma name t in - let b_else, s_else, e_else = compile_term sigma name f in + let b_then, s_then, e_then = compile_term sigma ctx name t in + let b_else, s_else, e_else = compile_term sigma ctx name f in let res_sym = Sym.fresh () in let res_expr = mk_expr (AilEident res_sym) in let res_binding = Utils.create_binding res_sym (bt_to_ctype name bt) in @@ -376,7 +422,7 @@ let rec compile_term [ (Locations.other __LOC__, [ Sym.pp_string x ]) ] )) ))) (List.of_seq - (SymSet.to_seq (SymSet.remove i (IT.free_vars perm)))) + (Sym.Set.to_seq (Sym.Set.remove i (IT.free_vars perm)))) @ [ mk_expr (AilEconst ConstantNull) ] ))) ]) in @@ -389,7 +435,7 @@ let rec compile_term (mk_expr (AilEident (Sym.fresh_named "CN_GEN_MAP_BODY")), [ e_perm ]))) ]) in - let b_val, s_val, e_val = compile_term sigma name inner in + let b_val, s_val, e_val = compile_term sigma ctx name inner in let s_end = A.( s_val @@ -403,16 +449,57 @@ let rec compile_term ( [ b_map; b_i ] @ b_min @ b_perm @ b_val, s_begin @ s_body @ s_end, mk_expr (AilEident sym_map) ) + | SplitSize { rest; _ } when not (TestGenConfig.is_random_size_splits ()) -> + compile_term sigma ctx name rest + | SplitSize { marker_var; syms; path_vars; last_var; rest } -> + let e_tmp = mk_expr (AilEident marker_var) in + let e_size = mk_expr (AilEident (Sym.fresh_named "cn_gen_rec_size")) in + let syms_l = syms |> Sym.Set.to_seq |> List.of_seq in + let b = + syms_l |> List.map (fun x -> Utils.create_binding x (C.mk_ctype_integer Size_t)) + in + let e_syms = + syms_l |> List.map (fun x -> mk_expr (AilEunary (Address, mk_expr (AilEident x)))) + in + let wrap_to_string (sym : Sym.t) = + let open A in + mk_expr + (AilEcast + ( C.no_qualifiers, + C.pointer_to_char, + mk_expr + (AilEstr (None, [ (Locations.other __LOC__, [ Sym.pp_string sym ]) ])) )) + in + let s = + let open A in + List.map (fun x -> AilSdeclaration [ (x, None) ]) syms_l + @ [ AilSexpr + (mk_expr + (AilEcall + ( mk_expr (AilEident (Sym.fresh_named "CN_GEN_SPLIT_BEGIN")), + [ e_tmp; e_size ] @ e_syms @ [ mk_expr (AilEconst ConstantNull) ] ))); + AilSexpr + (mk_expr + (AilEcall + ( mk_expr (AilEident (Sym.fresh_named "CN_GEN_SPLIT_END")), + [ e_tmp; e_size; mk_expr (AilEident last_var) ] + @ List.map wrap_to_string (List.of_seq (Sym.Set.to_seq path_vars)) + @ [ mk_expr (AilEconst ConstantNull) ] ))) + ] + in + let b', s', e' = compile_term sigma ctx name rest in + (b @ b', s @ s', e') let compile_gen_def (sigma : CF.GenTypes.genTypeCategory A.sigma) + (ctx : GR.context) ((name, gr) : Sym.t * GR.definition) : A.sigma_tag_definition * (A.sigma_declaration * 'a A.sigma_function_definition) = let loc = Locations.other __LOC__ in let bt_ret = - BT.Record (List.map (fun (x, bt) -> (Id.id (Sym.pp_string x), bt)) gr.oargs) + BT.Record (List.map (fun (x, bt) -> (Id.make loc (Sym.pp_string x), bt)) gr.oargs) in let struct_def = CtA.generate_record_opt name bt_ret |> Option.get in let ct_ret = C.(mk_ctype_pointer no_qualifiers (Ctype ([], Struct (fst struct_def)))) in @@ -420,7 +507,12 @@ let compile_gen_def A.Decl_function ( false, (C.no_qualifiers, ct_ret), - List.map (fun (_, bt) -> (C.no_qualifiers, bt_to_ctype name bt, false)) gr.iargs, + (List.map (fun (_, bt) -> (C.no_qualifiers, bt_to_ctype name bt, false)) gr.iargs + @ + if gr.sized then + [ (C.no_qualifiers, C.mk_ctype_integer Size_t, false) ] + else + []), false, false, false ) @@ -429,15 +521,26 @@ let compile_gen_def let s1 = A.( AilSexpr - (mk_expr (AilEcall (mk_expr (AilEident (Sym.fresh_named "CN_GEN_INIT")), [])))) + (mk_expr + (if gr.sized then + AilEcall + ( mk_expr (AilEident (Sym.fresh_named "CN_GEN_INIT_SIZED")), + [ mk_expr (AilEident (Sym.fresh_named "cn_gen_rec_size")) ] ) + else + AilEcall (mk_expr (AilEident (Sym.fresh_named "CN_GEN_INIT")), [])))) in - let b2, s2, e2 = compile_term sigma name gr.body in + let b2, s2, e2 = compile_term sigma ctx name gr.body in let sigma_def : CF.GenTypes.genTypeCategory A.sigma_function_definition = ( name, ( loc, 0, CF.Annot.Attrs [], - List.map fst gr.iargs, + (List.map fst gr.iargs + @ + if gr.sized then + [ Sym.fresh_named "cn_gen_rec_size" ] + else + []), mk_stmt (A.AilSblock ( b2, @@ -445,6 +548,14 @@ let compile_gen_def mk_stmt ([ s1 ] @ s2 + @ A. + [ AilSexpr + (mk_expr + (AilEcall + ( mk_expr + (AilEident (Sym.fresh_named "cn_gen_decrement_depth")), + [] ))) + ] @ A. [ AilSreturn (mk_expr @@ -473,11 +584,12 @@ let compile (sigma : CF.GenTypes.genTypeCategory A.sigma) (ctx : GR.context) : P in defs |> List.iter (fun ((name, def) : Sym.t * GR.definition) -> + let loc = Locations.other __LOC__ in let bt = - BT.Record (List.map (fun (x, bt) -> (Id.id (Sym.pp_string x), bt)) def.oargs) + BT.Record (List.map (fun (x, bt) -> (Id.make loc (Sym.pp_string x), bt)) def.oargs) in CtA.augment_record_map ~cn_sym:name bt); - let tag_definitions, funcs = List.split (List.map (compile_gen_def sigma) defs) in + let tag_definitions, funcs = List.split (List.map (compile_gen_def sigma ctx) defs) in let declarations, function_definitions = List.split funcs in let sigma : 'a A.sigma = { A.empty_sigma with tag_definitions; declarations; function_definitions } diff --git a/backend/cn/lib/testGeneration/genCompile.ml b/backend/cn/lib/testGeneration/genCompile.ml index e0b2acb66..17cdf045a 100644 --- a/backend/cn/lib/testGeneration/genCompile.ml +++ b/backend/cn/lib/testGeneration/genCompile.ml @@ -3,15 +3,12 @@ module BT = BaseTypes module AT = ArgumentTypes module LC = LogicalConstraints module LAT = LogicalArgumentTypes -module RP = ResourcePredicates -module RET = ResourceTypes +module Def = Definition +module Req = Request module GBT = GenBaseTypes module GT = GenTerms module GD = GenDefinitions module Config = TestGenConfig -module CtA = Cn_internal_to_ail -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) type s = GD.context @@ -34,15 +31,15 @@ let compile_oargs (ret_bt : BT.t) (iargs : (Sym.t * BT.t) list) : (Sym.t * BT.t) let add_request - (recursive : SymSet.t) - (preds : (SymMap.key * RP.definition) list) + (recursive : Sym.Set.t) + (preds : (Sym.Map.key * Def.Predicate.t) list) (fsym : Sym.t) : unit m = let pred = List.assoc Sym.equal fsym preds in let gd : GD.t = { filename = Option.get (Cerb_location.get_filename pred.loc); - recursive = SymSet.mem fsym recursive; + recursive = Sym.Set.mem fsym recursive; spec = false; name = fsym; iargs = @@ -55,8 +52,8 @@ let add_request fun s -> ((), GD.add_context gd s) -let compile_vars (generated : SymSet.t) (oargs : (Sym.t * GBT.t) list) (lat : IT.t LAT.t) - : SymSet.t * (GT.t -> GT.t) +let compile_vars (generated : Sym.Set.t) (oargs : (Sym.t * GBT.t) list) (lat : IT.t LAT.t) + : Sym.Set.t * (GT.t -> GT.t) = let backtrack_num = Config.get_max_backtracks () in let rec aux (xbts : (Sym.t * BT.t) list) : GT.t -> GT.t = @@ -71,14 +68,14 @@ let compile_vars (generated : SymSet.t) (oargs : (Sym.t * GBT.t) list) (lat : IT in let xs, xbts = match lat with - | Define ((x, it), _info, _) -> (SymSet.singleton x, IT.free_vars_bts it) + | Define ((x, it), _info, _) -> (Sym.Set.singleton x, IT.free_vars_bts it) | Resource ((x, ((P { name = Owned _; _ } as ret), bt)), _, _) -> - (SymSet.singleton x, SymMap.add x bt (RET.free_vars_bts ret)) - | Resource ((x, (ret, _)), _, _) -> (SymSet.singleton x, RET.free_vars_bts ret) - | Constraint (lc, _, _) -> (SymSet.empty, LC.free_vars_bts lc) + (Sym.Set.singleton x, Sym.Map.add x bt (Req.free_vars_bts ret)) + | Resource ((x, (ret, _)), _, _) -> (Sym.Set.singleton x, Req.free_vars_bts ret) + | Constraint (lc, _, _) -> (Sym.Set.empty, LC.free_vars_bts lc) | I it -> - ( SymSet.empty, - SymMap.union + ( Sym.Set.empty, + Sym.Map.union (fun _ bt1 bt2 -> assert (BT.equal bt1 bt2); Some bt1) @@ -87,23 +84,23 @@ let compile_vars (generated : SymSet.t) (oargs : (Sym.t * GBT.t) list) (lat : IT |> List.filter (fun (x, _) -> not (Sym.equal x cn_return)) |> List.map_snd GBT.bt |> List.to_seq - |> SymMap.of_seq) ) + |> Sym.Map.of_seq) ) in let xbts = - xbts |> SymMap.filter (fun x _ -> not (SymSet.mem x generated)) |> SymMap.bindings + xbts |> Sym.Map.filter (fun x _ -> not (Sym.Set.mem x generated)) |> Sym.Map.bindings in let generated = - xbts |> List.map fst |> SymSet.of_list |> SymSet.union generated |> SymSet.union xs + xbts |> List.map fst |> Sym.Set.of_list |> Sym.Set.union generated |> Sym.Set.union xs in (generated, aux xbts) let rec compile_it_lat (filename : string) - (recursive : SymSet.t) - (preds : (Sym.t * RP.definition) list) + (recursive : Sym.Set.t) + (preds : (Sym.t * Def.Predicate.t) list) (name : Sym.t) - (generated : SymSet.t) + (generated : Sym.Set.t) (oargs : (Sym.t * GBT.t) list) (lat : IT.t LAT.t) : GT.t m @@ -116,13 +113,13 @@ let rec compile_it_lat match lat with | Define ((x, it), (loc, _), lat') -> let@ gt' = compile_it_lat filename recursive preds name generated oargs lat' in - return (GT.let_ (backtrack_num, (x, GT.return_ it (IT.loc it)), gt') loc) + return (GT.let_ (backtrack_num, (x, GT.return_ it (IT.get_loc it)), gt') loc) | Resource ((x, (P { name = Owned (ct, _); pointer; iargs = _ }, bt)), (loc, _), lat') -> let@ gt' = compile_it_lat filename recursive preds name generated oargs lat' in let gt_asgn = GT.asgn_ ((pointer, ct), IT.sym_ (x, bt, loc), gt') loc in let gt_val = - if SymSet.mem x generated then + if Sym.Set.mem x generated then gt_asgn else GT.let_ (backtrack_num, (x, GT.arbitrary_ bt loc), gt_asgn) loc @@ -133,7 +130,8 @@ let rec compile_it_lat -> let here = Locations.other __LOC__ in let ret_bt = - BT.Record (compile_oargs bt [] |> List.map_fst (fun x -> Id.id (Sym.pp_string x))) + BT.Record + (compile_oargs bt [] |> List.map_fst (fun x -> Id.make here (Sym.pp_string x))) in (* Recurse *) let@ gt' = @@ -185,7 +183,7 @@ let rec compile_it_lat let gt_body = let sym_val = Sym.fresh () in let it_q = IT.sym_ (q_sym, k_bt, q_loc) in - let it_p = IT.add_ (pointer, IT.mul_ (it_q, step) (IT.loc step)) loc in + let it_p = IT.add_ (pointer, IT.mul_ (it_q, step) (IT.get_loc step)) loc in let gt_asgn = GT.asgn_ ( (it_p, ct), @@ -220,15 +218,17 @@ let rec compile_it_lat let pred = List.assoc Sym.equal fsym preds in let arg_syms = pred.pointer :: fst (List.split pred.iargs) in let it_q = IT.sym_ (q_sym, q_bt, q_loc) in - let it_p = IT.add_ (pointer, IT.mul_ (it_q, step) (IT.loc step)) loc in + let it_p = IT.add_ (pointer, IT.mul_ (it_q, step) (IT.get_loc step)) loc in let arg_its = it_p :: iargs in let args = List.combine arg_syms arg_its in (* Build [GT.t] *) let _, v_bt = BT.map_bt bt in let gt_body = + let here = Locations.other __LOC__ in let ret_bt = BT.Record - (compile_oargs v_bt [] |> List.map_fst (fun x -> Id.id (Sym.pp_string x))) + (compile_oargs v_bt [] + |> List.map_fst (fun x -> Id.make here (Sym.pp_string x))) in let y = Sym.fresh () in if BT.equal (BT.Record []) ret_bt then @@ -241,7 +241,7 @@ let rec compile_it_lat let it_ret = IT.recordMember_ ~member_bt:v_bt - (IT.sym_ (y, ret_bt, loc), Id.id "cn_return") + (IT.sym_ (y, ret_bt, loc), Id.make here "cn_return") loc in GT.let_ (0, (y, GT.call_ (fsym, args) ret_bt loc), GT.return_ it_ret loc) loc) @@ -262,21 +262,23 @@ let rec compile_it_lat | _ -> conv_fn oargs in let it_ret = - IT.record_ (List.map_fst (fun sym -> Id.id (Sym.pp_string sym)) it_oargs) here + IT.record_ + (List.map_fst (fun sym -> Id.make here (Sym.pp_string sym)) it_oargs) + here in - return (GT.return_ it_ret (IT.loc it)) + return (GT.return_ it_ret (IT.get_loc it)) in return (f_gt_init gt) let rec compile_clauses (filename : string) - (recursive : SymSet.t) - (preds : (Sym.t * RP.definition) list) + (recursive : Sym.Set.t) + (preds : (Sym.t * Def.Predicate.t) list) (name : Sym.t) - (iargs : SymSet.t) + (iargs : Sym.Set.t) (oargs : (Sym.t * GBT.t) list) - (cls : RP.clause list) + (cls : Def.Clause.t list) : GT.t m = match cls with @@ -294,8 +296,8 @@ let rec compile_clauses let compile_pred - (recursive_preds : SymSet.t) - (preds : (Sym.t * RP.definition) list) + (recursive_preds : Sym.Set.t) + (preds : (Sym.t * Def.Predicate.t) list) ({ filename; recursive; spec; name; iargs; oargs; body } : GD.t) : unit m = @@ -307,7 +309,7 @@ let compile_pred recursive_preds preds name - (SymSet.of_list (List.map fst iargs)) + (Sym.Set.of_list (List.map fst iargs)) oargs (Option.get pred.clauses) in @@ -317,21 +319,21 @@ let compile_pred let compile_spec (filename : string) - (recursive : SymSet.t) - (preds : (Sym.t * RP.definition) list) + (recursive : Sym.Set.t) + (preds : (Sym.t * Def.Predicate.t) list) (name : Sym.t) (at : 'a AT.t) : unit m = (* Necessary to avoid triggering special-cased logic in [CtA] w.r.t globals *) - let rename x = Sym.fresh_named ("cn_gen_" ^ Sym.pp_string x) in + let rename x = GenUtils.get_mangled_name [ x ] in let lat = let lat = AT.get_lat at in let subst = let loc = Locations.other __LOC__ in lat - |> LAT.free_vars_bts (fun _ -> SymMap.empty) - |> SymMap.bindings + |> LAT.free_vars_bts (fun _ -> Sym.Map.empty) + |> Sym.Map.bindings |> List.map (fun (x, bt) -> (x, IT.sym_ (rename x, bt, loc))) |> IT.make_subst |> LAT.subst (fun _ x -> x) @@ -342,8 +344,8 @@ let compile_spec let oargs = let oargs' = lat - |> LAT.free_vars_bts (fun _ -> SymMap.empty) - |> SymMap.bindings + |> LAT.free_vars_bts (fun _ -> Sym.Map.empty) + |> Sym.Map.bindings |> List.map_snd GBT.of_bt in oargs' @@ -364,7 +366,7 @@ let compile_spec recursive preds name - SymSet.empty + Sym.Set.empty oargs (LAT.map (fun _ -> IT.unit_ here) lat) in @@ -376,14 +378,14 @@ let compile_spec let compile ?(ctx : GD.context option) - (preds : (Sym.t * RP.definition) list) - (insts : Core_to_mucore.instrumentation list) + (preds : (Sym.t * Def.Predicate.t) list) + (insts : Executable_spec_extract.instrumentation list) : GD.context = let recursive_preds = GenAnalysis.get_recursive_preds preds in let context_specs = insts - |> List.map (fun (inst : Core_to_mucore.instrumentation) -> + |> List.map (fun (inst : Executable_spec_extract.instrumentation) -> compile_spec (Option.get (Cerb_location.get_filename inst.fn_loc)) recursive_preds diff --git a/backend/cn/lib/testGeneration/genCompile.mli b/backend/cn/lib/testGeneration/genCompile.mli index 81d611e08..0c38fcc34 100644 --- a/backend/cn/lib/testGeneration/genCompile.mli +++ b/backend/cn/lib/testGeneration/genCompile.mli @@ -1,5 +1,5 @@ val compile : ?ctx:GenDefinitions.context -> - (Sym.t * ResourcePredicates.definition) list -> - Core_to_mucore.instrumentation list -> + (Sym.t * Definition.Predicate.t) list -> + Executable_spec_extract.instrumentation list -> GenDefinitions.context diff --git a/backend/cn/lib/testGeneration/genDistribute.ml b/backend/cn/lib/testGeneration/genDistribute.ml index e368367c8..42056f14f 100644 --- a/backend/cn/lib/testGeneration/genDistribute.ml +++ b/backend/cn/lib/testGeneration/genDistribute.ml @@ -3,9 +3,6 @@ module IT = IndexTerms module LC = LogicalConstraints module GT = GenTerms module GD = GenDefinitions -module GA = GenAnalysis -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) module Config = TestGenConfig let generated_size (bt : BT.t) : int = @@ -43,18 +40,19 @@ let apply_array_max_length (gt : GT.t) : GT.t = | Assert (lc, gt') -> GT.assert_ (lc, aux gt') here | ITE (it_if, gt_then, gt_else) -> GT.ite_ (it_if, aux gt_then, aux gt_else) here | Map ((i, i_bt, it_perm), gt') -> - let _it_min, it_max = GenAnalysis.get_bounds (i, i_bt) it_perm in + let _it_min, it_max = IndexTerms.Bounds.get_bounds (i, i_bt) it_perm in let loc = Locations.other __LOC__ in let it_max_min = IT.le_ - ( IT.num_lit_ (Z.of_int 0) (IT.bt it_max) loc, - IT.add_ (it_max, IT.num_lit_ Z.one (IT.bt it_max) loc) loc ) + ( IT.num_lit_ (Z.of_int 0) (IT.get_bt it_max) loc, + IT.add_ (it_max, IT.num_lit_ Z.one (IT.get_bt it_max) loc) loc ) loc in let it_max_max = IT.lt_ ( it_max, - IT.num_lit_ (Z.of_int (Config.get_max_array_length ())) (IT.bt it_max) loc ) + IT.num_lit_ (Z.of_int (Config.get_max_array_length ())) (IT.get_bt it_max) loc + ) loc in GT.assert_ diff --git a/backend/cn/lib/testGeneration/genInline.ml b/backend/cn/lib/testGeneration/genInline.ml index cf471577d..fd41a0154 100644 --- a/backend/cn/lib/testGeneration/genInline.ml +++ b/backend/cn/lib/testGeneration/genInline.ml @@ -3,8 +3,8 @@ module GT = GenTerms module GD = GenDefinitions let unfold (ctx : GD.context) : GD.context = - let rec loop (fuel : int) (gd : GD.t) : GD.t = - if fuel <= 0 then + let rec loop (fuel : int option) (gd : GD.t) : GD.t = + if Option.equal Int.equal fuel (Some 0) then gd else ( let aux (gt : GT.t) : GT.t = @@ -22,9 +22,23 @@ let unfold (ctx : GD.context) : GD.context = GT.subst (IT.make_subst iargs) (Option.get gd'.body) | _ -> gt in - loop (fuel - 1) { gd with body = Some (GT.map_gen_post aux (Option.get gd.body)) }) + let gt = Option.get gd.body in + let gt' = GT.map_gen_post aux gt in + if GT.equal gt gt' then + { gd with body = Some gt' } + else + loop (Option.map (fun x -> x - 1) fuel) { gd with body = Some gt' }) in - List.map_snd (List.map_snd (loop (TestGenConfig.get_max_unfolds ()))) ctx + let unfolds = TestGenConfig.get_max_unfolds () in + ctx + |> List.map_snd (List.map_snd (loop unfolds)) + |> List.filter_map (fun (x, gds) -> + if Option.is_some unfolds then + Some (x, gds) + else ( + match List.filter (fun ((_, gd) : _ * GD.t) -> gd.spec || gd.recursive) gds with + | [] -> None + | gds' -> Some (x, gds'))) let inline (ctx : GD.context) : GD.context = unfold ctx diff --git a/backend/cn/lib/testGeneration/genNormalize.ml b/backend/cn/lib/testGeneration/genNormalize.ml index 37a9648cf..4389789e9 100644 --- a/backend/cn/lib/testGeneration/genNormalize.ml +++ b/backend/cn/lib/testGeneration/genNormalize.ml @@ -3,7 +3,166 @@ module IT = IndexTerms module LC = LogicalConstraints module GT = GenTerms module GD = GenDefinitions -module SymMap = Map.Make (Sym) + +module MemberIndirection = struct + type kind = + | Struct of Sym.t + | Record + + let rec replace_memberof_it + (k : kind) + (sym : Sym.t) + (dict : (Id.t * Sym.t) list) + (it : IT.t) + : IT.t + = + let repl = replace_memberof_it k sym dict in + let (IT (it_, bt, loc)) = it in + let it_ = + match it_ with + | Const _ | Sym _ | SizeOf _ | OffsetOf _ | Nil _ -> it_ + | Unop (op, it') -> IT.Unop (op, repl it') + | Binop (op, it1, it2) -> IT.Binop (op, repl it1, repl it2) + | ITE (it1, it2, it3) -> IT.ITE (repl it1, repl it2, repl it3) + | EachI ((min, (i_sym, i_bt), max), it') -> + IT.EachI ((min, (i_sym, i_bt), max), repl it') + | Tuple its -> IT.Tuple (List.map repl its) + | NthTuple (n, it') -> IT.NthTuple (n, repl it') + | Struct (tag, xits) -> IT.Struct (tag, List.map_snd repl xits) + | StructMember (it', x) -> + (match (k, IT.is_sym it') with + | Struct _tag, Some (y, _y_bt) when Sym.equal y sym -> + IT.Sym (List.assoc Id.equal x dict) + | _ -> IT.StructMember (repl it', x)) + | StructUpdate ((it_struct, x), it_val) -> + IT.StructUpdate ((repl it_struct, x), repl it_val) + | Record xits -> IT.Record (List.map_snd repl xits) + | RecordMember (it', x) -> + (match (k, IT.is_sym it') with + | Record, Some (y, _y_bt) when Sym.equal y sym -> + IT.Sym (List.assoc Id.equal x dict) + | _ -> IT.RecordMember (repl it', x)) + | RecordUpdate ((it_record, x), it_val) -> + IT.RecordUpdate ((repl it_record, x), repl it_val) + | Constructor (tag, xits) -> IT.Constructor (tag, List.map_snd repl xits) + | MemberShift (it', tag, member) -> IT.MemberShift (it', tag, member) + | ArrayShift { base; ct; index } -> + IT.ArrayShift { base = repl base; ct; index = repl index } + | CopyAllocId { addr; loc } -> IT.CopyAllocId { addr = repl addr; loc = repl loc } + | HasAllocId it' -> IT.HasAllocId (repl it') + | Cons (it1, it2) -> IT.Cons (repl it1, repl it2) + | Head it' -> IT.Head (repl it') + | Tail it' -> IT.Tail (repl it') + | NthList (it1, it2, it3) -> IT.NthList (repl it1, repl it2, repl it3) + | ArrayToList (it1, it2, it3) -> IT.ArrayToList (repl it1, repl it2, repl it3) + | Representable (sct, it') -> IT.Representable (sct, repl it') + | Good (sct, it') -> IT.Good (sct, repl it') + | Aligned { t; align } -> IT.Aligned { t = repl t; align = repl align } + | WrapI (sct, it') -> IT.WrapI (sct, repl it') + | MapConst (bt, it') -> IT.MapConst (bt, repl it') + | MapSet (it1, it2, it3) -> IT.MapSet (repl it1, repl it2, repl it3) + | MapGet (it1, it2) -> IT.MapGet (repl it1, repl it2) + | MapDef ((x, bt), it') -> IT.MapDef ((x, bt), repl it') + | Apply (fsym, its) -> IT.Apply (fsym, List.map repl its) + | Let ((x, it1), it2) -> IT.Let ((x, repl it1), it2) + | Match (it', pits) -> IT.Match (repl it', List.map_snd repl pits) + | Cast (bt, it') -> IT.Cast (bt, repl it') + in + IT (it_, bt, loc) + + + let replace_memberof_gt + (k : kind) + (sym : Sym.t) + (dict : (Id.t * Sym.t) list) + (gt : GT.t) + : GT.t + = + let repl = replace_memberof_it k sym dict in + let aux (gt : GT.t) : GT.t = + let (GT (gt_, bt, loc)) = gt in + let gt_ = + match gt_ with + | Alloc it -> GT.Alloc (repl it) + | Call (fsym, xits) -> GT.Call (fsym, List.map_snd repl xits) + | Asgn ((it_addr, sct), it_val, gt') -> + GT.Asgn ((repl it_addr, sct), repl it_val, gt') + | Return it -> GT.Return (repl it) + | Assert (T it, gt') -> GT.Assert (LC.T (repl it), gt') + | Assert (Forall ((i_sym, i_bt), it), gt') -> + GT.Assert (LC.Forall ((i_sym, i_bt), repl it), gt') + | ITE (it_if, gt_then, gt_else) -> GT.ITE (repl it_if, gt_then, gt_else) + | Map ((i_sym, i_bt, it_perm), gt_inner) -> + GT.Map ((i_sym, i_bt, repl it_perm), gt_inner) + | _ -> gt_ + in + GT (gt_, bt, loc) + in + GT.map_gen_pre aux gt + + + let transform (gt : GT.t) : GT.t = + let aux (gt : GT.t) : GT.t = + match gt with + | GT + ( Let + ( _backtracks, + (x, GT (Return (IT (Struct (_, xits), bt, loc_it)), _, loc_ret)), + gt' ), + _, + loc ) + | GT + ( Let + ( _backtracks, + (x, GT (Return (IT (Record xits, bt, loc_it)), _, loc_ret)), + gt' ), + _, + loc ) -> + let k = + match bt with + | Struct tag -> Struct tag + | Record _ -> Record + | _ -> failwith __LOC__ + in + let members_to_indirect, members_to_leave = + xits |> List.partition (fun (_, it) -> Option.is_none (IT.is_sym it)) + in + let indirect_map = + List.map_snd (fun _ -> Sym.fresh ()) members_to_indirect + @ List.map + (fun (y, it) -> (y, fst (Option.get (IT.is_sym it)))) + members_to_leave + in + let gt_main = + GT.let_ + ( 0, + ( x, + GT.return_ + (let members = + indirect_map + |> List.map (fun (y, z) -> + let it = List.assoc Id.equal y xits in + (y, IT.sym_ (z, IT.get_bt it, IT.get_loc it))) + in + match k with + | Struct tag -> IT.struct_ (tag, members) loc_it + | Record -> IT.record_ members loc_it) + loc_ret ), + replace_memberof_gt k x indirect_map gt' ) + loc + in + let here = Locations.other __LOC__ in + members_to_indirect + |> List.fold_left + (fun gt'' (y, it) -> + GT.let_ + (0, (List.assoc Id.equal y indirect_map, GT.return_ it here), gt'') + here) + gt_main + | _ -> gt + in + GT.map_gen_post aux gt +end let rec arbitrary_of_sctype (sct : Sctypes.t) loc : GT.t = match sct with diff --git a/backend/cn/lib/testGeneration/genNormalize.mli b/backend/cn/lib/testGeneration/genNormalize.mli index a6772a122..6323b3f35 100644 --- a/backend/cn/lib/testGeneration/genNormalize.mli +++ b/backend/cn/lib/testGeneration/genNormalize.mli @@ -1 +1,5 @@ +module MemberIndirection : sig + val transform : GenTerms.t -> GenTerms.t +end + val normalize : unit Mucore.file -> GenDefinitions.context -> GenDefinitions.context diff --git a/backend/cn/lib/testGeneration/genOptimize.ml b/backend/cn/lib/testGeneration/genOptimize.ml index 2c77e8fa4..bbf852d2f 100644 --- a/backend/cn/lib/testGeneration/genOptimize.ml +++ b/backend/cn/lib/testGeneration/genOptimize.ml @@ -6,8 +6,7 @@ module GT = GenTerms module GS = GenStatements module GD = GenDefinitions module GA = GenAnalysis -module SymSet = Set.Make (Sym) -module SymMap = Map.Make (Sym) +module Config = TestGenConfig module StringSet = Set.Make (String) module StringMap = Map.Make (String) @@ -19,7 +18,7 @@ type opt_pass = module FlipIfs = struct (* TODO: Improve performance on runway example *) let transform (gd : GD.t) : GD.t = - let iargs = gd.iargs |> List.map fst |> SymSet.of_list in + let iargs = gd.iargs |> List.map fst |> Sym.Set.of_list in let rec aux (gt : GT.t) : GT.t = let (GT (gt_, _, loc)) = gt in match gt_ with @@ -27,7 +26,7 @@ module FlipIfs = struct | Pick wgts -> GT.pick_ (List.map_snd aux wgts) loc | ITE (it_if, gt_then, gt_else) -> let gt_then, gt_else = (aux gt_then, aux gt_else) in - if not (SymSet.subset (IT.free_vars it_if) iargs) then ( + if not (Sym.Set.subset (IT.free_vars it_if) iargs) then ( let wgts1 = match gt_then with | GT (Pick wgts, _, _) -> @@ -104,7 +103,7 @@ module Fusion = struct let collect_constraints - (vars : SymSet.t) + (vars : Sym.Set.t) (x : Sym.t) ((it_min, it_max) : IT.t * IT.t) (gt : GT.t) @@ -126,14 +125,14 @@ module Fusion = struct ( Forall ((i, i_bt), (IT (Binop (Implies, it_perm, it_body), _, loc_implies) as it)), gt' ) - when SymSet.mem x (IT.free_vars it) && check_index_ok x i it -> - let it_min', it_max' = GA.get_bounds (i, i_bt) it_perm in + when Sym.Set.mem x (IT.free_vars it) && check_index_ok x i it -> + let it_min', it_max' = IndexTerms.Bounds.get_bounds (i, i_bt) it_perm in let gt', res = aux gt' in if IT.equal it_min it_min' && IT.equal it_max it_max' - && SymSet.subset - (SymSet.remove i (IT.free_vars_list [ it_perm; it_body ])) + && Sym.Set.subset + (Sym.Set.remove i (IT.free_vars_list [ it_perm; it_body ])) vars then (gt', (i, IT.arith_binop Implies (it_perm, it_body) loc_implies) :: res) @@ -162,7 +161,7 @@ module Fusion = struct let transform (gd : GD.t) : GD.t = - let rec aux (vars : SymSet.t) (gt : GT.t) : GT.t = + let rec aux (vars : Sym.Set.t) (gt : GT.t) : GT.t = let (GT (gt_, _bt, loc)) = gt in match gt_ with | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> gt @@ -172,58 +171,253 @@ module Fusion = struct | Let (backtracks, (x, GT (Map ((i, i_bt, it_perm), gt_inner), _, loc_map)), gt_rest) -> - let its_bounds = GA.get_bounds (i, i_bt) it_perm in + let its_bounds = IndexTerms.Bounds.get_bounds (i, i_bt) it_perm in let gt_rest, constraints = - collect_constraints (SymSet.add x vars) x its_bounds gt_rest + collect_constraints (Sym.Set.add x vars) x its_bounds gt_rest in - let gt_inner = - let stmts, gt_last = GS.stmts_of_gt (aux (SymSet.add i vars) gt_inner) in - let sym_bt, stmts', gt_last = - match gt_last with - | GT (Return (IT (Sym x, x_bt, _)), _, _) -> ((x, x_bt), [], gt_last) - | GT (Return it, ret_bt, loc_ret) -> - let here = Locations.other __LOC__ in - let y = Sym.fresh () in - ( (y, ret_bt), - [ GS.Let (0, (y, GT.return_ it loc_ret)) ], - GT.return_ (IT.sym_ (y, ret_bt, here)) loc_ret ) - | _ -> failwith (Pp.plain (GT.pp gt_last) ^ " @ " ^ __LOC__) - in - let here = Locations.other __LOC__ in - let stmts'' = - List.map - (fun (j, lc) : GS.t -> - Assert - (LC.T - (replace_index - x - sym_bt - i - (IT.subst (IT.make_subst [ (j, IT.sym_ (i, i_bt, here)) ]) lc)))) - constraints + if List.is_empty constraints then + gt + else ( + let gt_inner = + let stmts, gt_last = GS.stmts_of_gt (aux (Sym.Set.add i vars) gt_inner) in + let sym_bt, stmts', gt_last = + match gt_last with + | GT (Return (IT (Sym x, x_bt, _)), _, _) -> ((x, x_bt), [], gt_last) + | GT (Return it, ret_bt, loc_ret) -> + let here = Locations.other __LOC__ in + let y = Sym.fresh () in + ( (y, ret_bt), + [ GS.Let (0, (y, GT.return_ it loc_ret)) ], + GT.return_ (IT.sym_ (y, ret_bt, here)) loc_ret ) + | gt' -> + let ret_bt = GT.bt gt' in + let here = Locations.other __LOC__ in + let y = Sym.fresh () in + ( (y, ret_bt), + [ GS.Let (0, (y, gt')) ], + GT.return_ (IT.sym_ (y, ret_bt, here)) (GT.loc gt') ) + in + let here = Locations.other __LOC__ in + let stmts'' = + List.map + (fun (j, lc) : GS.t -> + Assert + (LC.T + (replace_index + x + sym_bt + i + (IT.subst (IT.make_subst [ (j, IT.sym_ (i, i_bt, here)) ]) lc)))) + constraints + in + GS.gt_of_stmts (stmts @ stmts' @ stmts'') gt_last in - GS.gt_of_stmts (stmts @ stmts' @ stmts'') gt_last - in - GT.let_ - ( backtracks, - (x, GT.map_ ((i, i_bt, it_perm), gt_inner) loc_map), - aux (SymSet.add x vars) gt_rest ) - loc + GT.let_ + ( backtracks, + (x, GT.map_ ((i, i_bt, it_perm), gt_inner) loc_map), + aux (Sym.Set.add x vars) gt_rest ) + loc) | Let (backtracks, (x, gt_inner), gt_rest) -> GT.let_ - (backtracks, (x, aux vars gt_inner), aux (SymSet.add x vars) gt_rest) + (backtracks, (x, aux vars gt_inner), aux (Sym.Set.add x vars) gt_rest) loc | Assert (lc, gt') -> GT.assert_ (lc, aux vars gt') loc | ITE (it_if, gt_then, gt_else) -> GT.ite_ (it_if, aux vars gt_then, aux vars gt_else) loc | Map ((i, i_bt, it_perm), gt_inner) -> - GT.map_ ((i, i_bt, it_perm), aux (SymSet.add i vars) gt_inner) loc + GT.map_ ((i, i_bt, it_perm), aux (Sym.Set.add i vars) gt_inner) loc in let body = - Some (aux (gd.iargs |> List.map fst |> SymSet.of_list) (Option.get gd.body)) + Some (aux (gd.iargs |> List.map fst |> Sym.Set.of_list) (Option.get gd.body)) in { gd with body } end + + module Recursive = struct + let collect_constraints (vars : Sym.Set.t) (x : Sym.t) (gt : GT.t) : GT.t * LC.t list = + let rec aux (gt : GT.t) : GT.t * LC.t list = + let (GT (gt_, _, loc)) = gt in + match gt_ with + | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ | Pick _ | ITE _ | Map _ -> + (gt, []) + | Asgn ((it_addr, sct), it_val, gt_rest) -> + let gt_rest, lcs = aux gt_rest in + (GT.asgn_ ((it_addr, sct), it_val, gt_rest) loc, lcs) + | Let (backtracks, (x, gt_inner), gt_rest) -> + let gt_inner, lcs = aux gt_inner in + let gt_rest, lcs' = aux gt_rest in + (GT.let_ (backtracks, (x, gt_inner), gt_rest) loc, lcs @ lcs') + | Assert ((T (IT (Binop (EQ, IT (Sym y, _, _), _), _, _)) as lc), gt_rest) + when not (Sym.equal x y) -> + let gt_rest, lcs = aux gt_rest in + (GT.assert_ (lc, gt_rest) loc, lcs) + | Assert ((T (IT (Binop (EQ, _, IT (Sym y, _, _)), _, _)) as lc), gt_rest) + when not (Sym.equal x y) -> + let gt_rest, lcs = aux gt_rest in + (GT.assert_ (lc, gt_rest) loc, lcs) + | Assert (lc, gt_rest) + when let free_vars = LC.free_vars lc in + Sym.Set.mem x free_vars && Sym.Set.subset free_vars vars -> + let gt_rest, lcs = aux gt_rest in + (gt_rest, lc :: lcs) + | Assert (lc, gt_rest) -> + let gt_rest, lcs = aux gt_rest in + (GT.assert_ (lc, gt_rest) loc, lcs) + in + aux gt + + + type inline_request = + { old_name : Sym.t; + old_args : (Sym.t * BT.t) list; + ret_sym : Sym.t; + new_name : Sym.t; + new_args : (Sym.t * BT.t) list; + constraints : LC.t list + } + + let request_gt (vars : Sym.Set.t) (gt : GT.t) : GT.t * inline_request list = + let rec aux (vars : Sym.Set.t) (gt : GT.t) : GT.t * inline_request list = + let (GT (gt_, _, loc)) = gt in + match gt_ with + | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> (gt, []) + | Pick wgts -> + let wgts, reqs = + wgts + |> List.map (fun (w, gt') -> + let gt'', reqs = aux vars gt' in + ((w, gt''), reqs)) + |> List.split + in + (GT.pick_ wgts loc, List.flatten reqs) + | Asgn ((it_addr, sct), it_val, gt_rest) -> + let gt_rest, reqs = aux vars gt_rest in + (GT.asgn_ ((it_addr, sct), it_val, gt_rest) loc, reqs) + | Let (backtracks, (x, GT (Call (fsym, xits), bt_call, loc_call)), gt_rest) -> + let gt_rest, lcs = collect_constraints (Sym.Set.add x vars) x gt_rest in + let gt_rest, reqs = aux (Sym.Set.add x vars) gt_rest in + if List.is_empty lcs then + ( GT.let_ + (backtracks, (x, GT.call_ (fsym, xits) bt_call loc_call), gt_rest) + loc, + reqs ) + else ( + let old_args = List.map_snd IT.get_bt xits in + let ret_sym = Sym.fresh_make_uniq (Sym.pp_string x) in + let xits' = + lcs + |> List.map LC.free_vars_bts + |> List.fold_left + (Sym.Map.union (fun _ bt1 bt2 -> + assert (BT.equal bt1 bt2); + Some bt1)) + Sym.Map.empty + |> Sym.Map.remove x + |> Sym.Map.to_seq + |> List.of_seq + |> List.map (fun (y, y_bt) -> + (Sym.fresh (), IT.sym_ (y, y_bt, Locations.other __LOC__))) + in + let subst = + (x, IT.sym_ (ret_sym, bt_call, Locations.other __LOC__)) + :: (xits' + |> List.map (fun (y, it) -> + ( fst (Option.get (IT.is_sym it)), + IT.sym_ (y, IT.get_bt it, Locations.other __LOC__) ))) + in + let lcs = List.map (LC.subst (IT.make_subst subst)) lcs in + let new_name = Sym.fresh_make_uniq (Sym.pp_string fsym) in + let new_args = xits' |> List.map (fun (y, it) -> (y, IT.get_bt it)) in + ( GT.let_ + ( backtracks, + (x, GT.call_ (new_name, xits @ xits') bt_call loc_call), + gt_rest ) + loc, + { old_name = fsym; + old_args; + ret_sym; + new_name; + new_args; + constraints = lcs + } + :: reqs )) + | Let (backtracks, (x, gt_inner), gt_rest) -> + let gt_inner, reqs = aux vars gt_inner in + let gt_rest, reqs' = aux (Sym.Set.add x vars) gt_rest in + (GT.let_ (backtracks, (x, gt_inner), gt_rest) loc, reqs @ reqs') + | Assert (lc, gt_rest) -> + let gt_rest, reqs = aux vars gt_rest in + (GT.assert_ (lc, gt_rest) loc, reqs) + | ITE (it_if, gt_then, gt_else) -> + let gt_then, reqs = aux vars gt_then in + let gt_else, reqs' = aux vars gt_else in + (GT.ite_ (it_if, gt_then, gt_else) loc, reqs @ reqs') + | Map ((i, i_bt, it_perm), gt_inner) -> + let gt_inner, reqs = aux (Sym.Set.add i vars) gt_inner in + (GT.map_ ((i, i_bt, it_perm), gt_inner) loc, reqs) + in + aux vars gt + + + let request_gd (gd : GD.t) : GD.t * inline_request list = + let gt, reqs = + request_gt (gd.iargs |> List.map fst |> Sym.Set.of_list) (Option.get gd.body) + in + ({ gd with body = Some gt }, reqs) + + + let request (ctx : GD.context) : GD.context * inline_request list = + ctx + |> List.map snd + |> List.flatten + |> List.map snd + |> List.map request_gd + |> List.fold_left + (fun (ctx', reqs') (gd, reqs) -> (GD.add_context gd ctx', reqs @ reqs')) + ([], []) + + + let fuse ((ctx, reqs) : GD.context * inline_request list) : GD.context = + let rec inject (ret_sym : Sym.t) (lcs : LC.t list) (gt : GT.t) : GT.t = + let (GT (gt_, bt, loc)) = gt in + match gt_ with + | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ | Map _ -> + GT.let_ + ( 0, + (ret_sym, gt), + List.fold_left + (fun gt_rest lc -> GT.assert_ (lc, gt_rest) loc) + (GT.return_ (IT.sym_ (ret_sym, bt, loc)) loc) + lcs ) + loc + | Pick wgts -> GT.pick_ (List.map_snd (inject ret_sym lcs) wgts) loc + | Asgn ((it_addr, sct), it_val, gt_rest) -> + GT.asgn_ ((it_addr, sct), it_val, inject ret_sym lcs gt_rest) loc + | Let (backtracks, (x, gt_inner), gt_rest) -> + GT.let_ (backtracks, (x, gt_inner), inject ret_sym lcs gt_rest) loc + | Assert (lc, gt_rest) -> GT.assert_ (lc, inject ret_sym lcs gt_rest) loc + | ITE (it_if, gt_then, gt_else) -> + GT.ite_ (it_if, inject ret_sym lcs gt_then, inject ret_sym lcs gt_else) loc + in + let rec aux (reqs : inline_request list) : GD.context = + match reqs with + | { old_name; old_args; ret_sym; new_name; new_args; constraints } :: reqs' -> + let gd = + ctx + |> List.assoc Sym.equal old_name + |> List.assoc (List.equal Sym.equal) (List.map fst old_args) + in + let body = Some (inject ret_sym constraints (Option.get gd.body)) in + let iargs = List.map_snd GenBaseTypes.of_bt (old_args @ new_args) in + (new_name, [ (List.map fst iargs, { gd with name = new_name; iargs; body }) ]) + :: aux reqs' + | [] -> [] + in + aux reqs @ ctx + + + let transform ctx = fuse (request ctx) + end end module PartialEvaluation = struct @@ -553,33 +747,37 @@ module PartialEvaluation = struct let struct_decls = Pmap.fold (fun tag def decls -> - match def with Mucore.StructDef st -> SymMap.add tag st decls | _ -> decls) + match def with + | Mucore.StructDef st -> Sym.Map.add tag st decls + | _ -> decls) prog5.tagDefs - SymMap.empty + Sym.Map.empty in eval_aux (representable struct_decls ty it' here) | Good (ty, it') -> let struct_decls = Pmap.fold (fun tag def decls -> - match def with Mucore.StructDef st -> SymMap.add tag st decls | _ -> decls) + match def with + | Mucore.StructDef st -> Sym.Map.add tag st decls + | _ -> decls) prog5.tagDefs - SymMap.empty + Sym.Map.empty in eval_aux (good_value struct_decls ty it' here) | Aligned { t; align } -> let addr = addr_ t here in - if not (BT.equal (IT.bt addr) (IT.bt align)) then + if not (BT.equal (IT.get_bt addr) (IT.get_bt align)) then Error "Mismatched types" else eval_aux (divisible_ (addr, align) here) | Apply (fsym, its) -> (match List.assoc_opt Sym.equal fsym prog5.logical_predicates with - | Some { args; definition = Def it_body; _ } - | Some { args; definition = Rec_Def it_body; _ } -> + | Some { args; body = Def it_body; _ } | Some { args; body = Rec_Def it_body; _ } + -> return @@ IT.subst (IT.make_subst (List.combine (List.map fst args) its)) it_body - | Some { definition = Uninterp; _ } -> + | Some { body = Uninterp; _ } -> Error ("Function " ^ Sym.pp_string fsym ^ " is uninterpreted") | None -> Error ("Function " ^ Sym.pp_string fsym ^ " was not found")) | Let ((x, it_v), it_rest) -> @@ -829,9 +1027,9 @@ module PartialEvaluation = struct * substitution, diverging. As such, we force strict evaluation of recursive calls *) (match List.assoc_opt Sym.equal fsym prog5.logical_predicates with - | Some { definition = Def _; _ } -> f it - | Some { definition = Rec_Def _; _ } -> f ~mode:Strict it - | Some { definition = Uninterp; _ } | None -> it) + | Some { body = Def _; _ } -> f it + | Some { body = Rec_Def _; _ } -> f ~mode:Strict it + | Some { body = Uninterp; _ } | None -> it) | _ -> f it in IT.map_term_post aux it @@ -986,7 +1184,8 @@ module BranchPruning = struct let aux (gt : GT.t) : GT.t = match gt with | GT (Pick [ (_, gt') ], _, _) -> gt' - | GT (Pick wgts, _, loc_pick) -> + (* TODO: Understand why this is so bad *) + (* | GT (Pick wgts, _, loc_pick) -> let rec aux'' (wgts : (Z.t * GT.t) list) : (Z.t * GT.t) list = match List.find_index (fun (_, gt') -> GT.is_pick gt') wgts with | Some i -> @@ -1011,7 +1210,7 @@ module BranchPruning = struct | _ -> failwith ("unreachable @ " ^ __LOC__)) | None -> wgts in - GT.pick_ (aux'' wgts) loc_pick + GT.pick_ (aux'' wgts) loc_pick *) | GT (ITE (it_cond, gt_then, gt_else), _, _) -> if IT.is_true it_cond then gt_then @@ -1064,7 +1263,7 @@ module BranchPruning = struct if contains_false_assertion gt_else then GT.assert_ (T it_if, gt_then) loc_ite else if contains_false_assertion gt_then then - GT.assert_ (T (IT.not_ it_if (IT.loc it_if)), gt_else) loc_ite + GT.assert_ (T (IT.not_ it_if (IT.get_loc it_if)), gt_else) loc_ite else gt | _ -> gt @@ -1078,195 +1277,6 @@ module BranchPruning = struct let passes = [ Unused.pass; Inconsistent.pass ] end -module MemberIndirection = struct - type kind = - | Struct - | Record - - let rec replace_memberof_it - (k : kind) - (sym : Sym.t) - (dict : (Id.t * Sym.t) list) - (it : IT.t) - : IT.t - = - let repl = replace_memberof_it k sym dict in - let (IT (it_, bt, loc)) = it in - let it_ = - match it_ with - | Const _ | Sym _ | SizeOf _ | OffsetOf _ | Nil _ -> it_ - | Unop (op, it') -> IT.Unop (op, repl it') - | Binop (op, it1, it2) -> IT.Binop (op, repl it1, repl it2) - | ITE (it1, it2, it3) -> IT.ITE (repl it1, repl it2, repl it3) - | EachI ((min, (i_sym, i_bt), max), it') -> - IT.EachI ((min, (i_sym, i_bt), max), repl it') - | Tuple its -> IT.Tuple (List.map repl its) - | NthTuple (n, it') -> IT.NthTuple (n, repl it') - | Struct (tag, xits) -> IT.Struct (tag, List.map_snd repl xits) - | StructMember (it', x) -> - (match (k, IT.is_sym it') with - | Struct, Some (y, _y_bt) when Sym.equal y sym -> - IT.Sym (List.assoc Id.equal x dict) - | _ -> IT.StructMember (repl it', x)) - | StructUpdate ((it_struct, x), it_val) -> - IT.StructUpdate ((repl it_struct, x), repl it_val) - | Record xits -> IT.Record (List.map_snd repl xits) - | RecordMember (it', x) -> - (match (k, IT.is_sym it') with - | Record, Some (y, _y_bt) when Sym.equal y sym -> - IT.Sym (List.assoc Id.equal x dict) - | _ -> IT.RecordMember (repl it', x)) - | RecordUpdate ((it_record, x), it_val) -> - IT.RecordUpdate ((repl it_record, x), repl it_val) - | Constructor (tag, xits) -> IT.Constructor (tag, List.map_snd repl xits) - | MemberShift (it', tag, member) -> IT.MemberShift (it', tag, member) - | ArrayShift { base; ct; index } -> - IT.ArrayShift { base = repl base; ct; index = repl index } - | CopyAllocId { addr; loc } -> IT.CopyAllocId { addr = repl addr; loc = repl loc } - | HasAllocId it' -> IT.HasAllocId (repl it') - | Cons (it1, it2) -> IT.Cons (repl it1, repl it2) - | Head it' -> IT.Head (repl it') - | Tail it' -> IT.Tail (repl it') - | NthList (it1, it2, it3) -> IT.NthList (repl it1, repl it2, repl it3) - | ArrayToList (it1, it2, it3) -> IT.ArrayToList (repl it1, repl it2, repl it3) - | Representable (sct, it') -> IT.Representable (sct, repl it') - | Good (sct, it') -> IT.Good (sct, repl it') - | Aligned { t; align } -> IT.Aligned { t = repl t; align = repl align } - | WrapI (sct, it') -> IT.WrapI (sct, repl it') - | MapConst (bt, it') -> IT.MapConst (bt, repl it') - | MapSet (it1, it2, it3) -> IT.MapSet (repl it1, repl it2, repl it3) - | MapGet (it1, it2) -> IT.MapGet (repl it1, repl it2) - | MapDef ((x, bt), it') -> IT.MapDef ((x, bt), repl it') - | Apply (fsym, its) -> IT.Apply (fsym, List.map repl its) - | Let ((x, it1), it2) -> IT.Let ((x, repl it1), it2) - | Match (it', pits) -> IT.Match (repl it', List.map_snd repl pits) - | Cast (bt, it') -> IT.Cast (bt, repl it') - in - IT (it_, bt, loc) - - - let replace_memberof_gt - (k : kind) - (sym : Sym.t) - (dict : (Id.t * Sym.t) list) - (gt : GT.t) - : GT.t - = - let repl = replace_memberof_it k sym dict in - let aux (gt : GT.t) : GT.t = - let (GT (gt_, bt, loc)) = gt in - let gt_ = - match gt_ with - | Alloc it -> GT.Alloc (repl it) - | Call (fsym, xits) -> GT.Call (fsym, List.map_snd repl xits) - | Asgn ((it_addr, sct), it_val, gt') -> - GT.Asgn ((repl it_addr, sct), repl it_val, gt') - | Return it -> GT.Return (repl it) - | Assert (T it, gt') -> GT.Assert (LC.T (repl it), gt') - | Assert (Forall ((i_sym, i_bt), it), gt') -> - GT.Assert (LC.Forall ((i_sym, i_bt), repl it), gt') - | ITE (it_if, gt_then, gt_else) -> GT.ITE (repl it_if, gt_then, gt_else) - | Map ((i_sym, i_bt, it_perm), gt_inner) -> - GT.Map ((i_sym, i_bt, repl it_perm), gt_inner) - | _ -> gt_ - in - GT (gt_, bt, loc) - in - GT.map_gen_pre aux gt - - - let transform (gt : GT.t) : GT.t = - let aux (gt : GT.t) : GT.t = - match gt with - | GT - ( Let - ( backtracks, - (x, (GT (Return (IT (Struct (_, xits), bt, _)), _, _) as gt_inner)), - gt' ), - _, - loc ) - | GT - ( Let - ( backtracks, - (x, (GT (Return (IT (Record xits, bt, _)), _, _) as gt_inner)), - gt' ), - _, - loc ) -> - let k = - match bt with Struct _ -> Struct | Record _ -> Record | _ -> failwith __LOC__ - in - let open Either in - let members = - xits - |> List.map_snd (fun it -> - match IT.is_sym it with - | Some (x, _) -> (Left (), x) - | None -> (Right it, Sym.fresh ())) - in - let gt_main = - GT.let_ - ( backtracks, - (x, gt_inner), - replace_memberof_gt k x (List.map_snd snd members) gt' ) - loc - in - let here = Locations.other __LOC__ in - members - |> List.map snd - |> List.filter_map (fun (info, x) -> - match info with Right it -> Some (x, it) | Left () -> None) - |> List.fold_left - (fun gt'' (x, it) -> GT.let_ (0, (x, GT.return_ it here), gt'') here) - gt_main - | _ -> gt - in - GT.map_gen_post aux gt - - - let pass = { name = "member_indirection"; transform } -end - -(** This pass performs makes pointer offsets consistent *) -module PointerOffsets = struct - let transform (gt : GT.t) : GT.t = - let aux (gt : GT.t) : GT.t = - match gt with - | GT (Asgn ((it_addr, sct), it_val, gt'), _, loc) -> - let it_addr = - match it_addr with - | IT - ( Binop (Add, IT (ArrayShift { base; ct; index }, _, loc_shift), it_offset), - _, - loc_add ) -> - let index = - if BT.equal (IT.bt index) Memory.size_bt then - index - else - IT.cast_ Memory.size_bt index (Locations.other __LOC__) - in - IT.add_ - ( base, - IT.add_ - (IT.mul_ (index, IT.sizeOf_ ct loc_shift) loc_shift, it_offset) - loc_add ) - loc_shift - | IT - ( Binop - (Add, IT (Binop (Add, it_base, it_offset_1), _, loc_shift), it_offset_2), - _, - loc_add ) -> - IT.add_ (it_base, IT.add_ (it_offset_1, it_offset_2) loc_add) loc_shift - | _ -> it_addr - in - GT.asgn_ ((it_addr, sct), it_val, gt') loc - | _ -> gt - in - GT.map_gen_post aux gt - - - let pass = { name = "rewrite"; transform } -end - (** This pass performs various inlinings *) module Inline = struct (** This pass inlines generators that just return a constant or symbol *) @@ -1302,16 +1312,16 @@ module Inline = struct GT.map_gen_post aux gt - let of_symset (s : SymSet.t) : bool SymMap.t = - s |> SymSet.to_seq |> Seq.map (fun x -> (x, false)) |> SymMap.of_seq + let of_symset (s : Sym.Set.t) : bool Sym.Map.t = + s |> Sym.Set.to_seq |> Seq.map (fun x -> (x, false)) |> Sym.Map.of_seq - let union = SymMap.union (fun _ a b -> Some (not (a || b))) + let union = Sym.Map.union (fun _ a b -> Some (not (a || b))) - let rec transform_aux (gt : GT.t) : GT.t * bool SymMap.t = + let rec transform_aux (gt : GT.t) : GT.t * bool Sym.Map.t = let (GT (gt_, _, loc)) = gt in match gt_ with - | Arbitrary | Uniform _ -> (gt, SymMap.empty) + | Arbitrary | Uniform _ -> (gt, Sym.Map.empty) | Pick wgts -> let wgts, only_ret = wgts @@ -1319,7 +1329,7 @@ module Inline = struct |> List.map (fun (a, (b, c)) -> ((a, b), c)) |> List.split in - (GT.pick_ wgts loc, List.fold_left union SymMap.empty only_ret) + (GT.pick_ wgts loc, List.fold_left union Sym.Map.empty only_ret) | Alloc it -> (gt, it |> IT.free_vars |> of_symset) | Call (_fsym, xits) -> ( gt, @@ -1327,20 +1337,20 @@ module Inline = struct |> List.map snd |> List.map IT.free_vars |> List.map of_symset - |> List.fold_left union SymMap.empty ) + |> List.fold_left union Sym.Map.empty ) | Asgn ((it_addr, sct), it_val, gt') -> let only_ret = [ it_addr; it_val ] |> List.map IT.free_vars |> List.map of_symset - |> List.fold_left union SymMap.empty + |> List.fold_left union Sym.Map.empty in let gt', only_ret' = transform_aux gt' in (GT.asgn_ ((it_addr, sct), it_val, gt') loc, union only_ret only_ret') | Let (backtracks, (x, gt_inner), gt') -> let gt', only_ret = transform_aux gt' in - let only_ret = SymMap.remove x only_ret in - if Option.equal Bool.equal (SymMap.find_opt x only_ret) (Some true) then + let only_ret = Sym.Map.remove x only_ret in + if Option.equal Bool.equal (Sym.Map.find_opt x only_ret) (Some true) then (subst x gt_inner gt', only_ret) else ( let gt_inner, only_ret' = transform_aux gt_inner in @@ -1348,7 +1358,7 @@ module Inline = struct | Return it -> ( gt, (match IT.is_sym it with - | Some (x, _bt) -> SymMap.singleton x true + | Some (x, _bt) -> Sym.Map.singleton x true | None -> it |> IT.free_vars |> of_symset) ) | Assert (lc, gt') -> let only_ret = lc |> LC.free_vars |> of_symset in @@ -1359,11 +1369,11 @@ module Inline = struct let gt_then, only_ret' = transform_aux gt_then in let gt_else, only_ret'' = transform_aux gt_else in ( GT.ite_ (it_if, gt_then, gt_else) loc, - [ only_ret; only_ret'; only_ret'' ] |> List.fold_left union SymMap.empty ) + [ only_ret; only_ret'; only_ret'' ] |> List.fold_left union Sym.Map.empty ) | Map ((i, i_bt, it_perm), gt_inner) -> - let only_ret = it_perm |> IT.free_vars |> SymSet.remove i |> of_symset in + let only_ret = it_perm |> IT.free_vars |> Sym.Set.remove i |> of_symset in let gt_inner, only_ret' = transform_aux gt_inner in - let only_ret' = only_ret' |> SymMap.remove i |> SymMap.map (fun _ -> false) in + let only_ret' = only_ret' |> Sym.Map.remove i |> Sym.Map.map (fun _ -> false) in (GT.map_ ((i, i_bt, it_perm), gt_inner) loc, union only_ret only_ret') @@ -1445,7 +1455,7 @@ module SplitConstraints = struct it |> cnf |> listify_constraints - |> List.partition (fun it' -> SymSet.mem i_sym (IT.free_vars it')) + |> List.partition (fun it' -> Sym.Set.mem i_sym (IT.free_vars it')) in let gt_forall = GT.assert_ (LC.Forall ((i_sym, i_bt), IT.and_ its_in loc), gt') loc @@ -1472,7 +1482,7 @@ module SplitConstraints = struct | Assert (T (IT (Let ((x, it_inner), it_rest), _, loc_let)), gt') -> GT.let_ ( 0, - (x, GT.return_ it_inner (IT.loc it_inner)), + (x, GT.return_ it_inner (IT.get_loc it_inner)), GT.assert_ (LC.T it_rest, gt') loc ) loc_let | Assert (Forall ((_i_sym, _i_bt), IT (Let _, _, _)), _) -> @@ -1505,6 +1515,19 @@ module SplitConstraints = struct let pass = { name; transform } end + let rec is_external (gt : GT.t) : bool = + let (GT (gt_, _, _)) = gt in + match gt_ with + | Arbitrary | Uniform _ | Alloc _ | Return _ -> false + | Call _ -> true + | Pick wgts -> wgts |> List.map snd |> List.exists is_external + | Asgn (_, _, gt_rest) -> is_external gt_rest + | Let (_, (_, gt_inner), gt_rest) -> is_external gt_inner || is_external gt_rest + | Assert (_, gt_rest) -> is_external gt_rest + | ITE (_, gt_then, gt_else) -> is_external gt_then || is_external gt_else + | Map (_, gt_inner) -> is_external gt_inner + + module Disjunction = struct let name = "split_disjunction" @@ -1556,23 +1579,59 @@ module SplitConstraints = struct let transform (gt : GT.t) : GT.t = - let aux (gt : GT.t) : GT.t = + let rec aux (ext : Sym.Set.t) (gt : GT.t) : GT.t = let (GT (gt_, _bt, loc)) = gt in match gt_ with + | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> gt + | Pick wgts -> GT.pick_ (List.map_snd (aux ext) wgts) loc + | Asgn ((it_addr, sct), it_val, gt_rest) -> + GT.asgn_ ((it_addr, sct), it_val, aux ext gt_rest) loc + | Let (backtracks, (x, gt_inner), gt_rest) -> + let gt_inner = aux ext gt_inner in + let ext = if is_external gt_inner then Sym.Set.add x ext else ext in + GT.let_ (backtracks, (x, gt_inner), aux ext gt_rest) loc | Assert (T it, gt') -> let it = dnf it in + let gt' = aux ext gt' in (match it with | IT (Binop (Or, _, _), _, _) -> - let cases = + let its_split, its_left = it |> listify_constraints - |> List.map (fun it' -> (Z.one, GT.assert_ (T it', gt') loc)) + |> List.partition (fun it' -> + match it with + | IT (Binop (EQ, IT (Sym x, _, _), _), _, _) when not (Sym.Set.mem x ext) + -> + true + | IT (Binop (EQ, _, IT (Sym x, _, _)), _, _) when not (Sym.Set.mem x ext) + -> + true + | _ -> Sym.Set.disjoint ext (IT.free_vars it')) + in + let gt' = + if List.is_empty its_left then + gt' + else ( + let it' = + List.fold_left + (fun it1 it2 -> IT.or2_ (it1, it2) loc) + (List.hd its_left) + (List.tl its_left) + in + GT.assert_ (T it', gt') loc) + in + let cases = + its_split |> List.map (fun it' -> (Z.one, GT.assert_ (T it', gt') loc)) in GT.pick_ cases loc - | _ -> gt) - | _ -> gt + | _ -> GT.assert_ (T it, gt') loc) + | Assert ((Forall _ as lc), gt_rest) -> GT.assert_ (lc, aux ext gt_rest) loc + | ITE (it_if, gt_then, gt_else) -> + GT.ite_ (it_if, aux ext gt_then, aux ext gt_else) loc + | Map ((i, i_bt, it_perm), gt_inner) -> + GT.map_ ((i, i_bt, it_perm), aux ext gt_inner) loc in - GT.map_gen_pre aux gt + aux Sym.Set.empty gt let pass = { name; transform } @@ -1586,11 +1645,7 @@ module SplitConstraints = struct let (GT (gt_, _bt, loc)) = gt in match gt_ with | Assert (T (IT (Binop (Implies, it_if, it_then), _, loc_implies)), gt') -> - GT.pick_ - [ (Z.one, GT.assert_ (T (IT.not_ it_if loc_implies), gt') loc); - (Z.one, GT.assert_ (T it_then, gt') loc) - ] - loc_implies + GT.ite_ (it_if, GT.assert_ (T it_then, gt') loc, gt') loc_implies | _ -> gt in GT.map_gen_pre aux gt @@ -1606,10 +1661,10 @@ end (** This pass infers how much allocation is needed for each pointer given the current intraprocedural context *) -module InferAllocationSize = struct +(* module InferAllocationSize = struct let name = "infer_alloc_size" - let infer_size (vars : SymSet.t) (x : Sym.t) (gt : GT.t) : IT.t option = + let infer_size (vars : Sym.Set.t) (x : Sym.t) (gt : GT.t) : IT.t option = let merge loc oa ob = match (oa, ob) with | Some a, Some b -> Some (IT.max_ (a, b) loc) @@ -1630,7 +1685,7 @@ module InferAllocationSize = struct let (IT (_, _, loc)) = it_addr in let open Option in let@ psym, it_offset = GA.get_addr_offset_opt it_addr in - if Sym.equal x psym && SymSet.subset (IT.free_vars it_offset) vars then + if Sym.equal x psym && Sym.Set.subset (IT.free_vars it_offset) vars then return (IT.add_ (it_offset, IT.sizeOf_ sct loc) loc) else None @@ -1649,7 +1704,7 @@ module InferAllocationSize = struct in let open Option in let@ it = aux gt_inner in - if SymSet.mem j_sym (IT.free_vars it) then ( + if Sym.Set.mem j_sym (IT.free_vars it) then ( let _, it_max = GA.get_bounds (i_sym, i_bt) it_perm in return (IT.subst (IT.make_subst [ (j_sym, it_max) ]) it)) else @@ -1659,7 +1714,7 @@ module InferAllocationSize = struct let transform (gd : GD.t) : GD.t = - let rec aux (vars : SymSet.t) (gt : GT.t) : GT.t = + let rec aux (vars : Sym.Set.t) (gt : GT.t) : GT.t = let (GT (gt_, _bt, loc)) = gt in match gt_ with | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> gt @@ -1668,7 +1723,7 @@ module InferAllocationSize = struct GT.asgn_ ((it_addr, sct), it_val, aux vars gt_rest) loc | Let (backtracks, (x, (GT (Alloc it_size, _bt, loc_alloc) as gt_inner)), gt_rest) -> - let gt_rest = aux (SymSet.add x vars) gt_rest in + let gt_rest = aux (Sym.Set.add x vars) gt_rest in (match infer_size vars x gt_rest with | Some it_size' -> let here = Locations.other __LOC__ in @@ -1679,21 +1734,21 @@ module InferAllocationSize = struct loc | None -> GT.let_ - (backtracks, (x, aux vars gt_inner), aux (SymSet.add x vars) gt_rest) + (backtracks, (x, aux vars gt_inner), aux (Sym.Set.add x vars) gt_rest) loc) | Let (backtracks, (x, gt_inner), gt_rest) -> - GT.let_ (backtracks, (x, aux vars gt_inner), aux (SymSet.add x vars) gt_rest) loc + GT.let_ (backtracks, (x, aux vars gt_inner), aux (Sym.Set.add x vars) gt_rest) loc | Assert (lc, gt_rest) -> GT.assert_ (lc, aux vars gt_rest) loc | ITE (it_if, gt_then, gt_else) -> GT.ite_ (it_if, aux vars gt_then, aux vars gt_else) loc | Map ((i_sym, i_bt, it_perm), gt_inner) -> - GT.map_ ((i_sym, i_bt, it_perm), aux (SymSet.add i_sym vars) gt_inner) loc + GT.map_ ((i_sym, i_bt, it_perm), aux (Sym.Set.add i_sym vars) gt_inner) loc in let body = - Some (aux (gd.iargs |> List.map fst |> SymSet.of_list) (Option.get gd.body)) + Some (aux (gd.iargs |> List.map fst |> Sym.Set.of_list) (Option.get gd.body)) in { gd with body } -end +end *) (** This pass uses [Simplify] to rewrite [IndexTerms.t] *) module TermSimplification = struct @@ -1702,7 +1757,7 @@ module TermSimplification = struct let transform (prog5 : unit Mucore.file) (gt : GT.t) : GT.t = let globals = { Global.empty with - logical_functions = SymMap.of_seq (List.to_seq prog5.logical_predicates) + logical_functions = Sym.Map.of_seq (List.to_seq prog5.logical_predicates) } in let simp_it (it : IT.t) : IT.t = @@ -1896,9 +1951,10 @@ module RemoveUnused = struct let aux (gt : GT.t) : GT.t = let (GT (gt_, _, _)) = gt in match gt_ with - | Let (_, (x, gt1), gt2) - when GA.is_pure gt1 && not (SymSet.mem x (GT.free_vars gt2)) -> - gt2 + | Let (_, (x, gt_inner), gt_rest) + when GA.is_pure gt_inner && not (Sym.Set.mem x (GT.free_vars gt_rest)) -> + gt_rest + | Assert (T it, gt_rest) when IT.is_true it -> gt_rest | _ -> gt in GT.map_gen_post aux gt @@ -1914,43 +1970,74 @@ module Reordering = struct module SymGraph = Graph.Persistent.Digraph.Concrete (Sym) - let get_variable_ordering (iargs : SymSet.t) (stmts : GS.t list) : Sym.t list = + let get_variable_ordering + (_rec_fsyms : Sym.Set.t) + (iargs : Sym.Set.t) + (stmts : GS.t list) + : Sym.t list + = let module Oper = Graph.Oper.P (SymGraph) in - (* Describes logical dependencies where [x <- y] means that [x] depends on [y] *) - let collect_constraints (stmts : GS.t list) : SymGraph.t = - let rec aux (stmts : GS.t list) : SymGraph.t = - match stmts with - | Let (_, (x, _)) :: stmts' -> SymGraph.add_vertex (aux stmts') x - | Assert (T (IT (Binop (EQ, IT (Sym x, _, _), it), _, _))) :: stmts' -> - let g = aux stmts' in - let g' = - List.fold_left - (fun g' y -> - if SymSet.mem y iargs || Sym.equal x y then - g' - else - SymGraph.add_edge_e g' (y, x)) - g - (it |> IT.free_vars |> SymSet.to_seq |> List.of_seq) - in - g' - | Assert (T (IT (Binop (EQ, it, IT (Sym x, _, _)), _, _))) :: stmts' -> - let g = aux stmts' in - Seq.fold_left + (* Insert edges x <- y_1, ..., y_n when x = f(y_1, ..., y_n) *) + let rec consider_equalities (stmts : GS.t list) : SymGraph.t = + match stmts with + | Let (_, (x, _)) :: stmts' -> SymGraph.add_vertex (consider_equalities stmts') x + | Assert (T (IT (Binop (EQ, IT (Sym x, _, _), it), _, _))) :: stmts' -> + let g = consider_equalities stmts' in + let g' = + List.fold_left (fun g' y -> - if SymSet.mem y iargs || Sym.equal x y then + if Sym.Set.mem y iargs || Sym.equal x y then g' else SymGraph.add_edge_e g' (y, x)) g - (it |> IT.free_vars |> SymSet.to_seq) - | _ :: stmts' -> aux stmts' - | [] -> SymGraph.empty - in - let g = aux stmts in + (it |> IT.free_vars |> Sym.Set.to_seq |> List.of_seq) + in + g' + | Assert (T (IT (Binop (EQ, it, IT (Sym x, _, _)), _, _))) :: stmts' -> + let g = consider_equalities stmts' in + Seq.fold_left + (fun g' y -> + if Sym.Set.mem y iargs || Sym.equal x y then + g' + else + SymGraph.add_edge_e g' (y, x)) + g + (it |> IT.free_vars |> Sym.Set.to_seq) + | _ :: stmts' -> consider_equalities stmts' + | [] -> SymGraph.empty + in + (* Put calls before local variables they constrain *) + let rec consider_constrained_calls + (from_calls : Sym.Set.t) + (g : SymGraph.t) + (stmts : GS.t list) + : SymGraph.t + = + match stmts with + | Let (_, (x, gt)) :: stmts' when GT.contains_call gt -> + consider_constrained_calls (Sym.Set.add x from_calls) g stmts' + | Asgn _ :: stmts' | Let _ :: stmts' -> + consider_constrained_calls from_calls g stmts' + | Assert lc :: stmts' -> + let g = consider_constrained_calls from_calls g stmts' in + let free_vars = LC.free_vars lc in + let call_vars = Sym.Set.inter free_vars from_calls in + let non_call_vars = Sym.Set.diff free_vars from_calls in + let add_from_call (x : Sym.t) (g : SymGraph.t) : SymGraph.t = + Sym.Set.fold (fun y g' -> SymGraph.add_edge g' y x) call_vars g + in + Sym.Set.fold add_from_call non_call_vars g + | [] -> g + in + (* Describes logical dependencies where [x <- y] means that [x] depends on [y] *) + let collect_constraints (stmts : GS.t list) : SymGraph.t = + let g = consider_equalities stmts in let g' = Oper.transitive_closure g in - assert (not (SymGraph.fold_edges (fun x y acc -> Sym.equal x y || acc) g' false)); - g + let g'' = consider_constrained_calls Sym.Set.empty g' stmts in + let g''' = Oper.transitive_closure g'' in + assert (not (SymGraph.fold_edges (fun x y acc -> Sym.equal x y || acc) g''' false)); + g''' in (* Describes data dependencies where [x <- y] means that [x] depends on [y] *) let collect_dependencies (stmts : GS.t list) : SymGraph.t = @@ -1958,9 +2045,9 @@ module Reordering = struct match stmts with | Let (_, (x, gt)) :: stmts' -> let g = SymGraph.add_vertex (aux stmts') x in - SymSet.fold + Sym.Set.fold (fun y g' -> - if SymSet.mem y iargs then + if Sym.Set.mem y iargs then g' else SymGraph.add_edge g' y x) @@ -1980,26 +2067,26 @@ module Reordering = struct let get_needs (x : Sym.t) (ys : Sym.t list) : Sym.t list = let syms_c = SymGraph.fold_pred - (fun y syms -> if List.mem Sym.equal y ys then syms else SymSet.add y syms) + (fun y syms -> if List.mem Sym.equal y ys then syms else Sym.Set.add y syms) g_c x - SymSet.empty + Sym.Set.empty in let syms = - SymSet.fold + Sym.Set.fold (fun z acc -> - SymSet.union + Sym.Set.union acc (SymGraph.fold_pred (fun y syms' -> - if List.mem Sym.equal y ys then syms' else SymSet.add y syms') + if List.mem Sym.equal y ys then syms' else Sym.Set.add y syms') g_d z - SymSet.empty)) + Sym.Set.empty)) syms_c syms_c in - orig_order |> List.filter (fun x -> SymSet.mem x syms) + orig_order |> List.filter (fun x -> Sym.Set.mem x syms) in let new_order : Sym.t list -> Sym.t list = List.fold_left @@ -2022,15 +2109,20 @@ module Reordering = struct loop orig_order - let get_statement_ordering (iargs : SymSet.t) (stmts : GS.t list) : GS.t list = - let rec loop (vars : SymSet.t) (syms : Sym.t list) (stmts : GS.t list) : GS.t list = + let get_statement_ordering + (rec_fsyms : Sym.Set.t) + (iargs : Sym.Set.t) + (stmts : GS.t list) + : GS.t list + = + let rec loop (vars : Sym.Set.t) (syms : Sym.t list) (stmts : GS.t list) : GS.t list = let res, stmts' = List.partition (fun (stmt : GS.t) -> match stmt with | Asgn ((it_addr, _sct), it_val) -> - SymSet.subset (IT.free_vars_list [ it_addr; it_val ]) vars - | Assert lc -> SymSet.subset (LC.free_vars lc) vars + Sym.Set.subset (IT.free_vars_list [ it_addr; it_val ]) vars + | Assert lc -> Sym.Set.subset (LC.free_vars lc) vars | _ -> false) stmts in @@ -2042,24 +2134,43 @@ module Reordering = struct match stmt with Let (_, (x, _)) -> Sym.equal x sym | _ -> false) stmts' in - res @ res' @ loop (SymSet.add sym vars) syms' stmts'' + res @ res' @ loop (Sym.Set.add sym vars) syms' stmts'' | [] -> - assert (List.is_empty stmts'); + if List.non_empty stmts' then + print_endline + (match stmts' with + | [ Assert lc ] -> + Pp.( + LC.free_vars lc + |> Sym.Set.to_seq + |> List.of_seq + |> separate_map (comma ^^ space) Sym.pp + |> plain) + | _ -> "ss"); res in - let syms = get_variable_ordering iargs stmts in + let syms = get_variable_ordering rec_fsyms iargs stmts in loop iargs syms stmts - let reorder (iargs : SymSet.t) (gt : GT.t) : GT.t = + let reorder (rec_fsyms : Sym.Set.t) (iargs : Sym.Set.t) (gt : GT.t) : GT.t = let stmts, gt_last = GS.stmts_of_gt gt in - let stmts = get_statement_ordering iargs stmts in + let stmts = get_statement_ordering rec_fsyms iargs stmts in GS.gt_of_stmts stmts gt_last - let transform (gd : GD.t) : GD.t = - let rec aux (iargs : SymSet.t) (gt : GT.t) : GT.t = - let rec loop (iargs : SymSet.t) (gt : GT.t) : GT.t = + let transform (gtx : GD.context) (gd : GD.t) : GD.t = + let rec_fsyms = + gtx + |> List.map snd + |> List.flatten + |> List.map snd + |> List.filter_map (fun (gd' : GD.t) -> + if gd'.recursive then Some gd'.name else None) + |> Sym.Set.of_list + in + let rec aux (iargs : Sym.Set.t) (gt : GT.t) : GT.t = + let rec loop (iargs : Sym.Set.t) (gt : GT.t) : GT.t = let (GT (gt_, _bt, loc)) = gt in match gt_ with | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> gt @@ -2067,17 +2178,17 @@ module Reordering = struct | Asgn ((it_addr, sct), it_val, gt_rest) -> GT.asgn_ ((it_addr, sct), it_val, loop iargs gt_rest) loc | Let (backtracks, (x, gt'), gt_rest) -> - let iargs = SymSet.add x iargs in + let iargs = Sym.Set.add x iargs in GT.let_ (backtracks, (x, (aux iargs) gt'), loop iargs gt_rest) loc | Assert (lc, gt_rest) -> GT.assert_ (lc, loop iargs gt_rest) loc | ITE (it_if, gt_then, gt_else) -> GT.ite_ (it_if, aux iargs gt_then, aux iargs gt_else) loc | Map ((i_sym, i_bt, it_perm), gt_inner) -> - GT.map_ ((i_sym, i_bt, it_perm), aux (SymSet.add i_sym iargs) gt_inner) loc + GT.map_ ((i_sym, i_bt, it_perm), aux (Sym.Set.add i_sym iargs) gt_inner) loc in - gt |> reorder iargs |> loop iargs + gt |> reorder rec_fsyms iargs |> loop iargs in - let iargs = gd.iargs |> List.map fst |> SymSet.of_list in + let iargs = gd.iargs |> List.map fst |> Sym.Set.of_list in { gd with body = Some (aux iargs (Option.get gd.body)) } end @@ -2433,7 +2544,37 @@ module ConstraintPropagation = struct ( EQ, IT (Const (Bits (_, m)), _, _), IT (Binop (Mod, IT (Sym x, x_bt, _), IT (Const (Bits (_, n)), _, _)), _, _) ) - when Z.equal m Z.zero -> + | Binop + ( EQ, + IT + ( Binop + ( Mod, + IT (Cast (_, IT (Sym x, x_bt, _)), _, _), + IT (Const (Bits (_, n)), _, _) ), + _, + _ ), + IT (Const (Bits (_, m)), _, _) ) + | Binop + ( EQ, + IT (Const (Bits (_, m)), _, _), + IT + ( Binop + ( Mod, + IT (Cast (_, IT (Sym x, x_bt, _)), _, _), + IT (Const (Bits (_, n)), _, _) ), + _, + _ ) ) + when Z.equal m Z.zero + && + let sgn, sz = + Option.get + (BT.is_bits_bt + (if BT.equal x_bt (Loc ()) then + Memory.uintptr_bt + else + x_bt)) + in + BT.fits_range (sgn, sz) n -> let@ bt_rep = IntRep.of_bt x_bt in Some (true, (x, Int (IntRep.intersect bt_rep (IntRep.of_mult n)))) | _ -> None @@ -2444,8 +2585,17 @@ module ConstraintPropagation = struct let is_const (Int r) = IntRep.is_const r let to_stmts (x : Sym.t) (bt : BT.t) (Int r : t) : GS.t list = + let loc = Locations.other __LOC__ in + let lit n = + if BT.equal bt (Loc ()) then + IT.pointer_ ~alloc_id:Z.zero ~addr:n loc + else + IT.num_lit_ n bt loc + in + let le (n, m) = + if BT.equal bt (Loc ()) then IT.lePointer_ (n, m) loc else IT.le_ (n, m) loc + in let aux (sgn : BT.sign) (sz : int) : GS.t list = - let loc = Locations.other __LOC__ in let min_bt, max_bt = BT.bits_range (sgn, sz) in if IntRep.is_empty r then [ GS.Assert (T (IT.bool_ false loc)) ] @@ -2453,22 +2603,17 @@ module ConstraintPropagation = struct let min, max = (Option.get (IntRep.minimum r), Option.get (IntRep.maximum r)) in let stmts_range = if Z.equal min max then - [ GS.Assert (T (IT.eq_ (IT.sym_ (x, bt, loc), IT.num_lit_ min bt loc) loc)) - ] + [ GS.Assert (T (IT.eq_ (IT.sym_ (x, bt, loc), lit min) loc)) ] else ( let stmt_min = if Z.lt min_bt min then - [ GS.Assert - (LC.T (IT.le_ (IT.num_lit_ min bt loc, IT.sym_ (x, bt, loc)) loc)) - ] + [ GS.Assert (LC.T (le (lit min, IT.sym_ (x, bt, loc)))) ] else [] in let stmt_max = if Z.lt max max_bt then - [ GS.Assert - (LC.T (IT.le_ (IT.sym_ (x, bt, loc), IT.num_lit_ max bt loc) loc)) - ] + [ GS.Assert (LC.T (le (IT.sym_ (x, bt, loc), lit max))) ] else [] in @@ -2481,8 +2626,17 @@ module ConstraintPropagation = struct [ GS.Assert (LC.T (IT.eq_ - ( IT.mod_ (IT.sym_ (x, bt, loc), IT.num_lit_ r.mult bt loc) loc, - IT.num_lit_ Z.zero bt loc ) + ( IT.mod_ + (if BT.equal bt (Loc ()) then + ( IT.cast_ Memory.uintptr_bt (IT.sym_ (x, bt, loc)) loc, + IT.num_lit_ r.mult Memory.uintptr_bt loc ) + else + (IT.sym_ (x, bt, loc), lit r.mult)) + loc, + IT.num_lit_ + Z.zero + (if BT.equal bt (Loc ()) then Memory.uintptr_bt else bt) + loc ) loc)) ] in @@ -2553,18 +2707,18 @@ module ConstraintPropagation = struct module G = Graph.Persistent.Digraph.ConcreteLabeled (Sym) (Constraint) end - type t = Domain.t SymMap.t * G.t + type t = Domain.t Sym.Map.t * G.t - let empty = (SymMap.empty, G.empty) + let empty = (Sym.Map.empty, G.empty) - let variables ((ds, _) : t) : Domain.t SymMap.t = ds + let variables ((ds, _) : t) : Domain.t Sym.Map.t = ds let constraints ((_, g) : t) : (Sym.t * Constraint.t * Sym.t) list = G.fold_edges_e (fun edge edges -> edge :: edges) g [] let add_variable (x : Sym.t) (d : Domain.t) ((ds, g) : t) : t = - ( SymMap.update + ( Sym.Map.update x (fun od -> match od with Some d' -> Some (Domain.intersect d d') | None -> Some d) @@ -2583,9 +2737,9 @@ module ConstraintPropagation = struct (ds, g) - let domain (x : Sym.t) ((ds, _) : t) : Domain.t = SymMap.find x ds + let domain (x : Sym.t) ((ds, _) : t) : Domain.t = Sym.Map.find x ds - let domain_opt (x : Sym.t) ((ds, _) : t) : Domain.t option = SymMap.find_opt x ds + let domain_opt (x : Sym.t) ((ds, _) : t) : Domain.t option = Sym.Map.find_opt x ds let related_constraints ((_, g) : t) (x : Sym.t) : (Sym.t * Constraint.t * Sym.t) list = @@ -2618,13 +2772,13 @@ module ConstraintPropagation = struct let network = ConstraintNetwork.add_variable x - (Int (Option.get (IntRep.of_bt (SymMap.find x xbts)))) + (Int (Option.get (IntRep.of_bt (Sym.Map.find x xbts)))) network in let network = ConstraintNetwork.add_variable y - (Int (Option.get (IntRep.of_bt (SymMap.find y xbts)))) + (Int (Option.get (IntRep.of_bt (Sym.Map.find y xbts)))) network in (stmt :: stmts', ConstraintNetwork.add_constraint c x y network) @@ -2742,15 +2896,15 @@ module ConstraintPropagation = struct (** Adds new asserts encoding the domain information *) let add_refined_asserts - (iargs : BT.t SymMap.t) + (iargs : BT.t Sym.Map.t) (network : ConstraintNetwork.t) (stmts : GS.t list) : GS.t list = - let rec aux (ds : Domain.t SymMap.t) (stmts : GS.t list) : GS.t list = + let rec aux (ds : Domain.t Sym.Map.t) (stmts : GS.t list) : GS.t list = match stmts with - | (Let (_, (x, gt)) as stmt) :: stmts' when SymMap.mem x ds -> - (stmt :: Domain.to_stmts x (GT.bt gt) (SymMap.find x ds)) @ aux ds stmts' + | (Let (_, (x, gt)) as stmt) :: stmts' when Sym.Map.mem x ds -> + (stmt :: Domain.to_stmts x (GT.bt gt) (Sym.Map.find x ds)) @ aux ds stmts' | (Asgn _ as stmt) :: stmts' | (Let _ as stmt) :: stmts' | (Assert _ as stmt) :: stmts' -> @@ -2758,17 +2912,17 @@ module ConstraintPropagation = struct | [] -> [] in let ds = ConstraintNetwork.variables network in - let ds_iargs, ds_rest = SymMap.partition (fun x _ -> SymMap.mem x iargs) ds in + let ds_iargs, ds_rest = Sym.Map.partition (fun x _ -> Sym.Map.mem x iargs) ds in let stmts_iargs = - SymMap.fold - (fun x d acc -> Domain.to_stmts x (SymMap.find x iargs) d @ acc) + Sym.Map.fold + (fun x d acc -> Domain.to_stmts x (Sym.Map.find x iargs) d @ acc) ds_iargs [] in stmts_iargs @ aux ds_rest stmts - let propagate_constraints (iargs : BT.t SymMap.t) (gt : GT.t) : GT.t = + let propagate_constraints (iargs : BT.t Sym.Map.t) (gt : GT.t) : GT.t = let stmts, gt_last = GS.stmts_of_gt gt in let stmts, network = construct_network stmts in let network = ac3 network in @@ -2777,8 +2931,8 @@ module ConstraintPropagation = struct let transform (gd : GD.t) : GD.t = - let rec aux (iargs : BT.t SymMap.t) (gt : GT.t) : GT.t = - let rec loop (iargs : BT.t SymMap.t) (gt : GT.t) : GT.t = + let rec aux (iargs : BT.t Sym.Map.t) (gt : GT.t) : GT.t = + let rec loop (iargs : BT.t Sym.Map.t) (gt : GT.t) : GT.t = let (GT (gt_, _bt, loc)) = gt in match gt_ with | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> gt @@ -2789,13 +2943,15 @@ module ConstraintPropagation = struct GT.let_ ( backtracks, (x, (aux iargs) gt'), - loop (SymMap.add x (GT.bt gt') iargs) gt_rest ) + loop (Sym.Map.add x (GT.bt gt') iargs) gt_rest ) loc | Assert (lc, gt_rest) -> GT.assert_ (lc, loop iargs gt_rest) loc | ITE (it_if, gt_then, gt_else) -> GT.ite_ (it_if, aux iargs gt_then, aux iargs gt_else) loc | Map ((i_sym, i_bt, it_perm), gt_inner) -> - GT.map_ ((i_sym, i_bt, it_perm), aux (SymMap.add i_sym i_bt iargs) gt_inner) loc + GT.map_ + ((i_sym, i_bt, it_perm), aux (Sym.Map.add i_sym i_bt iargs) gt_inner) + loc in gt |> propagate_constraints iargs |> loop iargs in @@ -2803,24 +2959,24 @@ module ConstraintPropagation = struct gd.iargs |> List.map (fun (x, gbt) -> (x, GenBaseTypes.bt gbt)) |> List.to_seq - |> SymMap.of_seq + |> Sym.Map.of_seq in { gd with body = Some (aux iargs (Option.get gd.body)) } end module Specialization = struct module Equality = struct - let find_constraint (vars : SymSet.t) (x : Sym.t) (stmts : GS.t list) + let find_constraint (vars : Sym.Set.t) (x : Sym.t) (stmts : GS.t list) : (GS.t list * IT.t) option = let rec aux (stmts : GS.t list) : (GS.t list * IT.t) option = let open Option in match stmts with | Assert (T (IT (Binop (EQ, IT (Sym x', _, _), it), _, _))) :: stmts' - when Sym.equal x x' && SymSet.subset (IT.free_vars it) vars -> + when Sym.equal x x' && Sym.Set.subset (IT.free_vars it) vars -> return (stmts', it) | Assert (T (IT (Binop (EQ, it, IT (Sym x', _, _)), _, _))) :: stmts' - when Sym.equal x x' && SymSet.subset (IT.free_vars it) vars -> + when Sym.equal x x' && Sym.Set.subset (IT.free_vars it) vars -> return (stmts', it) | stmt :: stmts' -> let@ stmts', it = aux stmts' in @@ -2830,8 +2986,8 @@ module Specialization = struct aux stmts - let specialize_stmts (vars : SymSet.t) (stmts : GS.t list) : GS.t list = - let rec aux (vars : SymSet.t) (stmts : GS.t list) : GS.t list = + let specialize_stmts (vars : Sym.Set.t) (stmts : GS.t list) : GS.t list = + let rec aux (vars : Sym.Set.t) (stmts : GS.t list) : GS.t list = match stmts with | Let (backtracks, (x, (GT (Arbitrary, _, loc) as gt))) :: stmts' | Let (backtracks, (x, (GT (Uniform _, _, loc) as gt))) :: stmts' @@ -2841,25 +2997,25 @@ module Specialization = struct | Some (stmts', it) -> (stmts', GT.return_ it loc) | None -> (stmts', gt) in - let vars = SymSet.add x vars in + let vars = Sym.Set.add x vars in GS.Let (backtracks, (x, gt)) :: aux vars stmts' - | (Let (_, (x, _)) as stmt) :: stmts' -> stmt :: aux (SymSet.add x vars) stmts' + | (Let (_, (x, _)) as stmt) :: stmts' -> stmt :: aux (Sym.Set.add x vars) stmts' | stmt :: stmts' -> stmt :: aux vars stmts' | [] -> [] in aux vars stmts - let specialize (vars : SymSet.t) (gt : GT.t) : GT.t = + let specialize (vars : Sym.Set.t) (gt : GT.t) : GT.t = let stmts, gt_last = GS.stmts_of_gt gt in let stmts = specialize_stmts vars stmts in GS.gt_of_stmts stmts gt_last let transform (gd : GD.t) : GD.t = - let iargs = gd.iargs |> List.map fst |> SymSet.of_list in - let rec aux (vars : SymSet.t) (gt : GT.t) : GT.t = - let rec loop (vars : SymSet.t) (gt : GT.t) : GT.t = + let iargs = gd.iargs |> List.map fst |> Sym.Set.of_list in + let rec aux (vars : Sym.Set.t) (gt : GT.t) : GT.t = + let rec loop (vars : Sym.Set.t) (gt : GT.t) : GT.t = let (GT (gt_, _bt, loc)) = gt in match gt_ with | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> gt @@ -2868,13 +3024,13 @@ module Specialization = struct GT.asgn_ ((it_addr, sct), it_val, loop vars gt_rest) loc | Let (backtracks, (x, gt'), gt_rest) -> GT.let_ - (backtracks, (x, (aux vars) gt'), loop (SymSet.add x vars) gt_rest) + (backtracks, (x, (aux vars) gt'), loop (Sym.Set.add x vars) gt_rest) loc | Assert (lc, gt_rest) -> GT.assert_ (lc, loop vars gt_rest) loc | ITE (it_if, gt_then, gt_else) -> GT.ite_ (it_if, aux vars gt_then, aux vars gt_else) loc | Map ((i_sym, i_bt, it_perm), gt_inner) -> - GT.map_ ((i_sym, i_bt, it_perm), aux (SymSet.add i_sym vars) gt_inner) loc + GT.map_ ((i_sym, i_bt, it_perm), aux (Sym.Set.add i_sym vars) gt_inner) loc in gt |> specialize vars |> loop vars in @@ -2898,14 +3054,20 @@ module Specialization = struct let of_it (x : Sym.t) (it : IT.t) : t option = let (IT (it_, _, _)) = it in match it_ with - | Binop (LT, IT (Sym x', _, _), it') when Sym.equal x x' -> Some (of_max it') - | Binop (LE, IT (Sym x', x_bt, _), it') when Sym.equal x x' -> + | Binop (LT, IT (Sym x', _, _), it') + when Sym.equal x x' && not (Sym.Set.mem x (IT.free_vars it')) -> + Some (of_max it') + | Binop (LE, IT (Sym x', x_bt, _), it') + when Sym.equal x x' && not (Sym.Set.mem x (IT.free_vars it')) -> let loc = Locations.other __LOC__ in Some (of_max (IT.add_ (it', IT.num_lit_ Z.one x_bt loc) loc)) - | Binop (LT, it', IT (Sym x', x_bt, _)) when Sym.equal x x' -> + | Binop (LT, it', IT (Sym x', x_bt, _)) + when Sym.equal x x' && not (Sym.Set.mem x (IT.free_vars it')) -> let loc = Locations.other __LOC__ in Some (of_min (IT.sub_ (it', IT.num_lit_ Z.one x_bt loc) loc)) - | Binop (LE, it', IT (Sym x', _, _)) when Sym.equal x x' -> Some (of_min it') + | Binop (LE, it', IT (Sym x', _, _)) + when Sym.equal x x' && not (Sym.Set.mem x (IT.free_vars it')) -> + Some (of_min it') | _ -> None @@ -2945,12 +3107,12 @@ module Specialization = struct { mult; min; max } end - let collect_constraints (vars : SymSet.t) (x : Sym.t) (bt : BT.t) (stmts : GS.t list) + let collect_constraints (vars : Sym.Set.t) (x : Sym.t) (bt : BT.t) (stmts : GS.t list) : GS.t list * Rep.t = let rec aux (stmts : GS.t list) : GS.t list * Rep.t = match stmts with - | (Assert (T it) as stmt) :: stmts' when SymSet.subset (IT.free_vars it) vars -> + | (Assert (T it) as stmt) :: stmts' when Sym.Set.subset (IT.free_vars it) vars -> let stmts', r = aux stmts' in (match Rep.of_it x it with | Some r' -> (stmts', Rep.intersect r r') @@ -2960,7 +3122,7 @@ module Specialization = struct (stmt :: stmts', v) | [] -> (match bt with - | Bits _ -> ([], { mult = None; min = None; max = None }) + | Bits _ | Loc _ -> ([], { mult = None; min = None; max = None }) | _ -> failwith __LOC__) in aux stmts @@ -3021,13 +3183,15 @@ module Specialization = struct | _ -> (gt, mult_to_stmt v.mult @ min_to_stmt v.min @ max_to_stmt v.max) - let specialize_stmts (vars : SymSet.t) (stmts : GS.t list) : GS.t list = - let rec aux (vars : SymSet.t) (stmts : GS.t list) : GS.t list = + let specialize_stmts (vars : Sym.Set.t) (stmts : GS.t list) : GS.t list = + let rec aux (vars : Sym.Set.t) (stmts : GS.t list) : GS.t list = match stmts with | Let (backtracks, (x, gt)) :: stmts' -> - let vars = SymSet.add x vars in + let vars = Sym.Set.add x vars in let stmts', (gt, stmts'') = - if Option.is_some (BT.is_bits_bt (GT.bt gt)) then ( + if + BT.equal (GT.bt gt) (BT.Loc ()) || Option.is_some (BT.is_bits_bt (GT.bt gt)) + then ( let stmts', v = collect_constraints vars x (GT.bt gt) stmts' in (stmts', compile_constraints x v gt)) else @@ -3040,15 +3204,15 @@ module Specialization = struct aux vars stmts - let specialize (vars : SymSet.t) (gt : GT.t) : GT.t = + let specialize (vars : Sym.Set.t) (gt : GT.t) : GT.t = let stmts, gt_last = GS.stmts_of_gt gt in let stmts = specialize_stmts vars stmts in GS.gt_of_stmts stmts gt_last let transform (gd : GD.t) : GD.t = - let rec aux (vars : SymSet.t) (gt : GT.t) : GT.t = - let rec loop (vars : SymSet.t) (gt : GT.t) : GT.t = + let rec aux (vars : Sym.Set.t) (gt : GT.t) : GT.t = + let rec loop (vars : Sym.Set.t) (gt : GT.t) : GT.t = let (GT (gt_, _bt, loc)) = gt in match gt_ with | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> gt @@ -3057,39 +3221,130 @@ module Specialization = struct GT.asgn_ ((it_addr, sct), it_val, loop vars gt_rest) loc | Let (backtracks, (x, gt'), gt_rest) -> GT.let_ - (backtracks, (x, (aux vars) gt'), loop (SymSet.add x vars) gt_rest) + (backtracks, (x, (aux vars) gt'), loop (Sym.Set.add x vars) gt_rest) loc | Assert (lc, gt_rest) -> GT.assert_ (lc, loop vars gt_rest) loc | ITE (it_if, gt_then, gt_else) -> GT.ite_ (it_if, aux vars gt_then, aux vars gt_else) loc | Map ((i_sym, i_bt, it_perm), gt_inner) -> - GT.map_ ((i_sym, i_bt, it_perm), aux (SymSet.add i_sym vars) gt_inner) loc + GT.map_ ((i_sym, i_bt, it_perm), aux (Sym.Set.add i_sym vars) gt_inner) loc in gt |> specialize vars |> loop vars in - let iargs = gd.iargs |> List.map fst |> SymSet.of_list in + let iargs = gd.iargs |> List.map fst |> Sym.Set.of_list in { gd with body = Some (aux iargs (Option.get gd.body)) } end + + module Pointer = struct + let is_not_null (x : Sym.t) (gt : GT.t) : bool * GT.t = + let rec aux (gt : GT.t) : bool * GT.t = + let (GT (gt_, _, loc)) = gt in + match gt_ with + | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> (false, gt) + | Pick wgts -> + let bools, wgts' = + wgts + |> List.map_snd aux + |> List.map (fun (w, (b, gt)) -> (b, (w, gt))) + |> List.split + in + (List.fold_left ( && ) true bools, GT.pick_ wgts' loc) + | Asgn ((it_addr, sct), it_val, gt_rest) -> + let b, gt_rest' = aux gt_rest in + (b, GT.asgn_ ((it_addr, sct), it_val, gt_rest') loc) + | Let (backtracks, (x, gt_inner), gt_rest) -> + let b, gt_inner' = aux gt_inner in + let b', gt_rest' = aux gt_rest in + (b || b', GT.let_ (backtracks, (x, gt_inner'), gt_rest') loc) + | Assert + ( T + (IT + ( Unop + (Not, IT (Binop (EQ, IT (Sym y, _, _), IT (Const Null, _, _)), _, _)), + _, + _ )), + gt_rest ) + | Assert + ( T + (IT + ( Unop + (Not, IT (Binop (EQ, IT (Const Null, _, _), IT (Sym y, _, _)), _, _)), + _, + _ )), + gt_rest ) + when Sym.equal x y -> + (true, snd (aux gt_rest)) + | Assert (lc, gt_rest) -> + let b, gt_rest' = aux gt_rest in + (b, GT.assert_ (lc, gt_rest') loc) + | ITE (it_if, gt_then, gt_else) -> + let b, gt_then' = aux gt_then in + let b', gt_else' = aux gt_else in + (b || b', GT.ite_ (it_if, gt_then', gt_else') loc) + | Map ((i, i_bt, it_perm), gt_inner) -> + let b, gt_inner' = aux gt_inner in + (b, GT.map_ ((i, i_bt, it_perm), gt_inner') loc) + in + aux gt + + + let transform_gt (gt : GT.t) : GT.t = + let aux (gt : GT.t) : GT.t = + let (GT (gt_, _, loc)) = gt in + match gt_ with + | Let + ( backtracks, + (x, GT (Alloc (IT (Const (Bits (_, n)), _, _)), _, loc_size)), + gt_rest ) + when Z.equal n Z.zero -> + let not_null, gt_rest' = is_not_null x gt_rest in + if not_null then + GT.let_ + ( backtracks, + (x, GT.alloc_ (IT.num_lit_ (Z.of_int 8) Memory.size_bt loc_size) loc), + gt_rest' ) + loc + else + gt + | _ -> gt + in + GT.map_gen_pre aux gt + + + let transform (gd : GD.t) : GD.t = + { gd with body = Some (transform_gt (Option.get gd.body)) } + end end +let debug msg = Cerb_debug.print_debug 2 [] (fun _ -> msg) + let all_passes (prog5 : unit Mucore.file) = - (PartialEvaluation.pass prog5 - :: PushPull.pass - :: MemberIndirection.pass - :: Inline.passes) + [ PartialEvaluation.pass prog5 ] + @ (if Config.has_pass "flatten" then [ PushPull.pass ] else []) + @ Inline.passes @ RemoveUnused.passes - @ [ TermSimplification.pass prog5; TermSimplification'.pass; PointerOffsets.pass ] + @ [ TermSimplification.pass prog5; TermSimplification'.pass ] @ BranchPruning.passes - @ SplitConstraints.passes + @ if Config.has_pass "lift_constraints" then SplitConstraints.passes else [] let optimize_gen (prog5 : unit Mucore.file) (passes : StringSet.t) (gt : GT.t) : GT.t = let passes = all_passes prog5 |> List.filter_map (fun { name; transform } -> - if StringSet.mem name passes then Some transform else None) + if StringSet.mem name passes then + Some + (fun gt -> + debug name; + transform gt) + else + None) + in + let opt (gt : GT.t) : GT.t = + gt + |> List.fold_right (fun pass gt -> pass gt) passes + |> GenNormalize.MemberIndirection.transform in - let opt (gt : GT.t) : GT.t = List.fold_left (fun gt pass -> pass gt) gt passes in let rec loop (fuel : int) (gt : GT.t) : GT.t = if fuel <= 0 then gt @@ -3114,15 +3369,35 @@ let optimize_gen_def (prog5 : unit Mucore.file) (passes : StringSet.t) (gd : GD. in gd |> aux - |> Fusion.Each.transform + |> (debug "fusion_each"; + Fusion.Each.transform) |> aux - |> FlipIfs.transform + |> (if Config.has_pass "picks" then ( + debug "flip_ifs"; + FlipIfs.transform) + else + fun gd' -> gd') |> aux - |> Reordering.transform - |> ConstraintPropagation.transform - |> Specialization.Equality.transform - |> Specialization.Integer.transform - |> InferAllocationSize.transform + |> (if Config.has_pass "reorder" then ( + debug "reorder"; + Reordering.transform []) + else + fun gd' -> gd') + |> (if Config.has_pass "consistency" then + fun gd' -> + gd' + |> (debug "constraint_propagation"; + ConstraintPropagation.transform) + |> (debug "specialization_equality"; + Specialization.Equality.transform) + |> (debug "specialization_integer"; + Specialization.Integer.transform) + |> + (debug "specialization_pointer"; + Specialization.Pointer.transform) + else + fun gd' -> gd') + (* |> InferAllocationSize.transform *) |> aux @@ -3134,4 +3409,17 @@ let optimize = let default = all_passes prog5 |> List.map (fun p -> p.name) |> StringSet.of_list in let passes = Option.value ~default passes in - List.map_snd (List.map_snd (optimize_gen_def prog5 passes)) ctx + ctx + (* |> List.map_snd + (List.map_snd + (fun ({ filename; recursive; spec; name; iargs; oargs; body } : GD.t) : GD.t -> + { filename; + recursive; + name; + spec; + iargs; + oargs; + body = Option.map (optimize_gen prog5 passes) body + })) + |> Fusion.Recursive.transform *) + |> List.map_snd (List.map_snd (optimize_gen_def prog5 passes)) diff --git a/backend/cn/lib/testGeneration/genRuntime.ml b/backend/cn/lib/testGeneration/genRuntime.ml index 84b07226c..aeb40efa3 100644 --- a/backend/cn/lib/testGeneration/genRuntime.ml +++ b/backend/cn/lib/testGeneration/genRuntime.ml @@ -7,7 +7,7 @@ module GT = GenTerms module GD = GenDefinitions module GBT = GenBaseTypes module GA = GenAnalysis -module SymSet = Set.Make (Sym) +module SymGraph = Graph.Persistent.Digraph.Concrete (Sym) module StringMap = Map.Make (String) let bennet = Sym.fresh_named "bennet" @@ -23,15 +23,20 @@ type term = choices : (int * term) list; last_var : Sym.t } - | Alloc of { bytes : IT.t } + | Alloc of + { bytes : IT.t; + sized : bool + } | Call of { fsym : Sym.t; iargs : (Sym.t * Sym.t) list; - oarg_bt : BT.t + oarg_bt : BT.t; + path_vars : Sym.Set.t; + sized : (int * Sym.t) option } | Asgn of { pointer : Sym.t; - offset : IT.t; + addr : IT.t; sct : Sctypes.t; value : IT.t; last_var : Sym.t; @@ -66,41 +71,45 @@ type term = inner : term; last_var : Sym.t } + | SplitSize of + { marker_var : Sym.t; + syms : Sym.Set.t; + path_vars : Sym.Set.t; + last_var : Sym.t; + rest : term + } [@@deriving eq, ord] let is_return (tm : term) : bool = match tm with Return _ -> true | _ -> false -let rec free_vars_term (tm : term) : SymSet.t = +let rec free_vars_term (tm : term) : Sym.Set.t = match tm with - | Uniform _ -> SymSet.empty + | Uniform _ -> Sym.Set.empty | Pick { bt = _; choice_var = _; choices; last_var = _ } -> free_vars_term_list (List.map snd choices) - | Alloc { bytes } -> IT.free_vars bytes - | Call { fsym = _; iargs; oarg_bt = _ } -> SymSet.of_list (List.map snd iargs) - | Asgn { pointer; offset; sct = _; value; last_var = _; rest } -> - List.fold_left - SymSet.union - SymSet.empty - [ SymSet.singleton pointer; - IT.free_vars_list [ offset; value ]; - free_vars_term rest - ] + | Alloc { bytes; sized = _ } -> IT.free_vars bytes + | Call { fsym = _; iargs; oarg_bt = _; path_vars = _; sized = _ } -> + Sym.Set.of_list (List.map snd iargs) + | Asgn { pointer = _; addr; sct = _; value; last_var = _; rest } -> + Sym.Set.union (IT.free_vars_list [ addr; value ]) (free_vars_term rest) | Let { backtracks = _; x; x_bt = _; value; last_var = _; rest } -> - SymSet.union (free_vars_term value) (SymSet.remove x (free_vars_term rest)) + Sym.Set.union (free_vars_term value) (Sym.Set.remove x (free_vars_term rest)) | Return { value } -> IT.free_vars value | Assert { prop; last_var = _; rest } -> - SymSet.union (LC.free_vars prop) (free_vars_term rest) + Sym.Set.union (LC.free_vars prop) (free_vars_term rest) | ITE { bt = _; cond; t; f } -> - SymSet.union (IT.free_vars cond) (free_vars_term_list [ t; f ]) + Sym.Set.union (IT.free_vars cond) (free_vars_term_list [ t; f ]) | Map { i; bt = _; min; max; perm; inner; last_var = _ } -> - SymSet.remove + Sym.Set.remove i - (SymSet.union (IT.free_vars_list [ min; max; perm ]) (free_vars_term inner)) + (Sym.Set.union (IT.free_vars_list [ min; max; perm ]) (free_vars_term inner)) + | SplitSize { marker_var = _; syms = _; path_vars = _; last_var = _; rest } -> + free_vars_term rest -and free_vars_term_list : term list -> SymSet.t = +and free_vars_term_list : term list -> Sym.Set.t = fun xs -> - List.fold_left (fun ss t -> SymSet.union ss (free_vars_term t)) SymSet.empty xs + List.fold_left (fun ss t -> Sym.Set.union ss (free_vars_term t)) Sym.Set.empty xs let rec pp_term (tm : term) : Pp.document = @@ -131,10 +140,14 @@ let rec pp_term (tm : term) : Pp.document = parens (int w ^^ comma ^^ braces (nest 2 (break 1 ^^ pp_term gt)))) choices))) - | Alloc { bytes } -> string "alloc" ^^ parens (IT.pp bytes) - | Call { fsym; iargs; oarg_bt } -> + | Alloc { bytes; sized } -> + (if sized then string "alloc_sized" else string "alloc") ^^ parens (IT.pp bytes) + | Call { fsym; iargs; oarg_bt; path_vars; sized } -> parens (Sym.pp fsym + ^^ optional + (fun (n, sym) -> brackets (int n ^^ comma ^^ space ^^ Sym.pp sym)) + sized ^^ parens (nest 2 @@ -143,33 +156,32 @@ let rec pp_term (tm : term) : Pp.document = (fun (x, y) -> Sym.pp x ^^ colon ^^ space ^^ Sym.pp y) iargs)) ^^ space - ^^ BT.pp oarg_bt) - | Asgn - { pointer : Sym.t; - offset : IT.t; - sct : Sctypes.t; - value : IT.t; - last_var : Sym.t; - rest : term - } -> + ^^ colon + ^^ space + ^^ BT.pp oarg_bt + ^^ c_comment + (string "path affected by" + ^^ space + ^^ separate_map + (comma ^^ space) + Sym.pp + (path_vars |> Sym.Set.to_seq |> List.of_seq))) + | Asgn { pointer; addr; sct; value; last_var; rest } -> Sctypes.pp sct ^^ space - ^^ Sym.pp pointer - ^^ space - ^^ plus - ^^ space - ^^ IT.pp offset + ^^ IT.pp addr ^^ space ^^ string ":=" ^^ space ^^ IT.pp value ^^ semi ^^ space - ^^ twice slash - ^^ space - ^^ string "backtracks to" - ^^ space - ^^ Sym.pp last_var + ^^ c_comment + (string "backtracks to" + ^^ space + ^^ Sym.pp last_var + ^^ string " allocs via " + ^^ Sym.pp pointer) ^^ break 1 ^^ pp_term rest | Let @@ -239,9 +251,30 @@ let rec pp_term (tm : term) : Pp.document = (IT.pp min ^^ string " <= " ^^ Sym.pp i ^^ string " <= " ^^ IT.pp max) ^^ c_comment (string "backtracks to" ^^ space ^^ Sym.pp last_var)) ^^ braces (c_comment (BT.pp bt) ^^ nest 2 (break 1 ^^ pp_term inner) ^^ break 1) + | SplitSize { marker_var; syms; path_vars; last_var; rest } -> + string "split_size" + ^^ brackets (Sym.pp marker_var) + ^^ parens + (separate_map (comma ^^ space) Sym.pp (syms |> Sym.Set.to_seq |> List.of_seq)) + ^^ space + ^^ c_comment + (string "backtracks to" + ^^ space + ^^ Sym.pp last_var + ^^ comma + ^^ space + ^^ string "path affected by" + ^^ space + ^^ separate_map + (comma ^^ space) + Sym.pp + (path_vars |> Sym.Set.to_seq |> List.of_seq)) + ^^ semi + ^^ break 1 + ^^ pp_term rest -let nice_names (inputs : SymSet.t) (gt : GT.t) : GT.t = +let nice_names (inputs : Sym.Set.t) (gt : GT.t) : GT.t = let basename (sym : Sym.t) : string = let open Sym in match description sym with @@ -256,12 +289,12 @@ let nice_names (inputs : SymSet.t) (gt : GT.t) : GT.t = | Arbitrary | Uniform _ | Alloc _ | Call _ | Return _ -> (vars, gt) | Pick wgts -> let vars, wgts = - List.fold_left - (fun (vars', choices') (w, gr') -> + List.fold_right + (fun (w, gr') (vars', choices') -> let vars'', gr'' = aux vars' gr' in (vars'', (w, gr'') :: choices')) - (vars, []) wgts + (vars, []) in (vars, GT.pick_ wgts loc) | Asgn ((it_addr, sct), it_val, gt') -> @@ -307,12 +340,12 @@ let nice_names (inputs : SymSet.t) (gt : GT.t) : GT.t = in snd (aux - (inputs |> SymSet.to_seq |> Seq.map (fun x -> (basename x, 1)) |> StringMap.of_seq) + (inputs |> Sym.Set.to_seq |> Seq.map (fun x -> (basename x, 1)) |> StringMap.of_seq) gt) -let elaborate_gt (inputs : SymSet.t) (gt : GT.t) : term = - let rec aux (vars : Sym.t list) (gt : GT.t) : term = +let elaborate_gt (inputs : Sym.Set.t) (gt : GT.t) : term = + let rec aux (vars : Sym.t list) (path_vars : Sym.Set.t) (gt : GT.t) : term = let last_var = match vars with v :: _ -> v | [] -> bennet in let (GT (gt_, bt, loc)) = gt in match gt_ with @@ -347,10 +380,13 @@ let elaborate_gt (inputs : SymSet.t) (gt : GT.t) : term = Z.to_int (Z.max Z.one (Z.div w (Z.div (Z.add w_sum (Z.pred max_int)) max_int))) in - List.map (fun (w, gt) -> (f w, aux (choice_var :: vars) gt)) wgts); + List.map + (fun (w, gt) -> + (f w, aux (choice_var :: vars) (Sym.Set.add choice_var path_vars) gt)) + wgts); last_var } - | Alloc bytes -> Alloc { bytes } + | Alloc bytes -> Alloc { bytes; sized = false } | Call (fsym, xits) -> let (iargs : (Sym.t * Sym.t) list), (gt_lets : Sym.t -> term -> term) = List.fold_right @@ -373,47 +409,65 @@ let elaborate_gt (inputs : SymSet.t) (gt : GT.t) : term = xits ([], fun _ gr -> gr) in - gt_lets last_var (Call { fsym; iargs; oarg_bt = bt }) - | Asgn ((it_addr, sct), value, rest) -> - let pointer, offset = GA.get_addr_offset it_addr in - if not (SymSet.mem pointer inputs || List.exists (Sym.equal pointer) vars) then - failwith - (Sym.pp_string pointer - ^ " not in [" - ^ String.concat "; " (List.map Sym.pp_string vars) - ^ "] from " - ^ Pp.plain (Locations.pp (IT.loc it_addr))); - Asgn { pointer; offset; sct; value; last_var; rest = aux vars rest } + gt_lets last_var (Call { fsym; iargs; oarg_bt = bt; path_vars; sized = None }) + | Asgn ((addr, sct), value, rest) -> + let pointer = + let pointers = + let free_vars = IT.free_vars_bts addr in + if Sym.Map.cardinal free_vars == 1 then + free_vars + else + free_vars |> Sym.Map.filter (fun _ bt -> BT.equal bt (BT.Loc ())) + in + if not (Sym.Map.cardinal pointers == 1) then + Cerb_debug.print_debug 2 [] (fun () -> + Pp.( + plain + (braces + (separate_map + (comma ^^ space) + Sym.pp + (List.map fst (Sym.Map.bindings pointers))) + ^^ space + ^^ string " in " + ^^ IT.pp addr))); + List.find + (fun x -> Sym.Map.mem x pointers) + (vars @ List.of_seq (Sym.Set.to_seq inputs)) + in + Asgn { pointer; addr; sct; value; last_var; rest = aux vars path_vars rest } | Let (backtracks, (x, gt1), gt2) -> Let { backtracks; x; x_bt = GT.bt gt1; - value = aux vars gt1; + value = aux vars path_vars gt1; last_var; - rest = aux (x :: vars) gt2 + rest = aux (x :: vars) path_vars gt2 } | Return value -> Return { value } - | Assert (prop, rest) -> Assert { prop; last_var; rest = aux vars rest } + | Assert (prop, rest) -> Assert { prop; last_var; rest = aux vars path_vars rest } | ITE (cond, gt_then, gt_else) -> - ITE { bt; cond; t = aux vars gt_then; f = aux vars gt_else } + let path_vars = Sym.Set.union path_vars (IT.free_vars cond) in + ITE { bt; cond; t = aux vars path_vars gt_then; f = aux vars path_vars gt_else } | Map ((i, i_bt, perm), inner) -> - let min, max = GenAnalysis.get_bounds (i, i_bt) perm in + let min, max = IndexTerms.Bounds.get_bounds (i, i_bt) perm in Map { i; bt = Map (i_bt, GT.bt inner); min; max; perm; - inner = aux (i :: vars) inner; + inner = aux (i :: vars) path_vars inner; last_var } in - aux [] (nice_names inputs gt) + aux [] Sym.Set.empty (nice_names inputs gt) type definition = { filename : string; + sized : bool; name : Sym.t; iargs : (Sym.t * BT.t) list; oargs : (Sym.t * BT.t) list; @@ -445,14 +499,18 @@ let pp_definition (def : definition) : Pp.document = ^^ rbrace) -let elaborate_gd ({ filename; recursive = _; spec = _; name; iargs; oargs; body } : GD.t) +let elaborate_gd ({ filename; recursive; spec = _; name; iargs; oargs; body } : GD.t) : definition = { filename; + sized = recursive; name; iargs = List.map_snd GBT.bt iargs; oargs = List.map_snd GBT.bt oargs; - body = elaborate_gt (SymSet.of_list (List.map fst iargs)) (Option.get body) + body = + Option.get body + |> GenNormalize.MemberIndirection.transform + |> elaborate_gt (Sym.Set.of_list (List.map fst iargs)) } @@ -472,4 +530,138 @@ let pp (ctx : context) : Pp.document = defns -let elaborate (gtx : GD.context) : context = List.map_snd (List.map_snd elaborate_gd) gtx +module Sizing = struct + let count_recursive_calls (syms : Sym.Set.t) (gr : term) : int = + let rec aux (gr : term) : int = + match gr with + | Uniform _ | Alloc _ | Return _ -> 0 + | Pick { choices; _ } -> + choices |> List.map snd |> List.map aux |> List.fold_left max 0 + | Call { fsym; _ } -> if Sym.Set.mem fsym syms then 1 else 0 + | Asgn { rest; _ } -> aux rest + | Let { value; rest; _ } -> aux value + aux rest + | Assert { rest; _ } -> aux rest + | ITE { t; f; _ } -> max (aux t) (aux f) + | Map { inner; _ } -> aux inner + | SplitSize _ -> failwith ("unreachable @ " ^ __LOC__) + in + aux gr + + + let size_recursive_calls + (marker_var : Sym.t) + (syms : Sym.Set.t) + (size : int) + (gr : term) + : term * Sym.Set.t + = + let rec aux (gr : term) : term * Sym.Set.t = + match gr with + | Call ({ fsym; path_vars; _ } as gr) when Sym.Set.mem fsym syms -> + let sym = Sym.fresh () in + let gr' = + if size > 1 && TestGenConfig.is_random_size_splits () then + Call + { gr with + sized = Some (size, sym); + path_vars = Sym.Set.add marker_var path_vars + } + else + Call { gr with sized = Some (size, sym) } + in + (gr', Sym.Set.singleton sym) + | Uniform _ | Call _ | Return _ -> (gr, Sym.Set.empty) + | Alloc { bytes; sized = _ } -> (Alloc { bytes; sized = true }, Sym.Set.empty) + | Pick ({ choices; _ } as gr) -> + let choices, syms = + choices + |> List.map (fun (w, gr) -> + let gr, syms = aux gr in + ((w, gr), syms)) + |> List.split + in + (Pick { gr with choices }, List.fold_left Sym.Set.union Sym.Set.empty syms) + | Asgn ({ rest; _ } as gr) -> + let rest, syms = aux rest in + (Asgn { gr with rest }, syms) + | Let ({ value; rest; _ } as gr) -> + let value, syms = aux value in + let rest, syms' = aux rest in + (Let { gr with value; rest }, Sym.Set.union syms syms') + | Assert ({ rest; _ } as gr) -> + let rest, syms = aux rest in + (Assert { gr with rest }, syms) + | ITE ({ t; f; _ } as gr) -> + let t, syms = aux t in + let f, syms' = aux f in + (ITE { gr with t; f }, Sym.Set.union syms syms') + | Map ({ inner; _ } as gr) -> + let inner, syms = aux inner in + (Map { gr with inner }, syms) + | SplitSize _ -> failwith ("unreachable @ " ^ __LOC__) + in + aux gr + + + let transform_gr (syms : Sym.Set.t) (gr : term) : term = + let rec aux (path_vars : Sym.Set.t) (gr : term) : term = + match gr with + | ITE { bt; cond; t; f } -> + let path_vars = Sym.Set.union path_vars (IT.free_vars cond) in + ITE { bt; cond; t = aux path_vars t; f = aux path_vars f } + | Pick { bt; choice_var; choices; last_var } -> + Pick + { bt; + choice_var; + choices = List.map_snd (aux (Sym.Set.add choice_var path_vars)) choices; + last_var + } + | _ -> + let count = count_recursive_calls syms gr in + let marker_var = Sym.fresh () in + let gr, syms = size_recursive_calls marker_var syms count gr in + if count > 1 then + SplitSize + { marker_var; + syms; + last_var = Sym.fresh_named "bennet"; + path_vars; + rest = gr + } + else + gr + in + aux Sym.Set.empty gr + + + let transform_def + (cg : SymGraph.t) + ({ filename : string; + sized : bool; + name : Sym.Set.elt; + iargs : (Sym.Set.elt * BT.t) list; + oargs : (Sym.Set.elt * BT.t) list; + body : term + } : + definition) + : definition + = + { filename; + sized; + name; + iargs; + oargs; + body = transform_gr (SymGraph.fold_pred Sym.Set.add cg name Sym.Set.empty) body + } + + + let transform (cg : SymGraph.t) (ctx : context) : context = + List.map_snd + (List.map_snd (fun ({ sized; _ } as def) -> + if sized then transform_def cg def else def)) + ctx +end + +let elaborate (gtx : GD.context) : context = + let cg = GA.get_call_graph gtx in + gtx |> List.map_snd (List.map_snd elaborate_gd) |> Sizing.transform cg diff --git a/backend/cn/lib/testGeneration/genRuntime.mli b/backend/cn/lib/testGeneration/genRuntime.mli index 5276abd22..9e1c5ce24 100644 --- a/backend/cn/lib/testGeneration/genRuntime.mli +++ b/backend/cn/lib/testGeneration/genRuntime.mli @@ -5,8 +5,6 @@ module IT = IndexTerms module LC = LogicalConstraints module GD = GenDefinitions -module SymSet : Set.S with type elt = Sym.t - type term = | Uniform of { bt : BT.t; @@ -18,15 +16,20 @@ type term = choices : (int * term) list; last_var : Sym.t } - | Alloc of { bytes : IT.t } + | Alloc of + { bytes : IT.t; + sized : bool + } | Call of { fsym : Sym.t; iargs : (Sym.t * Sym.t) list; - oarg_bt : BT.t + oarg_bt : BT.t; + path_vars : Sym.Set.t; + sized : (int * Sym.t) option } | Asgn of { pointer : Sym.t; - offset : IT.t; + addr : IT.t; sct : Sctypes.t; value : IT.t; last_var : Sym.t; @@ -61,16 +64,24 @@ type term = inner : term; last_var : Sym.t } + | SplitSize of + { marker_var : Sym.t; + syms : Sym.Set.t; + path_vars : Sym.Set.t; + last_var : Sym.t; + rest : term + } [@@deriving eq, ord] -val free_vars_term : term -> SymSet.t +val free_vars_term : term -> Sym.Set.t -val free_vars_term_list : term list -> SymSet.t +val free_vars_term_list : term list -> Sym.Set.t val pp_term : term -> Pp.document type definition = { filename : string; + sized : bool; name : Sym.t; iargs : (Sym.t * BT.t) list; oargs : (Sym.t * BT.t) list; diff --git a/backend/cn/lib/testGeneration/genTerms.ml b/backend/cn/lib/testGeneration/genTerms.ml index 263f9eb8c..8e24db588 100644 --- a/backend/cn/lib/testGeneration/genTerms.ml +++ b/backend/cn/lib/testGeneration/genTerms.ml @@ -3,8 +3,6 @@ module IT = IndexTerms module LC = LogicalConstraints module CF = Cerb_frontend module GBT = GenBaseTypes -module SymMap = Map.Make (Sym) -module SymSet = Set.Make (Sym) type t_ = | Arbitrary (** Generate arbitrary values *) @@ -54,7 +52,7 @@ let let_ ((retries, (x, gt1), gt2) : int * (Sym.t * t) * t) (loc : Locations.t) GT (Let (retries, (x, gt1), gt2), basetype gt2, loc) -let return_ (it : IT.t) (loc : Locations.t) : t = GT (Return it, IT.bt it, loc) +let return_ (it : IT.t) (loc : Locations.t) : t = GT (Return it, IT.get_bt it, loc) let assert_ ((lc, gt') : LC.t * t) (loc : Locations.t) : t = GT (Assert (lc, gt'), basetype gt', loc) @@ -263,31 +261,31 @@ and alpha_rename_gen x gt = and suitably_alpha_rename_gen syms x gt = - if SymSet.mem x syms then + if Sym.Set.mem x syms then alpha_rename_gen x gt else (x, gt) -let rec free_vars_bts_ (gt_ : t_) : BT.t SymMap.t = +let rec free_vars_bts_ (gt_ : t_) : BT.t Sym.Map.t = let loc = Locations.other __LOC__ in match gt_ with - | Arbitrary | Uniform _ -> SymMap.empty + | Arbitrary | Uniform _ -> Sym.Map.empty | Pick wgts -> free_vars_bts_list (List.map snd wgts) | Alloc it -> IT.free_vars_bts it | Call (_, xits) -> IT.free_vars_bts_list (List.map snd xits) | Asgn ((it_addr, _), it_val, gt') -> free_vars_bts_list [ return_ it_addr loc; return_ it_val loc; gt' ] | Let (_, (x, gt1), gt2) -> - SymMap.union + Sym.Map.union (fun _ bt1 bt2 -> assert (BT.equal bt1 bt2); Some bt1) (free_vars_bts gt1) - (SymMap.remove x (free_vars_bts gt2)) + (Sym.Map.remove x (free_vars_bts gt2)) | Return it -> IT.free_vars_bts it | Assert (lc, gt') -> - (SymMap.union (fun _ bt1 bt2 -> + (Sym.Map.union (fun _ bt1 bt2 -> assert (BT.equal bt1 bt2); Some bt1)) (free_vars_bts gt') @@ -295,27 +293,27 @@ let rec free_vars_bts_ (gt_ : t_) : BT.t SymMap.t = | ITE (it_if, gt_then, gt_else) -> free_vars_bts_list [ return_ it_if loc; gt_then; gt_else ] | Map ((i, _bt, it_perm), gt') -> - SymMap.remove i (free_vars_bts_list [ return_ it_perm loc; gt' ]) + Sym.Map.remove i (free_vars_bts_list [ return_ it_perm loc; gt' ]) -and free_vars_bts (GT (gt_, _, _) : t) : BT.t SymMap.t = free_vars_bts_ gt_ +and free_vars_bts (GT (gt_, _, _) : t) : BT.t Sym.Map.t = free_vars_bts_ gt_ -and free_vars_bts_list : t list -> BT.t SymMap.t = +and free_vars_bts_list : t list -> BT.t Sym.Map.t = fun xs -> List.fold_left (fun ss t -> - SymMap.union + Sym.Map.union (fun _ bt1 bt2 -> assert (BT.equal bt1 bt2); Some bt1) ss (free_vars_bts t)) - SymMap.empty + Sym.Map.empty xs -let free_vars (gt : t) : SymSet.t = - gt |> free_vars_bts |> SymMap.bindings |> List.map fst |> SymSet.of_list +let free_vars (gt : t) : Sym.Set.t = + gt |> free_vars_bts |> Sym.Map.bindings |> List.map fst |> Sym.Set.of_list let rec map_gen_pre (f : t -> t) (g : t) : t = @@ -359,10 +357,14 @@ let rec map_gen_post (f : t -> t) (g : t) : t = f (GT (gt_, bt, here)) -type definition = - { filename : string; - name : Sym.t; - iargs : (Sym.t * GBT.t) list; - oargs : GBT.t list; - body : t option - } +let rec contains_call (gt : t) : bool = + let (GT (gt_, _, _)) = gt in + match gt_ with + | Arbitrary | Uniform _ | Alloc _ | Return _ -> false + | Pick wgts -> wgts |> List.map snd |> List.exists contains_call + | Call _ -> true + | Asgn (_, _, gt_rest) -> contains_call gt_rest + | Let (_, (_, gt_inner), gt_rest) -> contains_call gt_inner || contains_call gt_rest + | Assert (_, gt_rest) -> contains_call gt_rest + | ITE (_, gt_then, gt_else) -> contains_call gt_then || contains_call gt_else + | Map (_, gt_inner) -> contains_call gt_inner diff --git a/backend/cn/lib/testGeneration/specTests.ml b/backend/cn/lib/testGeneration/specTests.ml index 4cf2f9f1d..963445f79 100644 --- a/backend/cn/lib/testGeneration/specTests.ml +++ b/backend/cn/lib/testGeneration/specTests.ml @@ -1,18 +1,24 @@ module CF = Cerb_frontend module A = CF.AilSyntax module C = CF.Ctype -module BT = BaseTypes module AT = ArgumentTypes module LAT = LogicalArgumentTypes module CtA = Cn_internal_to_ail module Utils = Executable_spec_utils -module ESpecInternal = Executable_spec_internal module Config = TestGenConfig -module SymSet = Set.Make (Sym) let debug_log_file : out_channel option ref = ref None +let init_debug () = + if Option.is_none !debug_log_file && !Cerb_debug.debug_level > 0 then + debug_log_file + := Some + (let open Stdlib in + open_out "generatorCompilation.log") + + let debug_log (str : string) : unit = + init_debug (); match !debug_log_file with | Some oc -> output_string oc str; @@ -25,41 +31,55 @@ let debug_stage (stage : string) (str : string) : unit = debug_log (str ^ "\n\n") -let pp_label ?(width : int = 30) (label : string) : Pp.document = - let padding = max 2 ((width - (String.length label + 2)) / 2) in - let open Pp in - repeat width slash - ^^ hardline - ^^ repeat padding slash - ^^ space - ^^ string label - ^^ space - ^^ repeat padding slash - ^^ hardline - ^^ repeat width slash - - -let compile_unit_tests (insts : Core_to_mucore.instrumentation list) = +let compile_constant_tests + (sigma : CF.GenTypes.genTypeCategory A.sigma) + (insts : Executable_spec_extract.instrumentation list) + : Test.t list * Pp.document + = + let test_names, docs = + List.map_split + (fun (inst : Executable_spec_extract.instrumentation) -> + ( Test. + { kind = Constant; + suite = + inst.fn_loc + |> Cerb_location.get_filename + |> Option.get + |> Filename.basename + |> String.split_on_char '.' + |> List.hd; + test = Sym.pp_string inst.fn + }, + let open Pp in + (if not (Config.with_static_hack ()) then + CF.Pp_ail.pp_function_prototype + ~executable_spec:true + inst.fn + (let _, _, decl = List.assoc Sym.equal inst.fn sigma.declarations in + decl) + ^^ hardline + else + empty) + ^^ CF.Pp_ail.pp_statement + A.( + Utils.mk_stmt + (AilSexpr + (Utils.mk_expr + (AilEcall + ( Utils.mk_expr + (AilEident (Sym.fresh_named "CN_UNIT_TEST_CASE")), + [ Utils.mk_expr (AilEident inst.fn) ] ))))) )) + insts + in let open Pp in - separate_map - (semi ^^ twice hardline) - (fun (inst : Core_to_mucore.instrumentation) -> - CF.Pp_ail.pp_statement - A.( - Utils.mk_stmt - (AilSexpr - (Utils.mk_expr - (AilEcall - ( Utils.mk_expr (AilEident (Sym.fresh_named "CN_UNIT_TEST_CASE")), - [ Utils.mk_expr (AilEident inst.fn) ] )))))) - insts + (test_names, separate (twice hardline) docs ^^ twice hardline) let compile_generators (sigma : CF.GenTypes.genTypeCategory A.sigma) (prog5 : unit Mucore.file) - (insts : Core_to_mucore.instrumentation list) - : PPrint.document + (insts : Executable_spec_extract.instrumentation list) + : Pp.document = let ctx = GenCompile.compile prog5.resource_predicates insts in debug_stage "Compile" (ctx |> GenDefinitions.pp_context |> Pp.plain ~width:80); @@ -77,10 +97,11 @@ let compile_generators let compile_random_test_case + (sigma : CF.GenTypes.genTypeCategory A.sigma) (prog5 : unit Mucore.file) (args_map : (Sym.t * (Sym.t * C.ctype) list) list) (convert_from : Sym.t * C.ctype -> Pp.document) - (inst : Core_to_mucore.instrumentation) + ((test, inst) : Test.t * Executable_spec_extract.instrumentation) : Pp.document = let open Pp in @@ -91,8 +112,8 @@ let compile_random_test_case inst.internal |> Option.get |> AT.get_lat - |> LAT.free_vars (fun _ -> SymSet.empty) - |> SymSet.to_seq + |> LAT.free_vars (fun _ -> Sym.Set.empty) + |> Sym.Set.to_seq |> List.of_seq |> List.filter (fun x -> not @@ -105,79 +126,94 @@ let compile_random_test_case | GlobalDef (sct, _) -> (sym, sct)) global_syms in - (if List.is_empty globals then - string "CN_RANDOM_TEST_CASE" - else ( - let init_name = string "cn_test_" ^^ Sym.pp inst.fn ^^ string "_init" in - string "void" - ^^ space - ^^ init_name - ^^ parens - (string "struct" - ^^ space - ^^ string (String.concat "_" [ "cn_gen"; Sym.pp_string inst.fn; "record" ]) - ^^ star - ^^ space - ^^ string "res") - ^^ space - ^^ braces - (nest - 2 - (hardline - ^^ separate_map - hardline - (fun (sym, sct) -> - let ty = - CF.Pp_ail.pp_ctype - ~executable_spec:true - ~is_human:false - C.no_qualifiers - (Sctypes.to_ctype sct) - in - Sym.pp sym - ^^ space - ^^ equals - ^^ space - ^^ star - ^^ parens (ty ^^ star) - ^^ string "convert_from_cn_pointer" - ^^ parens (string "res->cn_gen_" ^^ Sym.pp sym) - ^^ semi - ^^ hardline - ^^ string "cn_assume_ownership" - ^^ parens - (separate - (comma ^^ space) - [ ampersand ^^ Sym.pp sym; - string "sizeof" ^^ parens ty; - string "(char*)" ^^ dquotes init_name - ]) - ^^ semi) - globals) - ^^ hardline) - ^^ twice hardline - ^^ string "CN_RANDOM_TEST_CASE_WITH_INIT")) + (if not (Config.with_static_hack ()) then + CF.Pp_ail.pp_function_prototype + ~executable_spec:true + inst.fn + (let _, _, decl = List.assoc Sym.equal inst.fn sigma.declarations in + decl) + ^^ hardline + else + empty) + ^^ (if List.is_empty globals then + string "CN_RANDOM_TEST_CASE" + else ( + let init_name = string "cn_test_gen_" ^^ Sym.pp inst.fn ^^ string "_init" in + string "void" + ^^ space + ^^ init_name + ^^ parens + (string "struct" + ^^ space + ^^ string (String.concat "_" [ "cn_gen"; Sym.pp_string inst.fn; "record" ]) + ^^ star + ^^ space + ^^ string "res") + ^^ space + ^^ braces + (nest + 2 + (hardline + ^^ separate_map + hardline + (fun (sym, sct) -> + let ty = + CF.Pp_ail.pp_ctype + ~executable_spec:true + ~is_human:false + C.no_qualifiers + (Sctypes.to_ctype sct) + in + Sym.pp sym + ^^ space + ^^ equals + ^^ space + ^^ star + ^^ parens (ty ^^ star) + ^^ string "convert_from_cn_pointer" + ^^ parens + (string "res->" ^^ Sym.pp (GenUtils.get_mangled_name [ sym ])) + ^^ semi + ^^ hardline + ^^ string "cn_assume_ownership" + ^^ parens + (separate + (comma ^^ space) + [ ampersand ^^ Sym.pp sym; + string "sizeof" ^^ parens ty; + string "(char*)" ^^ dquotes init_name + ]) + ^^ semi) + globals) + ^^ hardline) + ^^ twice hardline + ^^ string "CN_RANDOM_TEST_CASE_WITH_INIT")) ^^ parens (separate (comma ^^ space) - [ Sym.pp inst.fn; int 100; separate_map (comma ^^ space) convert_from args ]) + [ string test.suite; + string test.test; + int (Config.get_num_samples ()); + separate_map (comma ^^ space) convert_from args + ]) + ^^ semi ^^ twice hardline -let compile_random_tests +let compile_generator_tests (sigma : CF.GenTypes.genTypeCategory A.sigma) (prog5 : unit Mucore.file) - (insts : Core_to_mucore.instrumentation list) - : Pp.document + (insts : Executable_spec_extract.instrumentation list) + : Test.t list * Pp.document = let declarations : A.sigma_declaration list = insts - |> List.map (fun (inst : Core_to_mucore.instrumentation) -> + |> List.map (fun (inst : Executable_spec_extract.instrumentation) -> (inst.fn, List.assoc Sym.equal inst.fn sigma.declarations)) in let args_map : (Sym.t * (Sym.t * C.ctype) list) list = List.map - (fun (inst : Core_to_mucore.instrumentation) -> + (fun (inst : Executable_spec_extract.instrumentation) -> ( inst.fn, let _, _, _, xs, _ = List.assoc Sym.equal inst.fn sigma.function_definitions in match List.assoc Sym.equal inst.fn declarations with @@ -201,302 +237,29 @@ let compile_random_tests A.( AilEmemberofptr ( Utils.mk_expr (AilEident (Sym.fresh_named "res")), - Sym.Identifier (Locations.other __LOC__, "cn_gen_" ^ Sym.pp_string x) )) + Sym.Identifier + ( Locations.other __LOC__, + Sym.pp_string (GenUtils.get_mangled_name [ x ]) ) )) (Memory.bt_of_sct (Sctypes.of_ctype_unsafe (Locations.other __LOC__) ct)))) in - let open Pp in - concat_map (compile_random_test_case prog5 args_map convert_from) insts - - -let compile_assumes - ~(with_ownership_checking : bool) - (sigma : CF.GenTypes.genTypeCategory A.sigma) - (prog5 : unit Mucore.file) - (insts : Core_to_mucore.instrumentation list) - : Pp.document - = - let declarations, function_definitions = - List.split - (List.map - (fun ctype -> - Cn_internal_to_ail.generate_assume_ownership_function - ~with_ownership_checking - ctype) - (let module CtypeSet = - Set.Make (struct - type t = C.ctype - - let compare a b = compare (Hashtbl.hash a) (Hashtbl.hash b) - end) - in - !CtA.ownership_ctypes |> CtypeSet.of_list |> CtypeSet.to_seq |> List.of_seq) - @ Cn_internal_to_ail.cn_to_ail_assume_predicates_internal - prog5.resource_predicates - sigma.cn_datatypes - [] - prog5.resource_predicates - @ ESpecInternal.generate_c_assume_pres_internal insts sigma prog5) - in - let open Pp in - separate_map - (twice hardline) - (fun (tag, (_, _, decl)) -> - CF.Pp_ail.pp_function_prototype ~executable_spec:true tag decl) - declarations - ^^ twice hardline - ^^ CF.Pp_ail.pp_program - ~executable_spec:true - ~show_include:true - (None, { A.empty_sigma with declarations; function_definitions }) - - -let compile_tests - ~(with_ownership_checking : bool) - (filename_base : string) - (sigma : CF.GenTypes.genTypeCategory A.sigma) - (prog5 : unit Mucore.file) - (insts : Core_to_mucore.instrumentation list) - = - let unit_tests, random_tests = - List.partition - (fun (inst : Core_to_mucore.instrumentation) -> - let _, _, decl = List.assoc Sym.equal inst.fn sigma.declarations in - match decl with - | Decl_function (_, _, args, _, _, _) -> - List.is_empty args - && SymSet.is_empty - (LAT.free_vars - (fun _ -> SymSet.empty) - (AT.get_lat (Option.get inst.internal))) - | Decl_object _ -> failwith __LOC__) + let tests = + List.map + (fun (inst : Executable_spec_extract.instrumentation) -> + Test. + { kind = Generator; + suite = + inst.fn_loc + |> Cerb_location.get_filename + |> Option.get + |> Filename.basename + |> String.split_on_char '.' + |> List.hd; + test = Sym.pp_string inst.fn + }) insts in - let unit_tests_doc = compile_unit_tests unit_tests in - let random_tests_doc = compile_random_tests sigma prog5 random_tests in let open Pp in - string "#include " - ^^ dquotes (string (filename_base ^ "_gen.h")) - ^^ hardline - ^^ string "#include " - ^^ dquotes (string (filename_base ^ "-exec.c")) - ^^ hardline - ^^ string "#include " - ^^ dquotes (string "cn.c") - ^^ twice hardline - ^^ pp_label "Assume Ownership Functions" - ^^ twice hardline - ^^ compile_assumes ~with_ownership_checking sigma prog5 insts - ^^ pp_label "Unit tests" - ^^ twice hardline - ^^ unit_tests_doc - ^^ twice hardline - ^^ pp_label "Random tests" - ^^ twice hardline - ^^ random_tests_doc - ^^ pp_label "Main function" - ^^ twice hardline - ^^ string "int main" - ^^ parens (string "int argc, char* argv[]") - ^^ break 1 - ^^ braces - (nest - 2 - (hardline - ^^ concat_map - (fun decl -> - let fn, (loc, _, _) = decl in - let suite = - loc - |> Cerb_location.get_filename - |> Option.get - |> Filename.basename - |> String.split_on_char '.' - |> List.hd - in - string "cn_register_test_case" - ^^ parens - (separate - (comma ^^ space) - [ string "(char*)" ^^ dquotes (string suite); - string "(char*)" ^^ dquotes (Sym.pp fn); - string "&cn_test" ^^ underscore ^^ Sym.pp fn - ]) - ^^ semi - ^^ hardline) - (List.map - (fun (inst : Core_to_mucore.instrumentation) -> - (inst.fn, List.assoc Sym.equal inst.fn sigma.declarations)) - insts) - ^^ string "return cn_test_main(argc, argv);") - ^^ hardline) - ^^ hardline - - -let compile_script ~(output_dir : string) ~(test_file : string) : Pp.document = - let open Pp in - string "#!/bin/bash" - ^^ twice hardline - ^^ string "# copied from cn-runtime-single-file.sh" - ^^ hardline - ^^ string "RUNTIME_PREFIX=\"$OPAM_SWITCH_PREFIX/lib/cn/runtime\"" - ^^ hardline - ^^ string "[ -d \"${RUNTIME_PREFIX}\" ]" - ^^ space - ^^ twice bar - ^^ space - ^^ parens - (nest - 4 - (hardline - ^^ string - "printf \"Could not find CN's runtime directory (looked at: \ - '${RUNTIME_PREFIX}')\"" - ^^ hardline - ^^ string "exit 1") - ^^ hardline) - ^^ twice hardline - ^^ string "TEST_DIR=" - ^^ string output_dir - ^^ hardline - ^^ twice hardline - ^^ string "# Compile" - ^^ hardline - ^^ separate_map - space - string - [ "if"; - "cc"; - "-g"; - "-c"; - "\"-I${RUNTIME_PREFIX}/include/\""; - "-o"; - "\"${TEST_DIR}/" ^ Filename.chop_extension test_file ^ ".o\""; - "\"${TEST_DIR}/" ^ test_file ^ "\";"; - "then" - ] - ^^ nest 4 (hardline ^^ string "echo \"Compiled C files.\"") - ^^ hardline - ^^ string "else" - ^^ nest - 4 - (hardline - ^^ string "printf \"Failed to compile C files in ${TEST_DIR}.\"" - ^^ hardline - ^^ string "exit 1") - ^^ hardline - ^^ string "fi" - ^^ twice hardline - ^^ string "# Link" - ^^ hardline - ^^ separate_map - space - string - [ "if"; - "cc"; - "-g"; - "\"-I${RUNTIME_PREFIX}/include\""; - "-o \"${TEST_DIR}/tests.out\""; - "${TEST_DIR}/" ^ Filename.chop_extension test_file ^ ".o"; - "\"${RUNTIME_PREFIX}/libcn.a\";"; - "then" - ] - ^^ nest 4 (hardline ^^ string "echo \"Linked C .o files.\"") - ^^ hardline - ^^ string "else" - ^^ nest - 4 - (hardline - ^^ string "printf \"Failed to link *.o files in ${TEST_DIR}.\"" - ^^ hardline - ^^ string "exit 1") - ^^ hardline - ^^ string "fi" - ^^ twice hardline - ^^ string "# Run" - ^^ hardline - ^^ - let cmd = - separate_map - space - string - ([ "${TEST_DIR}/tests.out" ] - @ (Config.has_null_in_every () - |> Option.map (fun null_in_every -> - [ "--null-in-every"; string_of_int null_in_every ]) - |> Option.to_list - |> List.flatten) - @ (Config.has_seed () - |> Option.map (fun seed -> [ "--seed"; seed ]) - |> Option.to_list - |> List.flatten) - @ (Config.has_logging_level () - |> Option.map (fun level -> [ "--logging-level"; string_of_int level ]) - |> Option.to_list - |> List.flatten) - @ - if Config.is_interactive () then - [ "--interactive" ] - else - []) - in - string "if" - ^^ space - ^^ cmd - ^^ semi - ^^ space - ^^ string "then" - ^^ nest 4 (hardline ^^ string "exit 0") - ^^ hardline - ^^ string "else" - ^^ nest 4 (hardline ^^ string "exit 1") - ^^ hardline - ^^ string "fi" - ^^ hardline - - -let save ?(perm = 0o666) (output_dir : string) (filename : string) (doc : Pp.document) - : unit - = - let oc = - Stdlib.open_out_gen - [ Open_wronly; Open_creat; Open_trunc; Open_text ] - perm - (Filename.concat output_dir filename) - in - output_string oc (Pp.plain ~width:80 doc); - close_out oc - - -let generate - ~(output_dir : string) - ~(filename : string) - ~(with_ownership_checking : bool) - (sigma : CF.GenTypes.genTypeCategory A.sigma) - (prog5 : unit Mucore.file) - : unit - = - if !Cerb_debug.debug_level > 0 then - debug_log_file - := Some - (let open Stdlib in - open_out "generatorCompilation.log"); - let insts = - prog5 - |> Core_to_mucore.collect_instrumentation - |> fst - |> List.filter (fun (inst : Core_to_mucore.instrumentation) -> - Option.is_some inst.internal) - in - if List.is_empty insts then failwith "No testable functions"; - let filename_base = filename |> Filename.basename |> Filename.chop_extension in - let generators_doc = compile_generators sigma prog5 insts in - let generators_fn = filename_base ^ "_gen.h" in - save output_dir generators_fn generators_doc; - let tests_doc = - compile_tests ~with_ownership_checking filename_base sigma prog5 insts - in - let test_file = filename_base ^ "_test.c" in - save output_dir test_file tests_doc; - let script_doc = compile_script ~output_dir ~test_file in - save ~perm:0o777 output_dir "run_tests.sh" script_doc; - () + ( tests, + concat_map + (compile_random_test_case sigma prog5 args_map convert_from) + (List.combine tests insts) ) diff --git a/backend/cn/lib/testGeneration/specTests.mli b/backend/cn/lib/testGeneration/specTests.mli index 90d019cba..b64eb23c1 100644 --- a/backend/cn/lib/testGeneration/specTests.mli +++ b/backend/cn/lib/testGeneration/specTests.mli @@ -1,10 +1,19 @@ module CF = Cerb_frontend module A = CF.AilSyntax -val generate - : output_dir:string -> - filename:string -> - with_ownership_checking:bool -> - CF.GenTypes.genTypeCategory A.sigma -> +val compile_constant_tests + : CF.GenTypes.genTypeCategory A.sigma -> + Executable_spec_extract.instrumentation list -> + Test.t list * Pp.document + +val compile_generators + : CF.GenTypes.genTypeCategory A.sigma -> + unit Mucore.file -> + Executable_spec_extract.instrumentation list -> + Pp.document + +val compile_generator_tests + : CF.GenTypes.genTypeCategory A.sigma -> unit Mucore.file -> - unit + Executable_spec_extract.instrumentation list -> + Test.t list * Pp.document diff --git a/backend/cn/lib/testGeneration/test.ml b/backend/cn/lib/testGeneration/test.ml new file mode 100644 index 000000000..b0e06eb23 --- /dev/null +++ b/backend/cn/lib/testGeneration/test.ml @@ -0,0 +1,14 @@ +type kind = + | Constant (* Run function without arguments nor `accesses` once *) + | Generator (* Run function with random inputs satisfying the precondition *) + +type t = + { kind : kind; + suite : string; + test : string + } + +let registration_macro (test : t) : string = + match test.kind with + | Constant -> "CN_REGISTER_UNIT_TEST_CASE" + | Generator -> "CN_REGISTER_RANDOM_TEST_CASE" diff --git a/backend/cn/lib/testGeneration/testGenConfig.ml b/backend/cn/lib/testGeneration/testGenConfig.ml index de647740e..8a43a1223 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.ml +++ b/backend/cn/lib/testGeneration/testGenConfig.ml @@ -1,23 +1,51 @@ type t = { (* Compile time *) + num_samples : int; max_backtracks : int; - max_unfolds : int; + max_unfolds : int option; max_array_length : int; + with_static_hack : bool; (* Run time *) + input_timeout : int option; null_in_every : int option; seed : string option; logging_level : int option; - interactive : bool + progress_level : int option; + interactive : bool; + until_timeout : int option; + exit_fast : bool; + max_stack_depth : int option; + allowed_depth_failures : int option; + max_generator_size : int option; + random_size_splits : bool; + allowed_size_split_backtracks : int option; + sized_null : bool; + coverage : bool; + disable_passes : string list } let default = - { max_backtracks = 25; - max_unfolds = 5; + { num_samples = 100; + max_backtracks = 25; + max_unfolds = None; max_array_length = 50; + with_static_hack = false; + input_timeout = None; null_in_every = None; seed = None; logging_level = None; - interactive = false + progress_level = None; + interactive = false; + until_timeout = None; + exit_fast = false; + max_stack_depth = None; + allowed_depth_failures = None; + max_generator_size = None; + random_size_splits = false; + allowed_size_split_backtracks = None; + sized_null = false; + coverage = false; + disable_passes = [] } @@ -25,16 +53,44 @@ let instance = ref default let initialize (cfg : t) = instance := cfg +let get_num_samples () = !instance.num_samples + let get_max_backtracks () = !instance.max_backtracks let get_max_unfolds () = !instance.max_unfolds let get_max_array_length () = !instance.max_array_length +let with_static_hack () = !instance.with_static_hack + +let has_input_timeout () = !instance.input_timeout + let has_null_in_every () = !instance.null_in_every let has_seed () = !instance.seed let has_logging_level () = !instance.logging_level +let has_progress_level () = !instance.progress_level + let is_interactive () = !instance.interactive + +let is_until_timeout () = !instance.until_timeout + +let is_exit_fast () = !instance.exit_fast + +let has_max_stack_depth () = !instance.max_stack_depth + +let has_allowed_depth_failures () = !instance.allowed_depth_failures + +let has_max_generator_size () = !instance.max_generator_size + +let is_random_size_splits () = !instance.random_size_splits + +let has_allowed_size_split_backtracks () = !instance.allowed_size_split_backtracks + +let is_sized_null () = !instance.sized_null + +let is_coverage () = !instance.coverage + +let has_pass s = not (List.mem String.equal s !instance.disable_passes) diff --git a/backend/cn/lib/testGeneration/testGenConfig.mli b/backend/cn/lib/testGeneration/testGenConfig.mli index 479c37109..e1c9acbce 100644 --- a/backend/cn/lib/testGeneration/testGenConfig.mli +++ b/backend/cn/lib/testGeneration/testGenConfig.mli @@ -1,29 +1,71 @@ type t = { (* Compile time *) + num_samples : int; max_backtracks : int; - max_unfolds : int; + max_unfolds : int option; max_array_length : int; + with_static_hack : bool; (* Run time *) + input_timeout : int option; null_in_every : int option; seed : string option; logging_level : int option; - interactive : bool + progress_level : int option; + interactive : bool; + until_timeout : int option; + exit_fast : bool; + max_stack_depth : int option; + allowed_depth_failures : int option; + max_generator_size : int option; + random_size_splits : bool; + allowed_size_split_backtracks : int option; + sized_null : bool; + coverage : bool; + disable_passes : string list } val default : t val initialize : t -> unit +val get_num_samples : unit -> int + val get_max_backtracks : unit -> int -val get_max_unfolds : unit -> int +val get_max_unfolds : unit -> int option val get_max_array_length : unit -> int +val with_static_hack : unit -> bool + +val has_input_timeout : unit -> int option + val has_null_in_every : unit -> int option val has_seed : unit -> string option val has_logging_level : unit -> int option +val has_progress_level : unit -> int option + val is_interactive : unit -> bool + +val is_until_timeout : unit -> int option + +val is_exit_fast : unit -> bool + +val has_max_stack_depth : unit -> int option + +val has_allowed_depth_failures : unit -> int option + +val has_max_generator_size : unit -> int option + +val is_random_size_splits : unit -> bool + +val has_allowed_size_split_backtracks : unit -> int option + +val is_sized_null : unit -> bool + +val is_coverage : unit -> bool + +val has_pass : string -> bool diff --git a/backend/cn/lib/testGeneration/testGeneration.ml b/backend/cn/lib/testGeneration/testGeneration.ml index 684139381..abe4ac061 100644 --- a/backend/cn/lib/testGeneration/testGeneration.ml +++ b/backend/cn/lib/testGeneration/testGeneration.ml @@ -1,21 +1,382 @@ +module CF = Cerb_frontend +module A = CF.AilSyntax +module C = CF.Ctype +module AT = ArgumentTypes +module LAT = LogicalArgumentTypes +module CtA = Cn_internal_to_ail +module ESpecInternal = Executable_spec_internal module Config = TestGenConfig type config = Config.t let default_cfg : config = Config.default +let set_config = Config.initialize + +let is_constant_function + (sigma : CF.GenTypes.genTypeCategory A.sigma) + (inst : Executable_spec_extract.instrumentation) + = + let _, _, decl = List.assoc Sym.equal inst.fn sigma.declarations in + match decl with + | Decl_function (_, _, args, _, _, _) -> + List.is_empty args + && Sym.Set.is_empty + (LAT.free_vars (fun _ -> Sym.Set.empty) (AT.get_lat (Option.get inst.internal))) + | Decl_object _ -> failwith __LOC__ + + +let compile_assumes + ~(without_ownership_checking : bool) + (sigma : CF.GenTypes.genTypeCategory A.sigma) + (prog5 : unit Mucore.file) + (insts : Executable_spec_extract.instrumentation list) + : Pp.document + = + let declarations, function_definitions = + List.split + (List.map + (fun ctype -> + Cn_internal_to_ail.generate_assume_ownership_function + ~without_ownership_checking + ctype) + (let module CtypeSet = + Set.Make (struct + type t = C.ctype + + let compare a b = compare (Hashtbl.hash a) (Hashtbl.hash b) + end) + in + !CtA.ownership_ctypes |> CtypeSet.of_list |> CtypeSet.to_seq |> List.of_seq) + @ Cn_internal_to_ail.cn_to_ail_assume_predicates_internal + prog5.resource_predicates + sigma.cn_datatypes + [] + prog5.resource_predicates + @ ESpecInternal.generate_c_assume_pres_internal insts sigma prog5) + in + let open Pp in + separate_map + (twice hardline) + (fun (tag, (_, _, decl)) -> + CF.Pp_ail.pp_function_prototype ~executable_spec:true tag decl) + declarations + ^^ twice hardline + ^^ CF.Pp_ail.pp_program + ~executable_spec:true + ~show_include:true + (None, { A.empty_sigma with declarations; function_definitions }) + ^^ hardline + + +let pp_label ?(width : int = 30) (label : string) (doc : Pp.document) : Pp.document = + let padding = max 2 ((width - (String.length label + 2)) / 2) in + let width = max width (String.length label + 6) in + let open Pp in + if PPrint.requirement doc = 0 then + empty + else + repeat width slash + ^^ hardline + ^^ repeat + (if String.length label mod 2 = 1 then + padding + 1 + else + padding) + slash + ^^ space + ^^ string label + ^^ space + ^^ repeat padding slash + ^^ hardline + ^^ repeat width slash + ^^ twice hardline + ^^ doc + + +let compile_includes ~filename_base = + let open Pp in + string "#include " + ^^ dquotes (string (filename_base ^ "_gen.h")) + ^^ hardline + ^^ + if Config.with_static_hack () then + string "#include " + ^^ dquotes (string (filename_base ^ "-exec.c")) + ^^ hardline + ^^ string "#include " + ^^ dquotes (string "cn.c") + else + string "#include " ^^ dquotes (string "cn.h") + + +let compile_test test = + let open Pp in + let macro = Test.registration_macro test in + string macro ^^ parens (string test.suite ^^ comma ^^ space ^^ string test.test) ^^ semi + + +let compile_test_file + ~(without_ownership_checking : bool) + (filename_base : string) + (sigma : CF.GenTypes.genTypeCategory A.sigma) + (prog5 : unit Mucore.file) + (insts : Executable_spec_extract.instrumentation list) + = + let for_constant, for_generator = List.partition (is_constant_function sigma) insts in + let constant_tests, constant_tests_defs = + SpecTests.compile_constant_tests sigma for_constant + in + let generator_tests, generator_tests_defs = + SpecTests.compile_generator_tests sigma prog5 for_generator + in + let tests = [ constant_tests; generator_tests ] in + let open Pp in + compile_includes ~filename_base + ^^ twice hardline + ^^ pp_label + "Assume Ownership Functions" + (compile_assumes ~without_ownership_checking sigma prog5 insts) + ^^ pp_label "Constant function tests" constant_tests_defs + ^^ pp_label "Generator-based tests" generator_tests_defs + ^^ pp_label + "Main function" + (string "int main" + ^^ parens (string "int argc, char* argv[]") + ^^ break 1 + ^^ braces + (nest + 2 + (hardline + ^^ separate_map + (twice hardline) + (separate_map hardline compile_test) + tests + ^^ twice hardline + ^^ string "return cn_test_main(argc, argv);") + ^^ hardline)) + ^^ hardline + + +let save ?(perm = 0o666) (output_dir : string) (filename : string) (doc : Pp.document) + : unit + = + let oc = + Stdlib.open_out_gen + [ Open_wronly; Open_creat; Open_trunc; Open_text ] + perm + (Filename.concat output_dir filename) + in + output_string oc (Pp.plain ~width:80 doc); + close_out oc + + +let save_generators + ~output_dir + ~filename_base + (sigma : CF.GenTypes.genTypeCategory A.sigma) + (prog5 : unit Mucore.file) + (insts : Executable_spec_extract.instrumentation list) + : unit + = + let generators_doc = + SpecTests.compile_generators + sigma + prog5 + (List.filter (fun inst -> not (is_constant_function sigma inst)) insts) + in + let generators_fn = filename_base ^ "_gen.h" in + save output_dir generators_fn generators_doc + + +let save_tests + ~output_dir + ~filename_base + ~without_ownership_checking + (sigma : CF.GenTypes.genTypeCategory A.sigma) + (prog5 : unit Mucore.file) + (insts : Executable_spec_extract.instrumentation list) + : unit + = + let tests_doc = + compile_test_file ~without_ownership_checking filename_base sigma prog5 insts + in + save output_dir (filename_base ^ "_test.c") tests_doc + + +let save_build_script ~output_dir ~filename_base = + let script_doc = BuildScript.generate ~output_dir ~filename_base in + save ~perm:0o777 output_dir "run_tests.sh" script_doc + + +(** Workaround for https://github.com/rems-project/cerberus/issues/784 *) +let needs_static_hack + ~(with_warning : bool) + (cabs_tunit : CF.Cabs.translation_unit) + (sigma : CF.GenTypes.genTypeCategory A.sigma) + (inst : Executable_spec_extract.instrumentation) + = + let (TUnit decls) = cabs_tunit in + let is_static_func () = + List.exists + (fun decl -> + match decl with + | CF.Cabs.EDecl_func + (FunDef + ( loc, + _, + { storage_classes; _ }, + Declarator + (_, DDecl_function (DDecl_identifier (_, Identifier (_, fn')), _)), + _ )) + when String.equal (Sym.pp_string inst.fn) fn' + && List.exists + (fun scs -> match scs with CF.Cabs.SC_static -> true | _ -> false) + storage_classes -> + if with_warning then + Cerb_colour.with_colour + (fun () -> + Pp.( + warn + loc + (string "Static function" + ^^^ squotes (Sym.pp inst.fn) + ^^^ string "could not be tested." + ^/^ string "Try again with '--with-static-hack'"))) + (); + true + | _ -> false) + decls + in + let _, _, _, args, _ = List.assoc Sym.equal inst.fn sigma.function_definitions in + let depends_on_static_glob () = + let global_syms = + inst.internal + |> Option.get + |> AT.get_lat + |> LAT.free_vars (fun _ -> Sym.Set.empty) + |> Sym.Set.to_seq + |> List.of_seq + |> List.filter (fun x -> + not + (List.mem (fun x y -> String.equal (Sym.pp_string x) (Sym.pp_string y)) x args)) + in + let static_globs = + List.filter_map + (fun sym -> + match List.assoc Sym.equal sym sigma.declarations with + | loc, _, Decl_object ((Static, _), _, _, _) -> Some (sym, loc) + | _ -> None) + global_syms + in + if List.is_empty static_globs then + false + else ( + if with_warning then + Cerb_colour.with_colour + (fun () -> + List.iter + (fun (sym, loc) -> + Pp.( + warn + loc + (string "Function" + ^^^ squotes (Sym.pp inst.fn) + ^^^ string "relies on static global" + ^^^ squotes (Sym.pp sym) + ^^ comma + ^^^ string "so could not be tested." + ^^^ string "Try again with '--with-static-hack'."))) + static_globs) + (); + true) + in + is_static_func () || depends_on_static_glob () + + +(** Workaround for https://github.com/rems-project/cerberus/issues/765 *) +let needs_enum_hack + ~(with_warning : bool) + (sigma : CF.GenTypes.genTypeCategory A.sigma) + (inst : Executable_spec_extract.instrumentation) + = + match List.assoc Sym.equal inst.fn sigma.declarations with + | loc, _, Decl_function (_, (_, ret_ct), cts, _, _, _) -> + if + List.exists + (fun (_, ct, _) -> + match ct with C.Ctype (_, Basic (Integer (Enum _))) -> true | _ -> false) + cts + then ( + if with_warning then + Cerb_colour.with_colour + (fun () -> + Pp.( + warn + loc + (string "Function" + ^^^ squotes (Sym.pp inst.fn) + ^^^ string "has enum arguments and so could not be tested." + ^/^ string "Try again with '--with-static-hack'"))) + (); + true) + else if match ret_ct with C.Ctype (_, Basic (Integer (Enum _))) -> true | _ -> false + then ( + if with_warning then + Cerb_colour.with_colour + (fun () -> + Pp.( + warn + loc + (string "Function" + ^^^ squotes (Sym.pp inst.fn) + ^^^ string "has an enum return type and so could not be tested." + ^/^ string "Try again with '--with-static-hack'"))) + (); + true) + else + false + | _ -> false + + +let functions_under_test + ~(with_warning : bool) + (cabs_tunit : CF.Cabs.translation_unit) + (sigma : CF.GenTypes.genTypeCategory A.sigma) + (prog5 : unit Mucore.file) + : Executable_spec_extract.instrumentation list + = + let insts = prog5 |> Executable_spec_extract.collect_instrumentation |> fst in + let selected_fsyms = + Check.select_functions + (Sym.Set.of_list + (List.map + (fun (inst : Executable_spec_extract.instrumentation) -> inst.fn) + insts)) + in + insts + |> List.filter (fun (inst : Executable_spec_extract.instrumentation) -> + Option.is_some inst.internal + && Sym.Set.mem inst.fn selected_fsyms + && (Config.with_static_hack () + || not + (needs_static_hack ~with_warning cabs_tunit sigma inst + || needs_enum_hack ~with_warning sigma inst))) + + let run ~output_dir ~filename - ~with_ownership_checking - (cfg : config) - (sigma : Cerb_frontend.GenTypes.genTypeCategory Cerb_frontend.AilSyntax.sigma) + ~without_ownership_checking + (cabs_tunit : CF.Cabs.translation_unit) + (sigma : CF.GenTypes.genTypeCategory A.sigma) (prog5 : unit Mucore.file) : unit = - Config.initialize cfg; - if Option.is_some prog5.main then - failwith "Cannot test a file with a `main` function"; Cerb_debug.begin_csv_timing (); - SpecTests.generate ~output_dir ~filename ~with_ownership_checking sigma prog5; + let insts = functions_under_test ~with_warning:false cabs_tunit sigma prog5 in + let filename_base = filename |> Filename.basename |> Filename.chop_extension in + save_generators ~output_dir ~filename_base sigma prog5 insts; + save_tests ~output_dir ~filename_base ~without_ownership_checking sigma prog5 insts; + save_build_script ~output_dir ~filename_base; Cerb_debug.end_csv_timing "specification test generation" diff --git a/backend/cn/lib/testGeneration/testGeneration.mli b/backend/cn/lib/testGeneration/testGeneration.mli index 8bda60b43..2e7b60dea 100644 --- a/backend/cn/lib/testGeneration/testGeneration.mli +++ b/backend/cn/lib/testGeneration/testGeneration.mli @@ -2,11 +2,20 @@ type config = TestGenConfig.t val default_cfg : config +val set_config : config -> unit + +val functions_under_test + : with_warning:bool -> + Cerb_frontend.Cabs.translation_unit -> + Cerb_frontend.GenTypes.genTypeCategory Cerb_frontend.AilSyntax.sigma -> + unit Mucore.file -> + Executable_spec_extract.instrumentation list + val run : output_dir:string -> filename:string -> - with_ownership_checking:bool -> - config -> + without_ownership_checking:bool -> + Cerb_frontend.Cabs.translation_unit -> Cerb_frontend.GenTypes.genTypeCategory Cerb_frontend.AilSyntax.sigma -> unit Mucore.file -> unit diff --git a/backend/cn/lib/typeErrors.ml b/backend/cn/lib/typeErrors.ml index aec11c3a9..6013e2af7 100644 --- a/backend/cn/lib/typeErrors.ml +++ b/backend/cn/lib/typeErrors.ml @@ -1,14 +1,10 @@ -open Explain -open Pp -open Locations -module BT = BaseTypes module IT = IndexTerms -module LS = LogicalSorts module CF = Cerb_frontend module Loc = Locations -module RE = Resources +module Res = Resource module LC = LogicalConstraints -module RET = ResourceTypes +module Req = Request +open Pp type label_kind = Where.label @@ -88,193 +84,143 @@ let for_situation = function | Subtyping -> !^"for returning") -type request_chain_elem = - { resource : RET.t; - loc : Locations.t option; - reason : string option - } +module RequestChain = struct + type elem = + { resource : Req.t; + loc : Locations.t option; + reason : string option + } -type request_chain = request_chain_elem list + type t = elem list + + let pp requests = + let pp_req req = + let doc = Req.pp req.resource in + let doc = + match req.loc with + | None -> doc + | Some loc -> + doc ^^ hardline ^^ !^" " ^^ !^(fst (Locations.head_pos_of_location loc)) + in + match req.reason with None -> doc | Some str -> doc ^^^ parens !^str + in + let rec loop req = function + | [] -> !^"Resource needed:" ^^^ pp_req req + | req2 :: reqs -> loop req2 reqs ^^ hardline ^^ !^" which requires:" ^^^ pp_req req + in + match requests with [] -> None | req :: reqs -> Some (loop req reqs) +end type message = - | Unknown_variable of Sym.t - | Unknown_function of Sym.t - | Unknown_struct of Sym.t - | Unknown_datatype of Sym.t - | Unknown_datatype_constr of Sym.t - | Unknown_resource_predicate of - { id : Sym.t; - logical : bool - } - | Unknown_logical_function of - { id : Sym.t; - resource : bool - } - | Unexpected_member of Id.t list * Id.t - | Unknown_lemma of Sym.t + | Global of Global.error + | WellTyped of WellTyped.message (* some from Kayvan's compilePredicates module *) | First_iarg_missing | First_iarg_not_pointer of - { pname : ResourceTypes.predicate_name; + { pname : Request.name; found_bty : BaseTypes.t } - | Missing_member of Id.t | Missing_resource of - { requests : request_chain; + { requests : RequestChain.t; situation : situation; - ctxt : Context.t * log; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } | Merging_multiple_arrays of - { requests : request_chain; + { requests : RequestChain.t; situation : situation; - ctxt : Context.t * log; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } | Unused_resource of - { resource : RE.t; - ctxt : Context.t * log; + { resource : Res.t; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } - | Number_members of - { has : int; - expect : int - } - | Number_arguments of - { has : int; - expect : int - } - | Number_input_arguments of - { has : int; - expect : int - } - | Number_output_arguments of - { has : int; - expect : int - } - | Mismatch of - { has : document; - expect : document - } - | Illtyped_it of - { it : Pp.document; - has : Pp.document; (* 'expected' and 'has' as in Kayvan's Core type checker *) - expected : string; - reason : string - } | Illtyped_binary_it of { left : IT.Surface.t; right : IT.Surface.t; binop : CF.Cn.cn_binop } - | NIA of - { it : IT.t; - hint : string - } | TooBigExponent : { it : IT.t } -> message | NegativeExponent : { it : IT.t } -> message | Write_value_unrepresentable of { ct : Sctypes.t; location : IT.t; value : IT.t; - ctxt : Context.t * log; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } | Int_unrepresentable of { value : IT.t; ict : Sctypes.t; - ctxt : Context.t * log; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } | Unproven_constraint of { constr : LC.t; - requests : request_chain; - info : info; - ctxt : Context.t * log; + requests : RequestChain.t; + info : Locations.info; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } | Undefined_behaviour of { ub : CF.Undefined.undefined_behaviour; - ctxt : Context.t * log; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } | Needs_alloc_id of { ptr : IT.t; ub : CF.Undefined.undefined_behaviour; - ctxt : Context.t * log; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } | Alloc_out_of_bounds of { term : IT.t; constr : IT.t; ub : CF.Undefined.undefined_behaviour; - ctxt : Context.t * log; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } | Allocation_not_live of - { reason : [ `Copy_alloc_id | `Ptr_cmp | `Ptr_diff | `ISO_array_shift ]; + { reason : + [ `Copy_alloc_id | `Ptr_cmp | `Ptr_diff | `ISO_array_shift | `ISO_member_shift ]; ptr : IT.t; - ctxt : Context.t * log; + ctxt : Context.t * Explain.log; model_constr : (Solver.model_with_q * IT.t) option } (* | Implementation_defined_behaviour of document * state_report *) | Unspecified of CF.Ctype.ctype | StaticError of { err : string; - ctxt : Context.t * log; + ctxt : Context.t * Explain.log; model : Solver.model_with_q } - | Generic of Pp.document + | Generic of Pp.document (** TODO delete this *) | Generic_with_model of - { err : Pp.document; + { err : document; model : Solver.model_with_q; - ctxt : Context.t * log + ctxt : Context.t * Explain.log } - | Unsupported of Pp.document + | Unsupported of document | Parser of Cerb_frontend.Errors.cparser_cause - | Empty_pattern - | Missing_pattern of Pp.document - | Redundant_pattern of Pp.document - | Duplicate_pattern | Empty_provenance - | Inconsistent_assumptions of string * (Context.t * log) + | Inconsistent_assumptions of string * (Context.t * Explain.log) | Byte_conv_needs_owned -type type_error = +type t = { loc : Locations.t; msg : message } type report = - { short : Pp.document; - descr : Pp.document option; + { short : document; + descr : document option; state : Report.report option } -let request_chain_description requests = - let pp_req req = - let doc = RET.pp req.resource in - let doc = - match req.loc with - | None -> doc - | Some loc -> - doc ^^ hardline ^^ !^" " ^^ !^(fst (Locations.head_pos_of_location loc)) - in - match req.reason with None -> doc | Some str -> doc ^^^ parens !^str - in - let rec loop req = function - | [] -> !^"Resource needed:" ^^^ pp_req req - | req2 :: reqs -> loop req2 reqs ^^ hardline ^^ !^" which requires:" ^^^ pp_req req - in - match requests with [] -> None | req :: reqs -> Some (loop req reqs) - - -let pp_message te = - match te with - | Unknown_variable s -> - let short = !^"Unknown variable" ^^^ squotes (Sym.pp s) in - { short; descr = None; state = None } - | Unknown_function sym -> +let pp_global = function + | Global.Unknown_function sym -> let short = !^"Unknown function" ^^^ squotes (Sym.pp sym) in { short; descr = None; state = None } | Unknown_struct tag -> @@ -304,89 +250,25 @@ let pp_message te = None in { short; descr; state = None } - | Unexpected_member (expected, member) -> - let short = !^"Unexpected member" ^^^ Id.pp member in - let descr = !^"the struct only has members" ^^^ Pp.list Id.pp expected in - { short; descr = Some descr; state = None } | Unknown_lemma sym -> let short = !^"Unknown lemma" ^^^ squotes (Sym.pp sym) in { short; descr = None; state = None } - | First_iarg_missing -> - let short = !^"Missing pointer input argument" in - let descr = !^"a predicate definition must have at least one input argument" in - { short; descr = Some descr; state = None } - | First_iarg_not_pointer { pname; found_bty } -> - let short = !^"Non-pointer first input argument" in - let descr = - !^"the first input argument of predicate" - ^^^ Pp.squotes (ResourceTypes.pp_predicate_name pname) - ^^^ !^"must have type" - ^^^ Pp.squotes BaseTypes.(pp (Loc ())) - ^^^ !^"but was found with type" - ^^^ Pp.squotes BaseTypes.(pp found_bty) - in + | Unexpected_member (expected, member) -> + let short = !^"Unexpected member" ^^^ Id.pp member in + let descr = !^"the struct only has members" ^^^ list Id.pp expected in { short; descr = Some descr; state = None } - | Missing_member m -> - let short = !^"Missing member" ^^^ Id.pp m in + + +let pp_welltyped = function + | WellTyped.Global msg -> pp_global msg + | Unknown_variable s -> + let short = !^"Unknown variable" ^^^ squotes (Sym.pp s) in { short; descr = None; state = None } - | Missing_resource { requests; situation; ctxt; model } -> - let short = !^"Missing resource" ^^^ for_situation situation in - let descr = request_chain_description requests in - let orequest = - Option.map (fun r -> r.resource) (List.nth_opt (List.rev requests) 0) - in - let state = trace ctxt model Explain.{ no_ex with request = orequest } in - { short; descr; state = Some state } - | Merging_multiple_arrays { requests; situation; ctxt; model } -> - let short = - !^"Cannot satisfy request for resource" - ^^^ for_situation situation - ^^ dot - ^^^ !^"It requires merging multiple arrays." - in - let descr = request_chain_description requests in - let orequest = - Option.map (fun r -> r.resource) (List.nth_opt (List.rev requests) 0) - in - let state = trace ctxt model Explain.{ no_ex with request = orequest } in - { short; descr; state = Some state } - | Unused_resource { resource; ctxt; model } -> - let resource = RE.pp resource in - let short = !^"Left-over unused resource" ^^^ squotes resource in - let state = trace ctxt model Explain.no_ex in - { short; descr = None; state = Some state } - | Number_members { has; expect } -> - let short = !^"Wrong number of struct members" in - let descr = - !^"Expected" - ^^^ !^(string_of_int expect) - ^^ comma - ^^^ !^"has" - ^^^ !^(string_of_int has) - in - { short; descr = Some descr; state = None } - | Number_arguments { has; expect } -> - let short = !^"Wrong number of arguments" in - let descr = - !^"Expected" - ^^^ !^(string_of_int expect) - ^^ comma - ^^^ !^"has" - ^^^ !^(string_of_int has) - in - { short; descr = Some descr; state = None } - | Number_input_arguments { has; expect } -> - let short = !^"Wrong number of input arguments" in - let descr = - !^"Expected" - ^^^ !^(string_of_int expect) - ^^ comma - ^^^ !^"has" - ^^^ !^(string_of_int has) + | Number_arguments { type_; has; expect } -> + let type_ = + match type_ with `Other -> "" | `Input -> "input" | `Output -> "output" in - { short; descr = Some descr; state = None } - | Number_output_arguments { has; expect } -> - let short = !^"Wrong number of output arguments" in + let short = !^"Wrong number" ^^^ !^type_ ^^^ !^"of arguments" in let descr = !^"Expected" ^^^ !^(string_of_int expect) @@ -431,6 +313,66 @@ let pp_message te = ^^^ !^hint in { short; descr = Some descr; state = None } + | Empty_pattern -> + let short = !^"Empty match expression." in + { short; descr = None; state = None } + | Generic err -> + let short = err in + { short; descr = None; state = None } + | Redundant_pattern p' -> + let short = !^"Redundant pattern" in + { short; descr = Some p'; state = None } + | Missing_member m -> + let short = !^"Missing member" ^^^ Id.pp m in + { short; descr = None; state = None } + + +let pp_message = function + | Global msg -> pp_global msg + | WellTyped msg -> pp_welltyped msg + | First_iarg_missing -> + let short = !^"Missing pointer input argument" in + let descr = !^"a predicate definition must have at least one input argument" in + { short; descr = Some descr; state = None } + | First_iarg_not_pointer { pname; found_bty } -> + let short = !^"Non-pointer first input argument" in + let descr = + !^"the first input argument of predicate" + ^^^ squotes (Request.pp_name pname) + ^^^ !^"must have type" + ^^^ squotes BaseTypes.(pp (Loc ())) + ^^^ !^"but was found with type" + ^^^ squotes BaseTypes.(pp found_bty) + in + { short; descr = Some descr; state = None } + | Missing_resource { requests; situation; ctxt; model } -> + let short = !^"Missing resource" ^^^ for_situation situation in + let descr = RequestChain.pp requests in + let orequest = + Option.map + (fun (r : RequestChain.elem) -> r.RequestChain.resource) + (List.nth_opt (List.rev requests) 0) + in + let state = Explain.trace ctxt model Explain.{ no_ex with request = orequest } in + { short; descr; state = Some state } + | Merging_multiple_arrays { requests; situation; ctxt; model } -> + let short = + !^"Cannot satisfy request for resource" + ^^^ for_situation situation + ^^ dot + ^^^ !^"It requires merging multiple arrays." + in + let descr = RequestChain.pp requests in + let orequest = + Option.map (fun r -> r.RequestChain.resource) (List.nth_opt (List.rev requests) 0) + in + let state = Explain.trace ctxt model Explain.{ no_ex with request = orequest } in + { short; descr; state = Some state } + | Unused_resource { resource; ctxt; model } -> + let resource = Res.pp resource in + let short = !^"Left-over unused resource" ^^^ squotes resource in + let state = Explain.trace ctxt model Explain.no_ex in + { short; descr = None; state = Some state } | TooBigExponent { it } -> let it = IT.pp it in let short = !^"Exponent too big" in @@ -461,7 +403,7 @@ let pp_message te = let short = !^"Write value not representable at type" ^^^ Sctypes.pp ct in let location = IT.pp location in let value = IT.pp value in - let state = trace ctxt model Explain.no_ex in + let state = Explain.trace ctxt model Explain.no_ex in let descr = !^"Location" ^^ colon ^^^ location ^^ comma ^^^ !^"value" ^^ colon ^^^ value ^^ dot in @@ -470,12 +412,12 @@ let pp_message te = let short = !^"integer value not representable at type" ^^^ Sctypes.pp ict in let value = IT.pp value in let descr = !^"Value" ^^ colon ^^^ value in - let state = trace ctxt model Explain.no_ex in + let state = Explain.trace ctxt model Explain.no_ex in { short; descr = Some descr; state = Some state } | Unproven_constraint { constr; requests; info; ctxt; model } -> let short = !^"Unprovable constraint" in let state = - trace ctxt model Explain.{ no_ex with unproven_constraint = Some constr } + Explain.trace ctxt model Explain.{ no_ex with unproven_constraint = Some constr } in let descr = let spec_loc, odescr = info in @@ -485,14 +427,14 @@ let pp_message te = | None -> !^"Constraint from" ^^^ !^head ^/^ !^pos | Some descr -> !^"Constraint from" ^^^ !^descr ^^^ !^head ^/^ !^pos in - match request_chain_description requests with + match RequestChain.pp requests with | Some doc2 -> doc ^^ hardline ^^ doc2 | None -> doc in { short; descr = Some descr; state = Some state } | Undefined_behaviour { ub; ctxt; model } -> let short = !^"Undefined behaviour" in - let state = trace ctxt model Explain.no_ex in + let state = Explain.trace ctxt model Explain.no_ex in let descr = match CF.Undefined.std_of_undefined_behaviour ub with | Some stdref -> !^(CF.Undefined.ub_short_string ub) ^^^ parens !^stdref @@ -501,7 +443,7 @@ let pp_message te = { short; descr = Some descr; state = Some state } | Needs_alloc_id { ptr; ub; ctxt; model } -> let short = !^"Pointer " ^^ bquotes (IT.pp ptr) ^^ !^" needs allocation ID" in - let state = trace ctxt model Explain.no_ex in + let state = Explain.trace ctxt model Explain.no_ex in let descr = match CF.Undefined.std_of_undefined_behaviour ub with | Some stdref -> !^(CF.Undefined.ub_short_string ub) ^^^ parens !^stdref @@ -511,7 +453,10 @@ let pp_message te = | Alloc_out_of_bounds { constr; term; ub; ctxt; model } -> let short = bquotes (IT.pp term) ^^ !^" out of bounds" in let state = - trace ctxt model Explain.{ no_ex with unproven_constraint = Some (LC.T constr) } + Explain.trace + ctxt + model + Explain.{ no_ex with unproven_constraint = Some (LC.T constr) } in let descr = match CF.Undefined.std_of_undefined_behaviour ub with @@ -520,12 +465,19 @@ let pp_message te = in { short; descr = Some descr; state = Some state } | Allocation_not_live { reason; ptr; ctxt; model_constr } -> - let reason = + let adjust = function + | IT.IT (CopyAllocId { loc; _ }, _, _) -> loc + | IT.IT (ArrayShift { base; _ }, _, _) -> base + | IT.IT (MemberShift (ptr, _, _), _, _) -> ptr + | _ -> assert false + in + let reason, ptr = match reason with - | `Copy_alloc_id -> "copy_alloc_id" - | `Ptr_diff -> "pointer difference" - | `Ptr_cmp -> "pointer comparison" - | `ISO_array_shift -> "array shift" + | `Copy_alloc_id -> ("copy_alloc_id", adjust ptr) + | `Ptr_diff -> ("pointer difference", ptr) + | `Ptr_cmp -> ("pointer comparison", ptr) + | `ISO_array_shift -> ("array shift", adjust ptr) + | `ISO_member_shift -> ("member shift", adjust ptr) in let short = !^"Pointer " ^^ bquotes (IT.pp ptr) ^^^ !^"needs to be live for" ^^^ !^reason @@ -533,7 +485,10 @@ let pp_message te = let state = Option.map (fun (model, constr) -> - trace ctxt model Explain.{ no_ex with unproven_constraint = Some (LC.T constr) }) + Explain.trace + ctxt + model + Explain.{ no_ex with unproven_constraint = Some (LC.T constr) }) model_constr in let descr = !^"Need an Alloc or Owned in context with same allocation id" in @@ -547,7 +502,7 @@ let pp_message te = { short; descr = None; state = None } | StaticError { err; ctxt; model } -> let short = !^"Static error" in - let state = trace ctxt model Explain.no_ex in + let state = Explain.trace ctxt model Explain.no_ex in let descr = !^err in { short; descr = Some descr; state = Some state } | Generic err -> @@ -555,7 +510,7 @@ let pp_message te = { short; descr = None; state = None } | Generic_with_model { err; model; ctxt } -> let short = err in - let state = trace ctxt model Explain.no_ex in + let state = Explain.trace ctxt model Explain.no_ex in { short; descr = None; state = Some state } | Unsupported err -> let short = err in @@ -563,18 +518,6 @@ let pp_message te = | Parser err -> let short = !^(Cerb_frontend.Pp_errors.string_of_cparser_cause err) in { short; descr = None; state = None } - | Empty_pattern -> - let short = !^"Empty match expression." in - { short; descr = None; state = None } - | Missing_pattern p' -> - let short = !^"Missing pattern" ^^^ squotes p' ^^ dot in - { short; descr = None; state = None } - | Redundant_pattern p' -> - let short = !^"Redundant pattern" in - { short; descr = Some p'; state = None } - | Duplicate_pattern -> - let short = !^"Duplicate pattern" in - { short; descr = None; state = None } | Empty_provenance -> let short = !^"Empty provenance" in { short; descr = None; state = None } @@ -588,25 +531,23 @@ let pp_message te = Some (squotes (IT.pp left) ^^^ !^"has type" - ^^^ squotes (BaseTypes.Surface.pp (IT.bt left)) + ^^^ squotes (BaseTypes.Surface.pp (IT.get_bt left)) ^^ comma ^^^ squotes (IT.pp right) ^^^ !^"has type" - ^^^ squotes (BaseTypes.Surface.pp (IT.bt right)) + ^^^ squotes (BaseTypes.Surface.pp (IT.get_bt right)) ^^ dot) in { short; descr; state = None } | Inconsistent_assumptions (kind, ctxt_log) -> let short = !^kind ^^ !^" makes inconsistent assumptions" in - let state = Some (trace ctxt_log (Solver.empty_model, []) Explain.no_ex) in + let state = Some (Explain.trace ctxt_log (Solver.empty_model, []) Explain.no_ex) in { short; descr = None; state } | Byte_conv_needs_owned -> let short = !^"byte conversion only supports Owned/Block" in { short; descr = None; state = None } -type t = type_error - (** Convert a possibly-relative filepath into an absolute one. *) let canonicalize (path : string) : string = if Filename.is_relative path then ( @@ -616,79 +557,132 @@ let canonicalize (path : string) : string = path -(** Create a filename derived from the given error location, and create a file - with that name in [output_dir], which will be created if it doesn't exist. - If no directory is provided, or if the provided directory name is - unusable, the file is created in the system temporary directory instead. *) -let mk_state_file_name - ?(output_dir : string option) +(** Construct a canonical path to a directory and create the directory if it + doesn't already exist. If [output_dir] is provided, the path will point to + it. If not, the path will point to a temporary directory instead. *) +let mk_output_dir (output_dir : string option) : string = + match output_dir with + | None -> Filename.get_temp_dir_name () + | Some d -> + let dir = canonicalize d in + if not (Sys.file_exists dir) then ( + (* 0o700 == r+w+x permissions for current user *) + Sys.mkdir dir 0o700; + dir) + else if Sys.is_directory dir then + dir + else + Filename.get_temp_dir_name () + + +(** A naming convention for files that pertain to specific error locations. The + generated name will always include the user-provided [~name], which should + be a valid filename. *) +let located_file_name ?(fn_name : string option) - (loc : Cerb_location.t) + ~(dir : string) + ~(name : string) + ~(ext : string) + (error_loc : Cerb_location.t) : string = - let dir = - match output_dir with - | None -> Filename.get_temp_dir_name () - | Some d -> - let dir = canonicalize d in - if not (Sys.file_exists dir) then ( - (* 0o700 == r+w+x permissions for current user *) - Sys.mkdir dir 0o700; - dir) - else if Sys.is_directory dir then - dir - else - Filename.get_temp_dir_name () - in - let file_tag = - match Cerb_location.get_filename loc with + let source_file_tag = + match Cerb_location.get_filename error_loc with | None -> "" | Some filename -> "__" ^ Filename.basename filename in let function_tag = match fn_name with None -> "" | Some fn -> "__" ^ fn in - let filename = "state" ^ file_tag ^ function_tag ^ ".html" in + let filename = name ^ source_file_tag ^ function_tag ^ ext in Filename.concat dir filename +(** Construct a canonical filename for state output derived from the given error + location, located in [output_dir]. *) +let mk_state_file_name + ?(fn_name : string option) + (output_dir : string) + (loc : Cerb_location.t) + : string + = + located_file_name ?fn_name ~dir:output_dir ~name:"state" ~ext:".html" loc + + +(** Construct a canonical filename for report output derived from the given + error location, located in [output_dir]. *) +let mk_report_file_name + ?(fn_name : string option) + (output_dir : string) + (loc : Cerb_location.t) + : string + = + located_file_name ?fn_name ~dir:output_dir ~name:"report" ~ext:".json" loc + + (** Format the error for human readability and print it to [stderr]. if the error contains enough information to create an HTML state report, generate one in [output_dir] (or, failing that, the system temporary directory) and print a link to it. *) -let report_pretty ?output_dir:dir_ ?(fn_name : string option) { loc; msg } = +let report_pretty + ?(output_dir : string option) + ?(fn_name : string option) + ?(serialize_json : bool = false) + { loc; msg } + = (* stealing some logic from pp_errors *) let report = pp_message msg in let consider = match report.state with | Some state -> - let file = mk_state_file_name ?output_dir:dir_ ?fn_name loc in + let dir = mk_output_dir output_dir in + let file = mk_state_file_name ?fn_name dir loc in let link = Report.make file (Cerb_location.get_filename loc) state in - let msg = !^"State file:" ^^^ !^("file://" ^ link) in - Some msg - | None -> None + let state_msg = !^"State file:" ^^^ !^("file://" ^ link) in + if serialize_json then ( + let report_file = mk_report_file_name ?fn_name dir loc in + let report_js = Report.report_to_yojson state in + let () = Yojson.Safe.to_file report_file report_js in + let report_msg = !^"Report file:" ^^^ !^("file://" ^ report_file) in + [ state_msg; report_msg ]) + else + [ state_msg ] + | None -> [] in - Pp.error loc report.short (Option.to_list report.descr @ Option.to_list consider) + error loc report.short (Option.to_list report.descr @ consider) (* stealing some logic from pp_errors *) -let report_json ?output_dir:dir_ ?(fn_name : string option) { loc; msg } = +let report_json + ?(output_dir : string option) + ?(fn_name : string option) + ?(serialize_json : bool = false) + { loc; msg } + = let report = pp_message msg in - let state_error_file = + let state_error_file, report_file = match report.state with | Some state -> - let file = mk_state_file_name ?output_dir:dir_ ?fn_name loc in + let dir = mk_output_dir output_dir in + let file = mk_state_file_name ?fn_name dir loc in let link = Report.make file (Cerb_location.get_filename loc) state in - `String link - | None -> `Null + if serialize_json then ( + let report_file = mk_report_file_name ?fn_name dir loc in + let report_js = Report.report_to_yojson state in + let () = Yojson.Safe.to_file report_file report_js in + (`String link, `String report_file)) + else + (`String link, `Null) + | None -> (`Null, `Null) in let descr = - match report.descr with None -> `Null | Some descr -> `String (Pp.plain descr) + match report.descr with None -> `Null | Some descr -> `String (plain descr) in let json = `Assoc [ ("loc", Loc.json_loc loc); - ("short", `String (Pp.plain report.short)); + ("short", `String (plain report.short)); ("descr", descr); - ("state", state_error_file) + ("state", state_error_file); + ("report", report_file) ] in Yojson.Safe.to_channel ~std:true stderr json diff --git a/backend/cn/lib/typeErrors.mli b/backend/cn/lib/typeErrors.mli new file mode 100644 index 000000000..087276d4b --- /dev/null +++ b/backend/cn/lib/typeErrors.mli @@ -0,0 +1,198 @@ +(** TODO Switch to this structure: https://rustc-dev-guide.rust-lang.org/diagnostics.html#diagnostic-structure *) + +(** TODO Cleanly factor out all pretty printing from all error gathering. + Pp.document, string to actual types (including polymorphic variants if need be) *) + +type access = + | Load + | Store + | Deref + | Kill + | Free + | To_bytes + | From_bytes + +type call_situation = + | FunctionCall of Sym.t + | LemmaApplication of Sym.t + | LabelCall of Where.label + | Subtyping + +val call_prefix : call_situation -> string + +type situation = + | Access of access + | Call of call_situation + +(** TODO move *) +val call_situation : call_situation -> Pp.document + +(** TODO move *) +val checking_situation : situation -> Pp.document + +(** TODO move *) +val for_access : access -> Pp.document + +(** TODO move *) +val for_situation : situation -> Pp.document + +module RequestChain : sig + type elem = + { resource : Request.t; + loc : Cerb_location.t option; + reason : string option (** TODO replace with an actual type *) + } + + type t = elem list + + (** TODO move *) + val pp : t -> Pp.document option +end + +type message = + | Global of Global.error + | WellTyped of WellTyped.message + | First_iarg_missing + | First_iarg_not_pointer of + { pname : Request.name; + found_bty : BaseTypes.t + } + | Missing_resource of + { requests : RequestChain.t; + situation : situation; + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Merging_multiple_arrays of + { requests : RequestChain.t; + situation : situation; + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Unused_resource of + { resource : Resource.t; + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Illtyped_binary_it of + { left : IndexTerms.Surface.t; + right : IndexTerms.Surface.t; + binop : Cerb_frontend.Cn.cn_binop + } + | TooBigExponent : { it : IndexTerms.t } -> message + | NegativeExponent : { it : IndexTerms.t } -> message + | Write_value_unrepresentable of + { ct : Sctypes.t; + location : IndexTerms.t; + value : IndexTerms.t; + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Int_unrepresentable of + { value : IndexTerms.t; + ict : Sctypes.t; + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Unproven_constraint of + { constr : LogicalConstraints.t; + requests : RequestChain.t; + info : Locations.info; + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Undefined_behaviour of + { ub : Cerb_frontend.Undefined.undefined_behaviour; + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Needs_alloc_id of + { ptr : IndexTerms.t; + ub : Cerb_frontend.Undefined.undefined_behaviour; + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Alloc_out_of_bounds of + { term : IndexTerms.t; + constr : IndexTerms.t; + ub : Cerb_frontend.Undefined.undefined_behaviour; + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Allocation_not_live of + { reason : + [ `Copy_alloc_id | `ISO_array_shift | `ISO_member_shift | `Ptr_cmp | `Ptr_diff ]; + ptr : IndexTerms.t; + ctxt : Context.t * Explain.log; + model_constr : (Solver.model_with_q * IndexTerms.t) option + } + | Unspecified of Cerb_frontend.Ctype.ctype + | StaticError of + { err : string; (** TODO replace with an actual type *) + ctxt : Context.t * Explain.log; + model : Solver.model_with_q + } + | Generic of Pp.document (** TODO delete this *) + | Generic_with_model of + { err : Pp.document; (** TODO delete this too *) + model : Solver.model_with_q; + ctxt : Context.t * Explain.log + } + | Unsupported of Pp.document (** TODO add source location *) + | Parser of Cerb_frontend.Errors.cparser_cause + | Empty_provenance + | Inconsistent_assumptions of string * (Context.t * Explain.log) + (** TODO replace string with an actual type *) + | Byte_conv_needs_owned + +type t = + { loc : Locations.t; + msg : message + } + +(** TODO move *) +type report = + { short : Pp.document; + descr : Pp.document option; + state : Report.report option (** Why is this here? *) + } + +(** TODO move *) +val pp_message : message -> report + +(** TODO move *) +val canonicalize : string -> string + +(** TODO move *) +val mk_output_dir : string option -> string + +(** TODO move *) +val located_file_name + : ?fn_name:string -> + dir:string -> + name:string -> + ext:string -> + Cerb_location.t -> + string + +(** TODO move *) +val mk_state_file_name : ?fn_name:string -> string -> Cerb_location.t -> string + +(** TODO move *) +val mk_report_file_name : ?fn_name:string -> string -> Cerb_location.t -> string + +(** TODO move *) +val report_pretty + : ?output_dir:string -> + ?fn_name:string -> + ?serialize_json:bool -> + t -> + unit + +(** TODO move *) +val report_json + : ?output_dir:string -> + ?fn_name:string -> + ?serialize_json:bool -> + t -> + unit diff --git a/backend/cn/lib/typing.ml b/backend/cn/lib/typing.ml index 1ccd4cd81..74e58a84b 100644 --- a/backend/cn/lib/typing.ml +++ b/backend/cn/lib/typing.ml @@ -1,20 +1,20 @@ -open Context +module BT = BaseTypes +module Res = Resource +module Req = Request +module LC = LogicalConstraints +module Loc = Locations module IT = IndexTerms module ITSet = Set.Make (IT) -module SymMap = Map.Make (Sym) -module RET = ResourceTypes -module RE = Resources -open TypeErrors type solver = Solver.solver type s = { typing_context : Context.t; solver : solver option; - sym_eqs : IT.t SymMap.t; + sym_eqs : IT.t Sym.Map.t; past_models : (Solver.model_with_q * Context.t) list; found_equalities : EqTable.table; - movable_indices : (RET.predicate_name * IT.t) list; + movable_indices : (Req.name * IT.t) list; unfold_resources_required : bool; log : Explain.log } @@ -22,7 +22,7 @@ type s = let empty_s (c : Context.t) = { typing_context = c; solver = None; - sym_eqs = SymMap.empty; + sym_eqs = Sym.Map.empty; past_models = []; found_equalities = EqTable.empty; movable_indices = []; @@ -56,7 +56,7 @@ let get () : s t = fun s -> Ok (s, s) (* due to solver interaction, this has to be used carefully *) let set (s' : s) : unit t = fun _s -> Ok ((), s') -let run (c : Context.t) (m : 'a t) : 'a Resultat.t = +let run (c : Context.t) (m : 'a t) : 'a Or_TypeError.t = match m (empty_s c) with Ok (a, _) -> Ok a | Error e -> Error e @@ -68,17 +68,17 @@ let run_from_pause (f : 'a -> 'b t) (pause : 'a pause) = match pause with Ok (a, s) -> Result.map fst @@ f a s | Error e -> Error e -let pause_to_result (pause : 'a pause) : 'a Resultat.t = Result.map fst pause +let pause_to_result (pause : 'a pause) : 'a Or_TypeError.t = Result.map fst pause let pure (m : 'a t) : 'a t = fun s -> - Solver.push (Option.get s.solver); + Option.iter Solver.push s.solver; let outcome = match m s with Ok (a, _) -> Ok (a, s) | Error e -> Error e in - Solver.pop (Option.get s.solver) 1; + Option.iter (fun s -> Solver.pop s 1) s.solver; outcome -let sandbox (m : 'a t) : 'a Resultat.t t = +let sandbox (m : 'a t) : 'a Or_TypeError.t t = fun s -> let n = Solver.num_scopes (Option.get s.solver) in Solver.push (Option.get s.solver); @@ -97,14 +97,14 @@ let sandbox (m : 'a t) : 'a Resultat.t t = Ok (outcome, s) -let embed_resultat (m : 'a Resultat.t) : 'a m = +let lift (m : 'a Or_TypeError.t) : 'a m = fun s -> match m with Ok r -> Ok (r, s) | Error e -> Error e (* end basic functions *) module Eff = Effectful.Make (struct - type 'a m = 'a t + type nonrec 'a t = 'a t let bind = bind @@ -179,21 +179,11 @@ let print_with_ctxt printer = let get_global () : Global.t t = inspect_typing_context (fun c -> c.global) +(** TODO delete this, have Global.t be constructed by itself *) let set_global (g : Global.t) : unit t = modify_typing_context (fun s -> { s with global = g }) -(* later functions should be rewritten to use `inspect_global` and `modify_global` *) -let _inspect_global (f : Global.t -> 'a) : 'a t = - let@ g = get_global () in - return (f g) - - -let _modify_global (f : Global.t -> Global.t) : unit t = - let@ g = get_global () in - set_global (f g) - - let record_action ((a : Explain.action), (loc : Loc.t)) : unit t = modify (fun s -> { s with log = Action (a, loc) :: s.log }) @@ -205,143 +195,107 @@ let modify_where (f : Where.t -> Where.t) : unit t = { s with log; typing_context }) -(* convenient functions for global typing context *) - -let get_logical_function_def loc id = - let@ global = get_global () in - match Global.get_logical_function_def global id with - | Some def -> return def - | None -> - fail (fun _ -> - { loc; - msg = - Unknown_logical_function - { id; - resource = Option.is_some (Global.get_resource_predicate_def global id) - } - }) - - -let get_struct_decl loc tag = - let@ global = get_global () in - match SymMap.find_opt tag global.struct_decls with - | Some decl -> return decl - | None -> fail (fun _ -> { loc; msg = Unknown_struct tag }) - +module ErrorReader = struct + type nonrec 'a t = 'a t -let get_datatype loc tag = - let@ global = get_global () in - match SymMap.find_opt tag global.datatypes with - | Some dt -> return dt - | None -> fail (fun _ -> { loc; msg = Unknown_datatype tag }) + let return = return + let bind = bind -let get_datatype_constr loc tag = - let@ global = get_global () in - match SymMap.find_opt tag global.datatype_constrs with - | Some info -> return info - | None -> fail (fun _ -> { loc; msg = Unknown_datatype_constr tag }) + let get_global () = + let@ s = get () in + return s.typing_context.global -let get_member_type loc _tag member layout : Sctypes.t m = - let member_types = Memory.member_types layout in - match List.assoc_opt Id.equal member member_types with - | Some membertyp -> return membertyp - | None -> - fail (fun _ -> { loc; msg = Unexpected_member (List.map fst member_types, member) }) + let lift = function + | Ok x -> return x + | Error WellTyped.{ loc; msg } -> fail (fun _ -> { loc; msg = WellTyped msg }) -let get_struct_member_type loc tag member = - let@ decl = get_struct_decl loc tag in - let@ ty = get_member_type loc tag member decl in - return ty + let fail loc msg = fail (fun _ -> { loc; msg = Global msg }) + let get_context () = + let@ s = get () in + return s.typing_context +end -let get_fun_decl loc fsym = - let@ global = get_global () in - match Global.get_fun_decl global fsym with - | Some t -> return t - | None -> fail (fun _ -> { loc; msg = Unknown_function fsym }) +module Global = struct + include Global.Lift (ErrorReader) + let empty = Global.empty -let get_lemma loc lsym = - let@ global = get_global () in - match Global.get_lemma global lsym with - | Some t -> return t - | None -> fail (fun _ -> { loc; msg = Unknown_lemma lsym }) + let is_fun_decl global id = Option.is_some @@ Global.get_fun_decl global id + let get_struct_member_type loc tag member = + let@ decl = get_struct_decl loc tag in + let@ ty = get_member_type loc member decl in + return ty -let get_resource_predicate_def loc id = - let@ global = get_global () in - match Global.get_resource_predicate_def global id with - | Some def -> return def - | None -> - fail (fun _ -> - { loc; - msg = - Unknown_resource_predicate - { id; logical = Option.is_some (Global.get_logical_function_def global id) } - }) + let get_fun_decls () = + let@ global = get_global () in + return (Sym.Map.bindings global.fun_decls) -let add_struct_decl tag layout : unit m = - let@ global = get_global () in - set_global { global with struct_decls = SymMap.add tag layout global.struct_decls } + let add_struct_decl tag layout : unit m = + let@ global = get_global () in + set_global { global with struct_decls = Sym.Map.add tag layout global.struct_decls } -let add_fun_decl fname entry = - let@ global = get_global () in - set_global { global with fun_decls = SymMap.add fname entry global.fun_decls } + let add_fun_decl fname entry = + let@ global = get_global () in + set_global { global with fun_decls = Sym.Map.add fname entry global.fun_decls } -let add_lemma lemma_s (loc, lemma_typ) = - let@ global = get_global () in - set_global { global with lemmata = SymMap.add lemma_s (loc, lemma_typ) global.lemmata } + let add_lemma lemma_s (loc, lemma_typ) = + let@ global = get_global () in + set_global + { global with lemmata = Sym.Map.add lemma_s (loc, lemma_typ) global.lemmata } -let add_resource_predicate name entry = - let@ global = get_global () in - set_global - { global with - resource_predicates = Global.SymMap.add name entry global.resource_predicates - } + let add_resource_predicate name entry = + let@ global = get_global () in + set_global + { global with + resource_predicates = Sym.Map.add name entry global.resource_predicates + } -let add_logical_function name entry = - let@ global = get_global () in - set_global - { global with - logical_functions = Global.SymMap.add name entry global.logical_functions - } + let add_logical_function name entry = + let@ global = get_global () in + set_global + { global with logical_functions = Sym.Map.add name entry global.logical_functions } -let add_datatype name entry = - let@ global = get_global () in - set_global { global with datatypes = SymMap.add name entry global.datatypes } + let add_datatype name entry = + let@ global = get_global () in + set_global { global with datatypes = Sym.Map.add name entry global.datatypes } -let add_datatype_constr name entry = - let@ global = get_global () in - set_global - { global with datatype_constrs = SymMap.add name entry global.datatype_constrs } + let add_datatype_constr name entry = + let@ global = get_global () in + set_global + { global with datatype_constrs = Sym.Map.add name entry global.datatype_constrs } -let set_datatype_order datatype_order = - let@ g = get_global () in - set_global { g with datatype_order } + let set_datatype_order datatype_order = + let@ g = get_global () in + set_global { g with datatype_order } -let get_datatype_order () = - let@ g = get_global () in - return g.datatype_order + let get_datatype_order () = + let@ g = get_global () in + return g.datatype_order +end (* end: convenient functions for global typing context *) +module WellTyped = WellTyped.Lift (ErrorReader) + let add_sym_eqs sym_eqs = modify (fun s -> let sym_eqs = - List.fold_left (fun acc (s, v) -> SymMap.add s v acc) s.sym_eqs sym_eqs + List.fold_left (fun acc (s, v) -> Sym.Map.add s v acc) s.sym_eqs sym_eqs in { s with sym_eqs }) @@ -418,7 +372,7 @@ let init_solver () = modify (fun s -> let c = s.typing_context in let solver = Solver.make c.global in - LCSet.iter (Solver.add_assumption solver c.global) c.constraints; + LC.Set.iter (Solver.add_assumption solver c.global) c.constraints; { s with solver = Some solver }) @@ -440,16 +394,14 @@ let add_c_internal lc = return () -let add_r_internal ?(derive_constraints = true) loc (r, RE.O oargs) = +let add_r_internal ?(derive_constraints = true) loc (r, Res.O oargs) = let@ s = get_typing_context () in let@ simp_ctxt = simp_ctxt () in - let r = Simplify.ResourceTypes.simp simp_ctxt r in + let r = Simplify.Request.simp simp_ctxt r in let oargs = Simplify.IndexTerms.simp simp_ctxt oargs in let pointer_facts = if derive_constraints then - Resources.pointer_facts - ~new_resource:(r, RE.O oargs) - ~old_resources:(Context.get_rs s) + Res.pointer_facts ~new_resource:(r, Res.O oargs) ~old_resources:(Context.get_rs s) else [] in @@ -501,15 +453,14 @@ let get_just_models () = let model_has_prop () = - let@ global = get_global () in let is_some_true t = Option.is_some t && IT.is_true (Option.get t) in - return (fun prop m -> is_some_true (Solver.eval global (fst m) prop)) + return (fun prop m -> is_some_true (Solver.eval (fst m) prop)) let prove_or_model_with_past_model loc m = let@ has_prop = model_has_prop () in let@ p_f = provable_internal loc in - let loc = Locations.other __FUNCTION__ in + let loc = Locations.other __LOC__ in let res lc = match lc with | LC.T t when has_prop (IT.not_ t loc) m -> `Counterex (lazy m) @@ -523,18 +474,17 @@ let prove_or_model_with_past_model loc m = let do_check_model loc m prop = Pp.warn loc (Pp.string "doing model consistency check"); let@ ctxt = get_typing_context () in - let@ global = get_global () in let vs = Context.( - SymMap.bindings ctxt.computational @ SymMap.bindings ctxt.logical + Sym.Map.bindings ctxt.computational @ Sym.Map.bindings ctxt.logical |> List.filter (fun (_, (bt_or_v, _)) -> not (has_value bt_or_v)) |> List.map (fun (nm, (bt_or_v, (loc, _))) -> IT.sym_ (nm, bt_of bt_or_v, loc))) in - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let eqs = List.filter_map (fun v -> - match Solver.eval global (fst m) v with + match Solver.eval (fst m) v with | None -> None | Some x -> Some (IT.eq_ (v, x) here)) vs @@ -560,8 +510,8 @@ let model_with_internal loc prop = | Some m -> return (Some m) | None -> let@ prover = provable_internal loc in - let here = Locations.other __FUNCTION__ in - (match prover (LC.t_ (IT.not_ prop here)) with + let here = Locations.other __LOC__ in + (match prover (LC.T (IT.not_ prop here)) with | `True -> return None | `False -> let@ m = model () in @@ -571,17 +521,6 @@ let model_with_internal loc prop = (* functions for binding return types and associated auxiliary functions *) -let ensure_logical_sort (loc : Loc.t) ~(expect : LS.t) (has : LS.t) : unit m = - if LS.equal has expect then - return () - else - fail (fun _ -> { loc; msg = Mismatch { has = BT.pp has; expect = BT.pp expect } }) - - -let ensure_base_type (loc : Loc.t) ~(expect : BT.t) (has : BT.t) : unit m = - ensure_logical_sort loc ~expect has - - let make_return_record loc (record_name : string) record_members = let record_s = Sym.fresh_make_uniq record_name in (* let record_s = Sym.fresh_make_uniq (TypeErrors.call_prefix call_situation) in *) @@ -602,12 +541,14 @@ let bind_logical_return_internal loc = let rec aux members lrt = match (members, lrt) with | member :: members, LogicalReturnTypes.Define ((s, it), _, lrt) -> - let@ () = ensure_base_type loc ~expect:(IT.bt it) (IT.bt member) in - let@ () = add_c_internal (LC.t_ (IT.eq__ member it loc)) in + let@ () = + WellTyped.ensure_base_type loc ~expect:(IT.get_bt it) (IT.get_bt member) + in + let@ () = add_c_internal (LC.T (IT.eq__ member it loc)) in aux members (LogicalReturnTypes.subst (IT.make_subst [ (s, member) ]) lrt) | member :: members, Resource ((s, (re, bt)), _, lrt) -> - let@ () = ensure_base_type loc ~expect:bt (IT.bt member) in - let@ () = add_r_internal loc (re, RE.O member) in + let@ () = WellTyped.ensure_base_type loc ~expect:bt (IT.get_bt member) in + let@ () = add_r_internal loc (re, Res.O member) in aux members (LogicalReturnTypes.subst (IT.make_subst [ (s, member) ]) lrt) | members, Constraint (lc, _, lrt) -> let@ () = add_c_internal lc in @@ -627,7 +568,7 @@ let bind_logical_return loc members lrt = let bind_return loc members (rt : ReturnTypes.t) = match (members, rt) with | member :: members, Computational ((s, bt), _, lrt) -> - let@ () = ensure_base_type loc ~expect:bt (IT.bt member) in + let@ () = WellTyped.ensure_base_type loc ~expect:bt (IT.get_bt member) in let@ () = bind_logical_return loc @@ -643,9 +584,10 @@ let bind_return loc members (rt : ReturnTypes.t) = type changed = | Deleted | Unchanged - | Changed of RE.t + | Changed of Res.t -let map_and_fold_resources_internal loc (f : RE.t -> 'acc -> changed * 'acc) (acc : 'acc) = +let map_and_fold_resources_internal loc (f : Res.t -> 'acc -> changed * 'acc) (acc : 'acc) + = let@ s = get_typing_context () in let@ provable_f = provable_internal loc in let resources, orig_ix = s.resources in @@ -663,7 +605,7 @@ let map_and_fold_resources_internal loc (f : RE.t -> 'acc -> changed * 'acc) (ac let ix, hist = Context.res_written loc i "changed" (ix, hist) in (match re with | Q { q; permission; _ }, _ -> - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in (match provable_f (LC.forall_ q (IT.not_ permission here)) with | `True -> (resources, ix, hist, i :: changed_or_deleted, acc) | `False -> @@ -689,11 +631,11 @@ let do_unfold_resources loc = let rec aux () = let@ s = get_typing_context () in let@ movable_indices = get_movable_indices () in - let@ _provable_f = provable_internal (Locations.other __FUNCTION__) in + let@ _provable_f = provable_internal (Locations.other __LOC__) in let resources, orig_ix = s.resources in let _orig_hist = s.resource_history in Pp.debug 8 (lazy (Pp.string "-- checking resource unfolds now --")); - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let@ true_m = model_with_internal loc (IT.bool_ true here) in match true_m with | None -> return () (* contradictory state *) @@ -704,7 +646,7 @@ let do_unfold_resources loc = (fun (re, i) (keep, unpack, extract) -> match Pack.unpack loc s.global provable_f2 re with | Some unpackable -> - let pname = RET.predicate_name (fst re) in + let pname = Req.get_name (fst re) in (keep, (i, pname, unpackable) :: unpack, extract) | None -> let re_reduced, extracted = @@ -728,7 +670,7 @@ let do_unfold_resources loc = let@ _, members = make_return_record loc - ("unpack_" ^ Pp.plain (RET.pp_predicate_name pname)) + ("unpack_" ^ Pp.plain (Req.pp_name pname)) (LogicalReturnTypes.binders lrt) in bind_logical_return_internal loc members lrt @@ -803,11 +745,11 @@ let value_eq_group guard x = let test_value_eqs loc guard x ys = - let here = Locations.other __FUNCTION__ in + let here = Locations.other __LOC__ in let prop y = match guard with - | None -> LC.t_ (IT.eq_ (x, y) here) - | Some t -> LC.t_ (IT.impl_ (t, IT.eq_ (x, y) here) here) + | None -> LC.T (IT.eq_ (x, y) here) + | Some t -> LC.T (IT.impl_ (t, IT.eq_ (x, y) here) here) in let@ prover = provable loc in let guard_it = Option.value guard ~default:(IT.bool_ true here) in diff --git a/backend/cn/lib/typing.mli b/backend/cn/lib/typing.mli index 2ed6fb4fd..881e89b9a 100644 --- a/backend/cn/lib/typing.mli +++ b/backend/cn/lib/typing.mli @@ -1,5 +1,3 @@ -type solver - type 'a t type 'a m = 'a t @@ -26,7 +24,7 @@ val run_from_pause : ('a -> 'b m) -> 'a pause -> ('b, TypeErrors.t) Result.t val pause_to_result : 'a pause -> ('a, TypeErrors.t) Result.t -val sandbox : 'a t -> 'a Resultat.t t +val sandbox : 'a t -> 'a Or_TypeError.t t val get_typing_context : unit -> Context.t m @@ -34,13 +32,13 @@ val print_with_ctxt : (Context.t -> unit) -> unit m val get_global : unit -> Global.t m -val get_cs : unit -> Context.LCSet.t m +val get_cs : unit -> LogicalConstraints.Set.t m val simp_ctxt : unit -> Simplify.simp_ctxt m -val all_resources : Locations.t -> Resources.t list m +val all_resources : Locations.t -> Resource.t list m -val all_resources_tagged : Locations.t -> ((Resources.t * int) list * int) m +val all_resources_tagged : Locations.t -> ((Resource.t * int) list * int) m val provable : Locations.t -> (LogicalConstraints.t -> [> `True | `False ]) m @@ -78,64 +76,72 @@ val add_c : Locations.t -> LogicalConstraints.t -> unit m val add_cs : Locations.t -> LogicalConstraints.t list -> unit m -val add_r : Locations.t -> Resources.t -> unit m - -val add_rs : Locations.t -> Resources.t list -> unit m - -val set_datatype_order : Sym.t list list option -> unit m +val add_r : Locations.t -> Resource.t -> unit m -val get_datatype_order : unit -> Sym.t list list option m +val add_rs : Locations.t -> Resource.t list -> unit m val res_history : Locations.t -> int -> Context.resource_history m type changed = | Deleted | Unchanged - | Changed of Resources.t + | Changed of Resource.t val map_and_fold_resources : Locations.t -> - (Resources.t -> 'acc -> changed * 'acc) -> + (Resource.t -> 'acc -> changed * 'acc) -> 'acc -> ('acc * int list) m -val get_struct_decl : Locations.t -> Sym.t -> Memory.struct_decl m +module Global : sig + val empty : Global.t -val get_struct_member_type : Locations.t -> Sym.t -> Id.t -> Sctypes.t m + val get_struct_decl : Locations.t -> Sym.t -> Memory.struct_decl m -val get_member_type : Locations.t -> Sym.t -> Id.t -> Memory.struct_layout -> Sctypes.t m + val get_struct_member_type : Locations.t -> Sym.t -> Id.t -> Sctypes.t m -val get_datatype : Locations.t -> Sym.t -> BaseTypes.dt_info m + val get_datatype : Locations.t -> Sym.t -> BaseTypes.dt_info m -val get_datatype_constr : Locations.t -> Sym.t -> BaseTypes.constr_info m + val get_datatype_constr : Locations.t -> Sym.t -> BaseTypes.constr_info m -val get_fun_decl - : Locations.t -> - Sym.t -> - (Locations.t * Global.AT.ft option * Sctypes.c_concrete_sig) m + val get_fun_decl + : Locations.t -> + Sym.t -> + (Locations.t * Global.AT.ft option * Sctypes.c_concrete_sig) m -val get_lemma : Locations.t -> Sym.t -> (Locations.t * Global.AT.lemmat) m + val add_lemma : Sym.t -> Locations.t * ArgumentTypes.lemmat -> unit m -val get_resource_predicate_def : Locations.t -> Sym.t -> ResourcePredicates.definition m + val get_lemma : Locations.t -> Sym.t -> (Locations.t * Global.AT.lemmat) m -val get_logical_function_def : Locations.t -> Sym.t -> LogicalFunctions.definition m + val get_resource_predicate_def : Locations.t -> Sym.t -> Definition.Predicate.t m -val add_struct_decl : Sym.t -> Memory.struct_layout -> unit m + val get_logical_function_def : Locations.t -> Sym.t -> Definition.Function.t m -val add_fun_decl - : Sym.t -> - Locations.t * ArgumentTypes.ft option * Sctypes.c_concrete_sig -> - unit m + val add_struct_decl : Sym.t -> Memory.struct_layout -> unit m + + val add_fun_decl + : Sym.t -> + Locations.t * ArgumentTypes.ft option * Sctypes.c_concrete_sig -> + unit m -val add_lemma : Sym.t -> Locations.t * ArgumentTypes.lemmat -> unit m + val set_datatype_order : Sym.t list list option -> unit m -val add_resource_predicate : Sym.t -> ResourcePredicates.definition -> unit m + val get_datatype_order : unit -> Sym.t list list option m -val add_logical_function : Sym.t -> LogicalFunctions.definition -> unit m + val add_resource_predicate : Sym.t -> Definition.Predicate.t -> unit m -val add_datatype : Sym.t -> BaseTypes.dt_info -> unit m + val add_logical_function : Sym.t -> Definition.Function.t -> unit m -val add_datatype_constr : Sym.t -> BaseTypes.constr_info -> unit m + val add_datatype : Sym.t -> BaseTypes.dt_info -> unit m + + val add_datatype_constr : Sym.t -> BaseTypes.constr_info -> unit m + + val is_fun_decl : Global.t -> Sym.t -> bool + + val get_fun_decls + : unit -> + (Sym.t * (Locations.t * Global.AT.ft option * Sctypes.c_concrete_sig)) list m +end (* val set_statement_locs : Locations.loc CStatements.LocMap.t -> (unit) m *) @@ -148,11 +154,7 @@ val test_value_eqs IndexTerms.t list -> unit m -val embed_resultat : 'a Resultat.t -> 'a m - -val ensure_logical_sort : Locations.t -> expect:LogicalSorts.t -> LogicalSorts.t -> unit m - -val ensure_base_type : Locations.t -> expect:LogicalSorts.t -> LogicalSorts.t -> unit m +val lift : 'a Or_TypeError.t -> 'a m val make_return_record : Locations.t -> @@ -171,10 +173,10 @@ val bind_return : Locations.t -> IndexTerms.t list -> ReturnTypes.t -> IndexTerm val add_movable_index : Locations.t -> (* verbose:bool -> *) - ResourceTypes.predicate_name * IndexTerms.t -> + Request.name * IndexTerms.t -> unit m -val get_movable_indices : unit -> (ResourceTypes.predicate_name * IndexTerms.t) list m +val get_movable_indices : unit -> (Request.name * IndexTerms.t) list m val record_action : Explain.action * Locations.t -> unit m @@ -184,3 +186,5 @@ val modify_where : (Where.t -> Where.t) -> unit m (* val add_trace_item_to_trace : Context.trace_item * Locations.t -> unit m *) val init_solver : unit -> unit m + +module WellTyped : WellTyped_intf.S with type 'a t := 'a t diff --git a/backend/cn/lib/wellTyped.ml b/backend/cn/lib/wellTyped.ml index f6e863433..da7ad671f 100644 --- a/backend/cn/lib/wellTyped.ml +++ b/backend/cn/lib/wellTyped.ml @@ -1,28 +1,111 @@ module CF = Cerb_frontend -module LS = LogicalSorts module BT = BaseTypes -module SymSet = Set.Make (Sym) -module TE = TypeErrors -module RE = Resources -module RET = ResourceTypes -module LRT = LogicalReturnTypes -module AT = ArgumentTypes -module LAT = LogicalArgumentTypes -module Mu = Mucore +module IT = IndexTerms +module Loc = Locations module IdSet = Set.Make (Id) -open Context -open Global -open TE -open Pp -open Typing +open Pp.Infix + +let squotes, warn, dot, string, debug, item, colon, comma = + Pp.(squotes, warn, dot, string, debug, item, colon, comma) + + +type message = + | Global of Global.error + | Mismatch of + { has : Pp.document; + expect : Pp.document + } + | Generic of Pp.document (** TODO remove *) + | Illtyped_it of + { it : Pp.document; (** TODO replace with terms *) + has : Pp.document; (* 'expected' and 'has' as in Kayvan's Core type checker *) + expected : string; + reason : string + } + | Number_arguments of + { type_ : [ `Other | `Input | `Output ]; + has : int; + expect : int + } + | Missing_member of Id.t + | NIA of + { it : IT.t; + hint : string + } + | Empty_pattern + | Redundant_pattern of Pp.document + | Unknown_variable of Sym.t + +type error = + { loc : Locations.t; + msg : message + } + +type 'a t = Context.t -> ('a * Context.t, error) Result.t + +module GlobalReader = struct + type nonrec 'a t = 'a t + + let return x s = Ok (x, s) + + let bind x f s = match x s with Ok (y, s') -> f y s' | Error err -> Error err + + let get_global () s = Ok (s.Context.global, s) + + let fail loc msg _ = Error { loc; msg = Global msg } +end + +module NoSolver = struct + include GlobalReader + include Global.Lift (GlobalReader) + + let fail err : 'a t = fun _ -> Error err + + let ( let@ ) = bind + + let get_struct_member_type loc tag member = + let@ decl = get_struct_decl loc tag in + let@ ty = get_member_type loc member decl in + return ty + + + let pure x s = match x s with Ok (y, _) -> Ok (y, s) | Error err -> Error err + + let update f s = Ok ((), f s) + + let lookup f : _ t = fun s -> Ok (f s, s) + + let bound_a sym = lookup (Context.bound_a sym) + + let bound_l sym = lookup (Context.bound_l sym) -open Effectful.Make (Typing) + let get_a sym = lookup (Context.get_a sym) + + let get_l sym = lookup (Context.get_l sym) + + let add_a sym bt info = update (Context.add_a sym bt info) + + let add_l sym bt info = update (Context.add_l sym bt info) + + let lift = function Ok x -> return x | Error x -> fail x + + let run ctxt x = x ctxt +end let use_ity = ref true -let ensure_base_type = Typing.ensure_base_type +open NoSolver + +open Effectful.Make (NoSolver) + +let ensure_base_type loc ~expect has : unit t = + if BT.equal has expect then + return () + else + fail { loc; msg = Mismatch { has = BT.pp has; expect = BT.pp expect } } + -let illtyped_index_term (loc : Locations.t) it has ~expected ~reason (_ctxt, _log) = +let illtyped_index_term (loc : Locations.t) it has ~expected ~reason = let reason = match reason with | Either.Left reason -> @@ -30,16 +113,13 @@ let illtyped_index_term (loc : Locations.t) it has ~expected ~reason (_ctxt, _lo head ^ "\n" ^ pos | Either.Right reason -> reason in - { loc; - msg = TypeErrors.Illtyped_it { it = IT.pp it; has = BT.pp has; expected; reason } - } + { loc; msg = Illtyped_it { it = IT.pp it; has = BT.pp has; expected; reason } } let ensure_bits_type (loc : Loc.t) (has : BT.t) = match has with | BT.Bits (_sign, _n) -> return () - | has -> - fail (fun _ -> { loc; msg = Mismatch { has = BT.pp has; expect = !^"bitvector" } }) + | has -> fail { loc; msg = Mismatch { has = BT.pp has; expect = !^"bitvector" } } let ensure_z_fits_bits_type loc (sign, n) v = @@ -47,77 +127,74 @@ let ensure_z_fits_bits_type loc (sign, n) v = return () else ( let err = !^"Value" ^^^ Pp.z v ^^^ !^"does not fit" ^^^ BT.pp (Bits (sign, n)) in - fail (fun _ -> { loc; msg = Generic err })) + fail { loc; msg = Generic err }) let ensure_arith_type ~reason it = let open BT in - match IT.bt it with + match IT.get_bt it with | Integer | Real | Bits _ -> return () | _ -> let expected = "integer, real or bitvector type" in fail (illtyped_index_term - (IT.loc it) + (IT.get_loc it) it - (IT.bt it) + (IT.get_bt it) ~expected ~reason:(Either.Left reason)) let ensure_set_type ~reason it = let open BT in - match IT.bt it with + match IT.get_bt it with | Set bt -> return bt | _ -> let expected = "set" in fail (illtyped_index_term - (IT.loc it) + (IT.get_loc it) it - (IT.bt it) + (IT.get_bt it) ~expected ~reason:(Either.Left reason)) let ensure_list_type ~reason it = let open BT in - match IT.bt it with + match IT.get_bt it with | List bt -> return bt | _ -> let expected = "list" in fail (illtyped_index_term - (IT.loc it) + (IT.get_loc it) it - (IT.bt it) + (IT.get_bt it) ~expected ~reason:(Either.Left reason)) let ensure_map_type ~reason it = let open BT in - match IT.bt it with + match IT.get_bt it with | Map (abt, rbt) -> return (abt, rbt) | _ -> let expected = "map/array" in fail (illtyped_index_term - (IT.loc it) + (IT.get_loc it) it - (IT.bt it) + (IT.get_bt it) ~expected ~reason:(Either.Left reason)) -let ensure_same_argument_number loc input_output has ~expect = +let ensure_same_argument_number loc type_ has ~expect = if has = expect then return () - else ( - match input_output with - | `General -> fail (fun _ -> { loc; msg = Number_arguments { has; expect } }) - | `Input -> fail (fun _ -> { loc; msg = Number_input_arguments { has; expect } }) - | `Output -> fail (fun _ -> { loc; msg = Number_output_arguments { has; expect } })) + else + fail { loc; msg = Number_arguments { type_; has; expect } } let compare_by_fst_id (x, _) (y, _) = Id.compare x y @@ -130,13 +207,13 @@ let correct_members loc (spec : (Id.t * 'a) list) (have : (Id.t * 'b) list) = if IdSet.mem id needed then return (IdSet.remove id needed) else - fail (fun _ -> { loc; msg = Unexpected_member (List.map fst spec, id) })) + fail { loc; msg = Global (Global.Unexpected_member (List.map fst spec, id)) }) needed have in match IdSet.elements needed with | [] -> return () - | missing :: _ -> fail (fun _ -> { loc; msg = Missing_member missing }) + | missing :: _ -> fail { loc; msg = Missing_member missing } let correct_members_sorted_annotated loc spec have = @@ -204,12 +281,8 @@ module WBT = struct match BT.pick_integer_encoding_type z with | Some bt -> return bt | None -> - fail (fun _ -> - { loc; msg = Generic (Pp.item "no standard encoding type for constant" (Pp.z z)) }) -end - -module WLS = struct - let is_ls = WBT.is_bt + fail + { loc; msg = Generic (Pp.item "no standard encoding type for constant" (Pp.z z)) } end module WCT = struct @@ -229,12 +302,12 @@ module WCT = struct fun ct -> aux ct end +type 'a m = 'a t + module WIT = struct open BaseTypes open IndexTerms - type t = IndexTerms.t - (* let rec check_and_bind_pattern loc bt pat = *) (* match pat with *) (* | PSym s -> *) @@ -282,7 +355,7 @@ module WIT = struct | [] -> assert (List.for_all (function [] -> true | _ -> false) cases); (match cases with - | [] -> fail (fun _ -> { loc; msg = Generic !^"Incomplete pattern" }) + | [] -> fail { loc; msg = Generic !^"Incomplete pattern" } | _ -> return ()) (* | [_(\*[]*\)] -> return () *) (* | _::_::_ -> fail (fun _ -> {loc; msg = Generic !^"Duplicate pattern"}) *) @@ -360,7 +433,7 @@ module WIT = struct ^/^ !^prev_pos ^^ !^suggestion in - fail (fun _ -> { loc = pat_loc; msg = Redundant_pattern err })) + fail { loc = pat_loc; msg = Redundant_pattern err }) [] pats in @@ -369,10 +442,10 @@ module WIT = struct let rec get_location_for_type = function | IT (Apply (name, _args), _, loc) -> - let@ def = Typing.get_logical_function_def loc name in + let@ def = get_logical_function_def loc name in return def.loc | IT ((MapSet (t, _, _) | Let (_, t)), _, _) -> get_location_for_type t - | IT (Cons (it, _), _, _) | it -> return @@ IT.loc it + | IT (Cons (it, _), _, _) | it -> return @@ IT.get_loc it (* NOTE: This cannot _check_ what the root type of term is (the type is @@ -391,7 +464,7 @@ module WIT = struct match () with | () when is_a -> get_a s | () when is_l -> get_l s - | () -> fail (fun _ -> { loc; msg = TE.Unknown_variable s }) + | () -> fail { loc; msg = Unknown_variable s } in (match binding with | BaseType bt -> return (IT (Sym s, bt, loc)) @@ -423,11 +496,11 @@ module WIT = struct | Negate -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - return (t, IT.bt t) + return (t, IT.get_bt t) | BW_CLZ_NoSMT | BW_CTZ_NoSMT | BW_FFS_NoSMT | BW_FLS_NoSMT | BW_Compl -> let@ t = infer t in - let@ () = ensure_bits_type (IT.loc t) (IT.bt t) in - return (t, IT.bt t) + let@ () = ensure_bits_type (IT.get_loc t) (IT.get_bt t) in + return (t, IT.get_bt t) in return (IT (Unop (unop, t), ret_bt, loc)) | Binop (arith_op, t, t') -> @@ -435,18 +508,18 @@ module WIT = struct | Add -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - return (IT (Binop (Add, t, t'), IT.bt t, loc)) + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + return (IT (Binop (Add, t, t'), IT.get_bt t, loc)) | Sub -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - return (IT (Binop (Sub, t, t'), IT.bt t, loc)) + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + return (IT (Binop (Sub, t, t'), IT.get_bt t, loc)) | Mul -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - (match (IT.bt t, is_const t, is_const t') with + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + (match (IT.get_bt t, is_const t, is_const t') with | Integer, None, None -> let msg = !^"Both sides of the integer multiplication" @@ -455,18 +528,18 @@ module WIT = struct ^^^ !^"treating the term as uninterpreted." in warn loc msg; - return (IT (Binop (MulNoSMT, t, t'), IT.bt t, loc)) - | _ -> return (IT (Binop (Mul, t, t'), IT.bt t, loc))) + return (IT (Binop (MulNoSMT, t, t'), IT.get_bt t, loc)) + | _ -> return (IT (Binop (Mul, t, t'), IT.get_bt t, loc))) | MulNoSMT -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - return (IT (Binop (MulNoSMT, t, t'), IT.bt t, loc)) + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + return (IT (Binop (MulNoSMT, t, t'), IT.get_bt t, loc)) | Div -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - (match (IT.bt t, is_const t') with + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + (match (IT.get_bt t, is_const t') with | Integer, Some (Z z', _) when Z.leq z' Z.zero -> let msg = !^"Division" @@ -475,7 +548,7 @@ module WIT = struct ^^^ !^"Treating as uninterpreted." in warn loc msg; - return (IT (Binop (DivNoSMT, t, t'), IT.bt t, loc)) + return (IT (Binop (DivNoSMT, t, t'), IT.get_bt t, loc)) | Integer, None -> let msg = !^"Division" @@ -484,55 +557,53 @@ module WIT = struct ^^^ !^"Treating as uninterpreted." in warn loc msg; - return (IT (Binop (DivNoSMT, t, t'), IT.bt t, loc)) - | _ -> - (* TODO: check for a zero divisor *) - return (IT (Binop (Div, t, t'), IT.bt t, loc))) + return (IT (Binop (DivNoSMT, t, t'), IT.get_bt t, loc)) + | _ -> return (IT (Binop (Div, t, t'), IT.get_bt t, loc))) | DivNoSMT -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - return (IT (Binop (DivNoSMT, t, t'), IT.bt t, loc)) + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + return (IT (Binop (DivNoSMT, t, t'), IT.get_bt t, loc)) | Exp -> let@ t = infer t in - let@ () = ensure_bits_type loc (IT.bt t) in - let@ t' = check (IT.loc t) (IT.bt t) t' in + let@ () = ensure_bits_type loc (IT.get_bt t) in + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in let msg = !^"Treating exponentiation" ^^^ squotes (IT.pp (exp_ (t, t') loc)) ^^^ !^"as uninterpreted." in warn loc msg; - return (IT (Binop (ExpNoSMT, t, t'), IT.bt t, loc)) + return (IT (Binop (ExpNoSMT, t, t'), IT.get_bt t, loc)) | ExpNoSMT | RemNoSMT | ModNoSMT | BW_Xor | BW_And | BW_Or | ShiftLeft | ShiftRight | Rem | Mod -> let@ t = infer t in - let@ () = ensure_bits_type loc (IT.bt t) in - let@ t' = check (IT.loc t) (IT.bt t) t' in - return (IT (Binop (arith_op, t, t'), IT.bt t, loc)) + let@ () = ensure_bits_type loc (IT.get_bt t) in + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + return (IT (Binop (arith_op, t, t'), IT.get_bt t, loc)) | LT -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in return (IT (Binop (LT, t, t'), BT.Bool, loc)) | LE -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in return (IT (Binop (LE, t, t'), BT.Bool, loc)) | Min -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - return (IT (Binop (Min, t, t'), IT.bt t, loc)) + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + return (IT (Binop (Min, t, t'), IT.get_bt t, loc)) | Max -> let@ t = infer t in let@ () = ensure_arith_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - return (IT (Binop (Max, t, t'), IT.bt t, loc)) + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + return (IT (Binop (Max, t, t'), IT.get_bt t, loc)) | EQ -> let@ t = infer t in - let@ t' = check (IT.loc t) (IT.bt t) t' in + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in return (IT (Binop (EQ, t, t'), BT.Bool, loc)) | LTPointer -> let@ t = check loc (Loc ()) t in @@ -544,18 +615,18 @@ module WIT = struct return (IT (Binop (LEPointer, t, t'), BT.Bool, loc)) | SetMember -> let@ t = infer t in - let@ t' = check loc (Set (IT.bt t)) t' in + let@ t' = check loc (Set (IT.get_bt t)) t' in return (IT (Binop (SetMember, t, t'), BT.Bool, loc)) | SetUnion -> let@ t = infer t in let@ _itembt = ensure_set_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - return (IT (Binop (SetUnion, t, t'), IT.bt t, loc)) + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + return (IT (Binop (SetUnion, t, t'), IT.get_bt t, loc)) | SetIntersection -> let@ t = infer t in let@ _itembt = ensure_set_type ~reason:loc t in - let@ t' = check (IT.loc t) (IT.bt t) t' in - return (IT (Binop (SetIntersection, t, t'), IT.bt t, loc)) + let@ t' = check (IT.get_loc t) (IT.get_bt t) t' in + return (IT (Binop (SetIntersection, t, t'), IT.get_bt t, loc)) | SetDifference -> let@ t = infer t in let@ itembt = ensure_set_type ~reason:loc t in @@ -564,7 +635,7 @@ module WIT = struct | Subset -> let@ t = infer t in let@ itembt = ensure_set_type ~reason:loc t in - let@ t' = check (IT.loc t) (Set itembt) t' in + let@ t' = check (IT.get_loc t) (Set itembt) t' in return (IT (Binop (Subset, t, t'), BT.Bool, loc)) | And -> let@ t = check loc Bool t in @@ -581,8 +652,8 @@ module WIT = struct | ITE (t, t', t'') -> let@ t = check loc Bool t in let@ t' = infer t' in - let@ t'' = check (IT.loc t') (IT.bt t') t'' in - return (IT (ITE (t, t', t''), IT.bt t', loc)) + let@ t'' = check (IT.get_loc t') (IT.get_bt t') t'' in + return (IT (ITE (t, t', t''), IT.get_bt t', loc)) | EachI ((i1, (s, bt), i2), t) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) pure @@ -596,12 +667,12 @@ module WIT = struct return (IT (EachI ((i1, (s, bt), i2), t), BT.Bool, loc))) | Tuple ts -> let@ ts = ListM.mapM infer ts in - let bts = List.map IT.bt ts in + let bts = List.map IT.get_bt ts in return (IT (Tuple ts, BT.Tuple bts, loc)) | NthTuple (n, t') -> let@ t' = infer t' in let@ item_bt = - match IT.bt t' with + match IT.get_bt t' with | Tuple bts -> (match List.nth_opt bts n with | Some t -> return t @@ -641,7 +712,7 @@ module WIT = struct | StructMember (t, member) -> let@ t = infer t in let@ tag = - match IT.bt t with + match IT.get_bt t with | Struct tag -> return tag | has -> let expected = "struct" in @@ -653,16 +724,16 @@ module WIT = struct | StructUpdate ((t, member), v) -> let@ t = infer t in let@ tag = - match IT.bt t with + match IT.get_bt t with | Struct tag -> return tag | has -> (* this case should have been caught by compile.ml *) let expected = "struct" in - let reason = Either.Left (IT.loc t) in + let reason = Either.Left (IT.get_loc t) in fail (illtyped_index_term loc t has ~expected ~reason) in let@ field_ct = get_struct_member_type loc tag member in - let@ v = check (IT.loc t) (Memory.bt_of_sct field_ct) v in + let@ v = check (IT.get_loc t) (Memory.bt_of_sct field_ct) v in return (IT (StructUpdate ((t, member), v), BT.Struct tag, loc)) | Record members -> assert (List.sorted_and_unique compare_by_fst_id members); @@ -673,12 +744,12 @@ module WIT = struct return (id, t)) members in - let member_types = List.map (fun (id, t) -> (id, IT.bt t)) members in + let member_types = List.map (fun (id, t) -> (id, IT.get_bt t)) members in return (IT (IT.Record members, BT.Record member_types, loc)) | RecordMember (t, member) -> let@ t = infer t in let@ members = - match IT.bt t with + match IT.get_bt t with | Record members -> return members | has -> let expected = "struct" in @@ -689,15 +760,15 @@ module WIT = struct match List.assoc_opt Id.equal member members with | Some bt -> return bt | None -> - let expected = "struct with member " ^ Id.pp_string member in + let expected = "struct with member " ^ Id.get_string member in let reason = Either.Left loc in - fail (illtyped_index_term loc t (IT.bt t) ~expected ~reason) + fail (illtyped_index_term loc t (IT.get_bt t) ~expected ~reason) in return (IT (RecordMember (t, member), bt, loc)) | RecordUpdate ((t, member), v) -> let@ t = infer t in let@ members = - match IT.bt t with + match IT.get_bt t with | Record members -> return members | has -> let expected = "struct" in @@ -708,22 +779,22 @@ module WIT = struct match List.assoc_opt Id.equal member members with | Some bt -> return bt | None -> - let expected = "struct with member " ^ Id.pp_string member in + let expected = "struct with member " ^ Id.get_string member in let reason = Either.Left loc in - fail (illtyped_index_term loc t (IT.bt t) ~expected ~reason) + fail (illtyped_index_term loc t (IT.get_bt t) ~expected ~reason) in - let@ v = check (IT.loc t) bt v in - return (IT (RecordUpdate ((t, member), v), IT.bt t, loc)) + let@ v = check (IT.get_loc t) bt v in + return (IT (RecordUpdate ((t, member), v), IT.get_bt t, loc)) | Cast (cbt, t) -> let@ cbt = WBT.is_bt loc cbt in let@ t = infer t in let@ () = - match (IT.bt t, cbt) with + match (IT.get_bt t, cbt) with | Integer, Loc () -> - fail (fun _ -> + fail { loc; msg = Generic !^"cast from integer not allowed in bitvector version" - }) + } | Loc (), Alloc_id -> return () | Integer, Real -> return () | Real, Integer -> return () @@ -743,7 +814,7 @@ module WIT = struct ^^^ BT.pp target ^^ dot in - fail (fun _ -> { loc; msg = Generic msg }) + fail { loc; msg = Generic msg } in return (IT (Cast (cbt, t), cbt, loc)) | MemberShift (t, tag, member) -> @@ -759,7 +830,7 @@ module WIT = struct let@ () = WCT.is_ct loc ct in let@ base = check loc (Loc ()) base in let@ index = infer index in - let@ () = ensure_bits_type loc (IT.bt index) in + let@ () = ensure_bits_type loc (IT.get_bt index) in return (IT (ArrayShift { base; ct; index }, BT.Loc (), loc)) | CopyAllocId { addr; loc = ptr } -> let@ addr = check loc Memory.uintptr_bt addr in @@ -802,8 +873,8 @@ module WIT = struct return (IT (Nil bt, BT.List bt, loc)) | Cons (t1, t2) -> let@ t1 = infer t1 in - let t1_loc = IT.loc t1 in - let t1_bt = IT.bt t1 in + let t1_loc = IT.get_loc t1 in + let t1_bt = IT.get_bt t1 in (* This is all a little more complicated than ideal because we use the type of the first element of a list literal (currently always non-empty) is used to annotate the (Nil bt), and so _its_ location is the one which must be passed to @@ -840,45 +911,45 @@ module WIT = struct return (IT (Tail t, BT.List bt, loc)) | NthList (i, xs, d) -> let@ i = infer i in - let@ () = ensure_bits_type loc (IT.bt i) in + let@ () = ensure_bits_type loc (IT.get_bt i) in let@ xs = infer xs in let@ bt = ensure_list_type xs ~reason:loc in - let@ d = check (IT.loc xs) bt d in + let@ d = check (IT.get_loc xs) bt d in return (IT (NthList (i, xs, d), bt, loc)) | ArrayToList (arr, i, len) -> let@ i = infer i in - let@ () = ensure_bits_type loc (IT.bt i) in - let@ len = check (IT.loc i) (IT.bt i) len in + let@ () = ensure_bits_type loc (IT.get_bt i) in + let@ len = check (IT.get_loc i) (IT.get_bt i) len in let@ arr = infer arr in let@ ix_bt, bt = ensure_map_type ~reason:loc arr in let@ () = - if BT.equal ix_bt (IT.bt i) then + if BT.equal ix_bt (IT.get_bt i) then return () else - fail (fun _ -> + fail { loc; msg = Generic (Pp.item "array_to_list: index type disagreement" (Pp.list IT.pp_with_typ [ i; arr ])) - }) + } in return (IT (ArrayToList (arr, i, len), BT.List bt, loc)) | MapConst (index_bt, t) -> let@ index_bt = WBT.is_bt loc index_bt in let@ t = infer t in - return (IT (MapConst (index_bt, t), BT.Map (index_bt, IT.bt t), loc)) + return (IT (MapConst (index_bt, t), BT.Map (index_bt, IT.get_bt t), loc)) | MapSet (t1, t2, t3) -> let@ t1 = infer t1 in let@ abt, rbt = ensure_map_type ~reason:loc t1 in - let@ t2 = check (IT.loc t1) abt t2 in - let@ t3 = check (IT.loc t1) rbt t3 in - return (IT (MapSet (t1, t2, t3), IT.bt t1, loc)) + let@ t2 = check (IT.get_loc t1) abt t2 in + let@ t3 = check (IT.get_loc t1) rbt t3 in + return (IT (MapSet (t1, t2, t3), IT.get_bt t1, loc)) | MapGet (t, arg) -> let@ t = infer t in let@ abt, bt = ensure_map_type ~reason:loc t in - let@ arg = check (IT.loc t) abt arg in + let@ arg = check (IT.get_loc t) abt arg in return (IT (MapGet (t, arg), bt, loc)) | MapDef ((s, abt), body) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) @@ -886,11 +957,11 @@ module WIT = struct pure (let@ () = add_l s abt (loc, lazy (Pp.string "map-def-var")) in let@ body = infer body in - return (IT (MapDef ((s, abt), body), Map (abt, IT.bt body), loc))) + return (IT (MapDef ((s, abt), body), Map (abt, IT.get_bt body), loc))) | Apply (name, args) -> - let@ def = Typing.get_logical_function_def loc name in + let@ def = get_logical_function_def loc name in let has_args, expect_args = (List.length args, List.length def.args) in - let@ () = ensure_same_argument_number loc `General has_args ~expect:expect_args in + let@ () = ensure_same_argument_number loc `Other has_args ~expect:expect_args in let@ args = ListM.map2M (fun has_arg (_, def_arg_bt) -> @@ -903,10 +974,10 @@ module WIT = struct | Let ((name, t1), t2) -> let@ t1 = infer t1 in pure - (let@ () = add_l name (IT.bt t1) (loc, lazy (Pp.string "let-var")) in - let@ () = add_c loc (LC.t_ (IT.def_ name t1 loc)) in + (let@ () = add_l name (IT.get_bt t1) (loc, lazy (Pp.string "let-var")) in + (* let@ () = add_c loc (LC.T (IT.def_ name t1 loc)) in *) let@ t2 = infer t2 in - return (IT (Let ((name, t1), t2), IT.bt t2, loc))) + return (IT (Let ((name, t1), t2), IT.get_bt t2, loc))) | Constructor (s, args) -> let@ info = get_datatype_constr loc s in let@ args_annotated = correct_members_sorted_annotated loc info.params args in @@ -925,21 +996,21 @@ module WIT = struct ListM.fold_leftM (fun (rbt, acc) (pat, body) -> pure - (let@ pat = check_and_bind_pattern (IT.bt e) pat in + (let@ pat = check_and_bind_pattern (IT.get_bt e) pat in let@ body = match rbt with None -> infer body | Some rbt -> check loc rbt body in - return (Some (IT.bt body), acc @ [ (pat, body) ]))) + return (Some (IT.get_bt body), acc @ [ (pat, body) ]))) (None, []) cases in let@ () = - cases_complete loc [ IT.bt e ] (List.map (fun (pat, _) -> [ pat ]) cases) + cases_complete loc [ IT.get_bt e ] (List.map (fun (pat, _) -> [ pat ]) cases) in let@ () = cases_necessary (List.map (fun (pat, _) -> pat) cases) in let@ rbt = match rbt with - | None -> fail (fun _ -> { loc; msg = Empty_pattern }) + | None -> fail { loc; msg = Empty_pattern } | Some rbt -> return rbt in return (IT (Match (e, cases), rbt, loc)) @@ -949,15 +1020,15 @@ module WIT = struct and check expect_loc expect_ls it = - let@ ls = WLS.is_ls expect_loc expect_ls in + let@ ls = WBT.is_bt expect_loc expect_ls in let@ it = infer it in let@ loc = get_location_for_type it in - if LS.equal ls (IT.bt it) then + if BT.equal ls (IT.get_bt it) then return it else ( - let expected = Pp.plain @@ LS.pp ls in + let expected = Pp.plain @@ BT.pp ls in let reason = Either.Left expect_loc in - fail (illtyped_index_term loc it (IT.bt it) ~expected ~reason)) + fail (illtyped_index_term loc it (IT.get_bt it) ~expected ~reason)) end let quantifier_bt = BT.Bits (Unsigned, 64) @@ -967,7 +1038,7 @@ let warn_when_not_quantifier_bt (ident : string) (loc : Locations.t) (bt : BaseTypes.t) - (sym : document option) + (sym : Pp.document option) : unit = if not (BT.equal bt quantifier_bt) then @@ -982,16 +1053,17 @@ let warn_when_not_quantifier_bt ^^^ !^"was provided. This will become an error in the future.") -module WRET = struct +module WReq = struct + module Req = Request open IndexTerms let welltyped loc r = - Pp.debug 22 (lazy (Pp.item "WRET: checking" (RET.pp r))); + Pp.debug 22 (lazy (Pp.item "WReq: checking" (Req.pp r))); let@ spec_iargs = - match RET.predicate_name r with + match Req.get_name r with | Owned (_ct, _init) -> return [] | PName name -> - let@ def = Typing.get_resource_predicate_def loc name in + let@ def = get_resource_predicate_def loc name in return def.iargs in match r with @@ -1008,7 +1080,7 @@ module WRET = struct spec_iargs p.iargs in - return (RET.P { name = p.name; pointer; iargs }) + return (Req.P { name = p.name; pointer; iargs }) | Q p -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) let@ pointer = WIT.check loc (BT.Loc ()) p.pointer in @@ -1025,16 +1097,16 @@ module WRET = struct if Z.lt Z.zero z then return step else - fail (fun _ -> + fail { loc; msg = Generic (!^"Iteration step" ^^^ IT.pp p.step ^^^ !^"must be positive") - }) + } | IT (SizeOf _, _, _) -> return step | IT (Cast (_, IT (SizeOf _, _, _)), _, _) -> return step | _ -> let hint = "Only constant iteration steps are allowed." in - fail (fun _ -> { loc; msg = NIA { it = p.step; hint } }) + fail { loc; msg = NIA { it = p.step; hint } } in (*let@ () = match p.name with | (Owned (ct, _init)) -> let sz = Memory.size_of_ctype ct in if IT.equal step (IT.int_lit_ sz (snd p.q)) then return () else fail (fun _ @@ -1046,7 +1118,7 @@ module WRET = struct (let@ () = add_l (fst p.q) (snd p.q) (loc, lazy (Pp.string "forall-var")) in let@ permission = WIT.check loc BT.Bool p.permission in (* let@ provable = provable loc in *) - (* let here = Locations.other __FUNCTION__ in *) + (* let here = Locations.other __LOC__ in *) (* let only_nonnegative_indices = *) (* (\* It is important to use `permission` here and NOT `p.permission`. *) (* If there is a record involved, `permission` is normalised but the @@ -1083,28 +1155,27 @@ module WRET = struct return (permission, iargs)) in return - (RET.Q + (Req.Q { name = p.name; pointer; q = p.q; q_loc = p.q_loc; step; permission; iargs }) end -let oarg_bt_of_pred loc = function - | RET.Owned (ct, _init) -> return (Memory.bt_of_sct ct) - | RET.PName pn -> - let@ def = Typing.get_resource_predicate_def loc pn in - return def.oarg_bt +module WRS = struct + let oarg_bt_of_pred loc = function + | Request.Owned (ct, _init) -> return (Memory.bt_of_sct ct) + | Request.PName pn -> + let@ def = get_resource_predicate_def loc pn in + return def.oarg_bt -let oarg_bt loc = function - | RET.P pred -> oarg_bt_of_pred loc pred.name - | RET.Q pred -> - let@ item_bt = oarg_bt_of_pred loc pred.name in - return (BT.make_map_bt (snd pred.q) item_bt) + let oarg_bt loc = function + | Request.P pred -> oarg_bt_of_pred loc pred.name + | Request.Q pred -> + let@ item_bt = oarg_bt_of_pred loc pred.name in + return (BT.make_map_bt (snd pred.q) item_bt) -module WRS = struct let welltyped loc (resource, bt) = - Pp.(debug 6 (lazy !^__FUNCTION__)); - let@ resource = WRET.welltyped loc resource in + let@ resource = WReq.welltyped loc resource in let@ bt = WBT.is_bt loc bt in let@ oarg_bt = oarg_bt loc resource in let@ () = ensure_base_type loc ~expect:oarg_bt bt in @@ -1112,7 +1183,7 @@ module WRS = struct end module WLC = struct - type t = LogicalConstraints.t + module LC = LogicalConstraints let welltyped loc lc = match lc with @@ -1130,65 +1201,42 @@ end module WLRT = struct module LRT = LogicalReturnTypes - open LRT - - type t = LogicalReturnTypes.t - let welltyped loc lrt = - let rec aux = - let here = Locations.other __FUNCTION__ in - function - | Define ((s, it), ((loc, _) as info), lrt) -> + let welltyped _loc lrt = + let rec aux = function + | LRT.Define ((s, it), ((loc, _) as info), lrt) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) let@ it = WIT.infer it in - let@ () = add_l s (IT.bt it) (loc, lazy (Pp.string "let-var")) in - let@ () = add_c (fst info) (LC.t_ (IT.def_ s it here)) in + let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in let@ lrt = aux lrt in - return (Define ((s, it), info, lrt)) + return (LRT.Define ((s, it), info, lrt)) | Resource ((s, (re, re_oa_spec)), ((loc, _) as info), lrt) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) let@ re, re_oa_spec = WRS.welltyped loc (re, re_oa_spec) in let@ () = add_l s re_oa_spec (loc, lazy (Pp.string "let-var")) in - let@ () = add_r loc (re, O (IT.sym_ (s, re_oa_spec, here))) in let@ lrt = aux lrt in - return (Resource ((s, (re, re_oa_spec)), info, lrt)) + return (LRT.Resource ((s, (re, re_oa_spec)), info, lrt)) | Constraint (lc, info, lrt) -> let@ lc = WLC.welltyped (fst info) lc in - let@ () = add_c (fst info) lc in let@ lrt = aux lrt in - return (Constraint (lc, info, lrt)) - | I -> - let@ provable = provable loc in - let here = Locations.other __FUNCTION__ in - let@ () = - match provable (LC.t_ (IT.bool_ false here)) with - | `True -> - fail (fun ctxt_log -> - { loc; msg = Inconsistent_assumptions ("return type", ctxt_log) }) - | `False -> return () - in - return I + return (LRT.Constraint (lc, info, lrt)) + | I -> return LRT.I in pure (aux lrt) end module WRT = struct - type t = ReturnTypes.t - - let subst = ReturnTypes.subst - let pp = ReturnTypes.pp let welltyped loc rt = - Pp.(debug 6 (lazy !^__FUNCTION__)); pure (match rt with - | RT.Computational ((name, bt), info, lrt) -> + | ReturnTypes.Computational ((name, bt), info, lrt) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) let@ bt = WBT.is_bt (fst info) bt in let@ () = add_a name bt (fst info, lazy (Sym.pp name)) in let@ lrt = WLRT.welltyped loc lrt in - return (RT.Computational ((name, bt), info, lrt))) + return (ReturnTypes.Computational ((name, bt), info, lrt))) end (* module WFalse = struct *) @@ -1201,50 +1249,32 @@ end (* let welltyped _ False.False = return False.False *) (* end *) -let pure_and_no_initial_resources loc m = - pure - (let@ (), _ = map_and_fold_resources loc (fun _re () -> (Deleted, ())) () in - m) - - module WLAT = struct + module LAT = LogicalArgumentTypes + let welltyped i_welltyped i_pp kind loc (at : 'i LAT.t) : 'i LAT.t m = debug 12 (lazy (item ("checking wf of " ^ kind ^ " at " ^ Loc.to_string loc) (LAT.pp i_pp at))); - let rec aux = - let here = Locations.other __FUNCTION__ in - function + let rec aux = function | LAT.Define ((s, it), info, at) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) let@ it = WIT.infer it in - let@ () = add_l s (IT.bt it) (loc, lazy (Pp.string "let-var")) in - let@ () = add_c (fst info) (LC.t_ (IT.def_ s it here)) in + let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in let@ at = aux at in return (LAT.Define ((s, it), info, at)) | LAT.Resource ((s, (re, re_oa_spec)), ((loc, _) as info), at) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) let@ re, re_oa_spec = WRS.welltyped (fst info) (re, re_oa_spec) in let@ () = add_l s re_oa_spec (loc, lazy (Pp.string "let-var")) in - let@ () = add_r loc (re, O (IT.sym_ (s, re_oa_spec, here))) in let@ at = aux at in return (LAT.Resource ((s, (re, re_oa_spec)), info, at)) | LAT.Constraint (lc, info, at) -> let@ lc = WLC.welltyped (fst info) lc in - let@ () = add_c (fst info) lc in let@ at = aux at in return (LAT.Constraint (lc, info, at)) | LAT.I i -> - let@ provable = provable loc in - let here = Locations.other __FUNCTION__ in - let@ () = - match provable (LC.t_ (IT.bool_ false here)) with - | `True -> - fail (fun ctxt_log -> - { loc; msg = Inconsistent_assumptions (kind, ctxt_log) }) - | `False -> return () - in let@ i = i_welltyped loc i in return (LAT.I i) in @@ -1252,6 +1282,8 @@ module WLAT = struct end module WAT = struct + module AT = ArgumentTypes + let welltyped i_welltyped i_pp kind loc (at : 'i AT.t) : 'i AT.t m = debug 12 @@ -1272,22 +1304,24 @@ module WAT = struct end module WFT = struct - let welltyped = - WAT.welltyped - (fun loc rt -> pure_and_no_initial_resources loc (WRT.welltyped loc rt)) - WRT.pp + let welltyped = WAT.welltyped (fun loc rt -> pure (WRT.welltyped loc rt)) WRT.pp end -module WLT = struct - open False +(* + module WLT = struct + open False - let welltyped = WAT.welltyped (fun _loc False -> return False) False.pp -end + let welltyped = WAT.welltyped (fun _loc False -> return False) False.pp + end +*) (* module WPackingFT(struct let name_bts = pd.oargs end) = WLAT(WOutputDef.welltyped (pd.oargs)) *) module WLArgs = struct + module LAT = LogicalArgumentTypes + module Mu = Mucore + let rec typ ityp = function | Mu.Define (bound, info, lat) -> LAT.Define (bound, info, typ ityp lat) | Mu.Resource (bound, info, lat) -> LAT.Resource (bound, info, typ ityp lat) @@ -1295,42 +1329,27 @@ module WLArgs = struct | Mu.I i -> LAT.I (ityp i) - let welltyped (i_welltyped : Loc.t -> 'i -> 'j m) kind loc (at : 'i Mu.arguments_l) + let welltyped (i_welltyped : Loc.t -> 'i -> 'j m) _kind loc (at : 'i Mu.arguments_l) : 'j Mu.arguments_l m = - let rec aux = - let here = Locations.other __FUNCTION__ in - Pp.(debug 6 (lazy !^__FUNCTION__)); - function + let rec aux = function | Mu.Define ((s, it), ((loc, _) as info), at) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) let@ it = WIT.infer it in - let@ () = add_l s (IT.bt it) (loc, lazy (Pp.string "let-var")) in - let@ () = add_c (fst info) (LC.t_ (IT.def_ s it here)) in + let@ () = add_l s (IT.get_bt it) (loc, lazy (Pp.string "let-var")) in let@ at = aux at in return (Mu.Define ((s, it), info, at)) | Mu.Resource ((s, (re, re_oa_spec)), ((loc, _) as info), at) -> (* no need to alpha-rename, because context.ml ensures there's no name clashes *) let@ re, re_oa_spec = WRS.welltyped (fst info) (re, re_oa_spec) in let@ () = add_l s re_oa_spec (loc, lazy (Pp.string "let-var")) in - let@ () = add_r loc (re, O (IT.sym_ (s, re_oa_spec, here))) in let@ at = aux at in return (Mu.Resource ((s, (re, re_oa_spec)), info, at)) | Mu.Constraint (lc, info, at) -> let@ lc = WLC.welltyped (fst info) lc in - let@ () = add_c (fst info) lc in let@ at = aux at in return (Mu.Constraint (lc, info, at)) | Mu.I i -> - let@ provable = provable loc in - let here = Locations.other __FUNCTION__ in - let@ () = - match provable (LC.t_ (IT.bool_ false here)) with - | `True -> - fail (fun ctxt_log -> - { loc; msg = Inconsistent_assumptions (kind, ctxt_log) }) - | `False -> return () - in let@ i = i_welltyped loc i in return (Mu.I i) in @@ -1338,6 +1357,9 @@ module WLArgs = struct end module WArgs = struct + module AT = ArgumentTypes + module Mu = Mucore + let rec typ ityp = function | Mu.Computational (bound, info, at) -> AT.Computational (bound, info, typ ityp at) | Mu.L lat -> AT.L (WLArgs.typ ityp lat) @@ -1348,7 +1370,7 @@ module WArgs = struct (Loc.t -> 'i -> 'j m) -> string -> Loc.t -> 'i Mu.arguments -> 'j Mu.arguments m = fun (i_welltyped : Loc.t -> 'i -> 'j m) kind loc (at : 'i Mu.arguments) -> - debug 6 (lazy !^__FUNCTION__); + debug 6 (lazy !^__LOC__); debug 12 (lazy @@ -1371,23 +1393,19 @@ module WArgs = struct end module BaseTyping = struct - open Typing - open TypeErrors - module SymMap = Map.Make (Sym) module BT = BaseTypes - module RT = ReturnTypes module AT = ArgumentTypes open BT - type label_context = (AT.lt * label_kind * Locations.t) SymMap.t + type label_context = (AT.lt * Where.label * Locations.t) Sym.Map.t let check_against_core_bt loc msg2 cbt bt = - Typing.embed_resultat - (CoreTypeChecks.check_against_core_bt - (fun msg -> Resultat.fail { loc; msg = Generic (msg ^^ Pp.hardline ^^ msg2) }) - cbt - bt) + CoreTypeChecks.check_against_core_bt cbt bt + |> Result.map_error (fun msg -> { loc; msg = Generic (msg ^^ Pp.hardline ^^ msg2) }) + |> lift + + module Mu = Mucore let rec check_and_bind_pattern bt = function | Mu.Pattern (loc, anns, _, p_) -> @@ -1414,8 +1432,7 @@ module BaseTyping = struct match BT.is_list_bt bt with | Some bt -> return bt | None -> - fail (fun _ -> - { loc; msg = Generic (Pp.item "list pattern match against" (BT.pp bt)) }) + fail { loc; msg = Generic (Pp.item "list pattern match against" (BT.pp bt)) } in let@ ctor, pats = match (ctor, pats) with @@ -1423,22 +1440,24 @@ module BaseTyping = struct let@ _item_bt = get_item_bt bt in return (Mu.Cnil cbt, []) | Cnil _, _ -> - fail (fun _ -> - { loc; msg = Number_arguments { has = List.length pats; expect = 0 } }) + let type_ = `Other in + let has = List.length pats in + fail { loc; msg = Number_arguments { type_; has; expect = 0 } } | Ccons, [ p1; p2 ] -> let@ item_bt = get_item_bt bt in let@ p1 = check_and_bind_pattern item_bt p1 in let@ p2 = check_and_bind_pattern bt p2 in return (Mu.Ccons, [ p1; p2 ]) | Ccons, _ -> - fail (fun _ -> - { loc; msg = Number_arguments { has = List.length pats; expect = 2 } }) + let type_ = `Other in + let has = List.length pats in + fail { loc; msg = Number_arguments { type_; has; expect = 2 } } | Ctuple, pats -> let@ bts = match BT.is_tuple_bt bt with | Some bts when List.length bts == List.length pats -> return bts | _ -> - fail (fun _ -> + fail { loc; msg = Generic @@ -1446,7 +1465,7 @@ module BaseTyping = struct (Int.to_string (List.length pats) ^ "-length tuple pattern match against") (BT.pp bt)) - }) + } in let@ pats = ListM.map2M check_and_bind_pattern bts pats in return (Mu.Ctuple, pats) @@ -1501,12 +1520,12 @@ module BaseTyping = struct if BT.fits_range (Option.get (BT.is_bits_bt bt)) z then return (Mu.OV (bt, OVinteger iv)) else - fail (fun _ -> + fail { loc; msg = Generic (!^"Value " ^^^ Pp.z z ^^^ !^"does not fit in expected type" ^^^ BT.pp bt) - }) + } | _ -> let@ ov = infer_object_value loc ov_original in let@ () = ensure_base_type loc ~expect:bt (Mu.bt_of_object_value ov) in @@ -1577,9 +1596,7 @@ module BaseTyping = struct let rec infer_pexpr : 'TY. 'TY Mu.pexpr -> BT.t Mu.pexpr m = fun pe -> let open Mu in - Pp.debug - 22 - (lazy (Pp.item "WellTyped.BaseTyping.infer_pexpr" (Pp_mucore_ast.pp_pexpr pe))); + Pp.debug 22 (lazy (Pp.item __FUNCTION__ (Pp_mucore_ast.pp_pexpr pe))); let (Pexpr (loc, annots, _, pe_)) = pe in match integer_annot annots with | Some ity when !use_ity -> @@ -1705,8 +1722,9 @@ module BaseTyping = struct let@ () = ensure_base_type loc ~expect:(List ibt) (bt_of_pexpr xs) in return (bt_of_pexpr xs) | _ -> - fail (fun _ -> - { loc; msg = Number_arguments { has = List.length pes; expect = 2 } })) + let type_ = `Other in + let has = List.length pes in + fail { loc; msg = Number_arguments { type_; has; expect = 2 } }) | Ctuple -> return (BT.Tuple (List.map bt_of_pexpr pes)) | Carray -> let ibt = bt_of_pexpr (List.hd pes) in @@ -1798,21 +1816,21 @@ module BaseTyping = struct let@ () = ensure_bits_type loc bt in return bt | None, _ -> - fail (fun _ -> + fail { loc; msg = Generic (Pp.item "untypeable mucore function" (Pp_mucore_ast.pp_pexpr orig_pe)) - }) + } | Some `Returns_Integer, None -> - fail (fun _ -> + fail { loc; msg = Generic (Pp.item "mucore function requires type-annotation" (Pp_mucore_ast.pp_pexpr orig_pe)) - }) + } in return (bt, pexps) @@ -1821,18 +1839,15 @@ module BaseTyping = struct let open Cnprog in Pp.debug 22 - (lazy - (Pp.item - "WellTyped.check_cn_statement" - (CF.Pp_ast.pp_doc_tree (dtree_of_statement stmt)))); + (lazy (Pp.item __FUNCTION__ (CF.Pp_ast.pp_doc_tree (dtree_of_statement stmt)))); match stmt with | Pack_unpack (pack_unpack, pt) -> - let@ p_pt = WRET.welltyped loc (P pt) in - let[@warning "-8"] (RET.P pt) = p_pt in + let@ p_pt = WReq.welltyped loc (P pt) in + let[@warning "-8"] (Req.P pt) = p_pt in return (Pack_unpack (pack_unpack, pt)) | To_from_bytes (to_from, pt) -> - let@ pt = WRET.welltyped loc (P pt) in - let[@warning "-8"] (RET.P pt) = pt in + let@ pt = WReq.welltyped loc (P pt) in + let[@warning "-8"] (Req.P pt) = pt in return (To_from_bytes (to_from, pt)) | Have lc -> let@ lc = WLC.welltyped loc lc in @@ -1863,20 +1878,20 @@ module BaseTyping = struct let@ it = WIT.infer it in warn_when_not_quantifier_bt "extract" - (IT.loc it) - (IT.bt it) + (IT.get_loc it) + (IT.get_bt it) (Some (IndexTerms.pp it)); return (Extract (attrs, to_extract, it)) | Unfold (f, its) -> let@ def = get_logical_function_def loc f in - if LogicalFunctions.is_recursive def then + if Definition.Function.is_recursive def then () else Pp.warn loc (Pp.item "unfold of function not marked [rec] (no effect)" (Sym.pp f)); let@ () = ensure_same_argument_number loc - `General + `Other (List.length its) ~expect:(List.length def.args) in @@ -1888,7 +1903,7 @@ module BaseTyping = struct let wrong_number_arguments () = let has = List.length its in let expect = AT.count_computational lemma_typ in - fail (fun _ -> { loc; msg = Number_arguments { has; expect } }) + fail { loc; msg = Number_arguments { type_ = `Other; has; expect } } in let rec check_args lemma_typ its = match (lemma_typ, its) with @@ -1937,9 +1952,7 @@ module BaseTyping = struct let rec infer_expr : 'TY. label_context -> 'TY Mu.expr -> BT.t Mu.expr m = fun label_context e -> let open Mu in - Pp.debug - 22 - (lazy (Pp.item "WellTyped.BaseTyping.infer_expr" (Pp_mucore_ast.pp_expr e))); + Pp.debug 22 (lazy (Pp.item __FUNCTION__ (Pp_mucore_ast.pp_expr e))); let (Expr (loc, annots, _, e_)) = e in match integer_annot annots with | Some ity when !use_ity -> @@ -2064,12 +2077,12 @@ module BaseTyping = struct assert (not is_variadic); return (snd ret_v_ct, List.map fst arg_r_cts) | _ -> - fail (fun _ -> + fail { loc; msg = Generic (Pp.item "not a function pointer at call-site" (Sctypes.pp act.ct)) - }) + } in let@ f_pe = check_pexpr (Loc ()) f_pe in (* TODO: we'd have to check the arguments against the function type, but we @@ -2117,17 +2130,15 @@ module BaseTyping = struct | Erun (l, pes) -> (* copying from check.ml *) let@ lt, _lkind = - match SymMap.find_opt l label_context with - | None -> - fail (fun _ -> - { loc; msg = Generic (!^"undefined code label" ^/^ Sym.pp l) }) + match Sym.Map.find_opt l label_context with + | None -> fail { loc; msg = Generic (!^"undefined code label" ^/^ Sym.pp l) } | Some (lt, lkind, _) -> return (lt, lkind) in let@ pes = let wrong_number_arguments () = let has = List.length pes in let expect = AT.count_computational lt in - fail (fun _ -> { loc; msg = Number_arguments { has; expect } }) + fail { loc; msg = Number_arguments { type_ = `Other; has; expect } } in let rec check_args lt pes = match (lt, pes) with @@ -2175,16 +2186,14 @@ module BaseTyping = struct end module WLabel = struct - open Mu - let typ l = WArgs.typ (fun _body -> False.False) l - - let welltyped (loc : Loc.t) (lt : _ expr arguments) : _ expr arguments m = - WArgs.welltyped (fun _loc body -> return body) "loop/label" loc lt end module WProc = struct - open Mu + module AT = ArgumentTypes + module LAT = LogicalArgumentTypes + module Mu = Mucore + open Mucore let label_context function_rt label_defs = Pmap.fold @@ -2193,51 +2202,34 @@ module WProc = struct match def with | Return loc -> (AT.of_rt function_rt (LAT.I False.False), CF.Annot.LAreturn, loc) - | Label (loc, label_args_and_body, annots, _parsed_spec) -> + | Label (loc, label_args_and_body, annots, _parsed_spec, _loop_condition_loc) -> let lt = WLabel.typ label_args_and_body in let kind = Option.get (CF.Annot.get_label_annot annots) in (lt, kind, loc) in (*debug 6 (lazy (!^"label type within function" ^^^ Sym.pp fsym)); debug 6 (lazy (CF.Pp_ast.pp_doc_tree (AT.dtree False.dtree lt)));*) - SymMap.add sym (lt, kind, loc) label_context) + Sym.Map.add sym (lt, kind, loc) label_context) label_defs - SymMap.empty + Sym.Map.empty let typ p = WArgs.typ (fun (_body, _labels, rt) -> rt) p let welltyped : Loc.t -> _ Mu.args_and_body -> _ Mu.args_and_body m = fun (loc : Loc.t) (at : 'TY1 Mu.args_and_body) -> - Pp.(debug 6 (lazy !^__FUNCTION__)); WArgs.welltyped (fun loc (body, labels, rt) -> - let@ rt = pure_and_no_initial_resources loc (WRT.welltyped loc rt) in - let@ labels = - PmapM.mapM - (fun _sym def -> - match def with - | Return loc -> return (Return loc) - | Label (loc, label_args_and_body, annots, parsed_spec) -> - let@ label_args_and_body = - pure_and_no_initial_resources - loc - (WLabel.welltyped loc label_args_and_body) - in - return (Label (loc, label_args_and_body, annots, parsed_spec))) - labels - Sym.compare - in + let@ rt = pure (WRT.welltyped loc rt) in let label_context = label_context rt labels in let@ labels = PmapM.mapM (fun _sym def -> match def with | Return loc -> return (Return loc) - | Label (loc, label_args_and_body, annots, parsed_spec) -> + | Label (loc, label_args_and_body, annots, parsed_spec, loop_info) -> let@ label_args_and_body = - pure_and_no_initial_resources - loc + pure (WArgs.welltyped (fun _loc label_body -> BaseTyping.check_expr label_context Unit label_body) @@ -2245,7 +2237,7 @@ module WProc = struct loc label_args_and_body) in - return (Label (loc, label_args_and_body, annots, parsed_spec))) + return (Label (loc, label_args_and_body, annots, parsed_spec, loop_info))) labels Sym.compare in @@ -2257,18 +2249,18 @@ module WProc = struct end module WRPD = struct - open ResourcePredicates + module Def = Definition - let welltyped { loc; pointer; iargs; oarg_bt; clauses } = + let welltyped Def.Predicate.{ loc; pointer; iargs; oarg_bt; clauses } = (* no need to alpha-rename, because context.ml ensures there's no name clashes *) pure (let@ () = add_l pointer BT.(Loc ()) (loc, lazy (Pp.string "ptr-var")) in let@ iargs = ListM.mapM - (fun (s, ls) -> - let@ ls = WLS.is_ls loc ls in - let@ () = add_l s ls (loc, lazy (Pp.string "input-var")) in - return (s, ls)) + (fun (s, bt) -> + let@ bt = WBT.is_bt loc bt in + let@ () = add_l s bt (loc, lazy (Pp.string "input-var")) in + return (s, bt)) iargs in let@ oarg_bt = WBT.is_bt loc oarg_bt in @@ -2278,16 +2270,10 @@ module WRPD = struct | Some clauses -> let@ clauses = ListM.fold_leftM - (fun acc { loc; guard; packing_ft } -> + (fun acc Def.Clause.{ loc; guard; packing_ft } -> let@ guard = WIT.check loc BT.Bool guard in - let here = Locations.other __FUNCTION__ in - let negated_guards = - List.map (fun clause -> IT.not_ clause.guard here) acc - in pure - (let@ () = add_c loc (LC.t_ guard) in - let@ () = add_c loc (LC.t_ (IT.and_ negated_guards here)) in - let@ packing_ft = + (let@ packing_ft = WLAT.welltyped (fun loc it -> WIT.check loc oarg_bt it) IT.pp @@ -2295,34 +2281,32 @@ module WRPD = struct loc packing_ft in - return (acc @ [ { loc; guard; packing_ft } ]))) + return (acc @ [ Def.Clause.{ loc; guard; packing_ft } ]))) [] clauses in return (Some clauses) in - return { loc; pointer; iargs; oarg_bt; clauses }) + return Def.Predicate.{ loc; pointer; iargs; oarg_bt; clauses }) end module WLFD = struct - open LogicalFunctions + open Definition.Function - let welltyped - ({ loc; args; return_bt; emit_coq; definition } : LogicalFunctions.definition) - = + let welltyped ({ loc; args; return_bt; emit_coq; body } : Definition.Function.t) = (* no need to alpha-rename, because context.ml ensures there's no name clashes *) pure (let@ args = ListM.mapM - (fun (s, ls) -> - let@ ls = WLS.is_ls loc ls in - let@ () = add_l s ls (loc, lazy (Pp.string "arg-var")) in - return (s, ls)) + (fun (s, bt) -> + let@ bt = WBT.is_bt loc bt in + let@ () = add_l s bt (loc, lazy (Pp.string "arg-var")) in + return (s, bt)) args in let@ return_bt = WBT.is_bt loc return_bt in - let@ definition = - match definition with + let@ body = + match body with | Def body -> let@ body = WIT.check loc return_bt body in return (Def body) @@ -2331,21 +2315,21 @@ module WLFD = struct return (Rec_Def body) | Uninterp -> return Uninterp in - return { loc; args; return_bt; emit_coq; definition }) + return { loc; args; return_bt; emit_coq; body }) end module WLemma = struct let welltyped loc _lemma_s lemma_typ = WAT.welltyped - (fun loc lrt -> pure_and_no_initial_resources loc (WLRT.welltyped loc lrt)) - LRT.pp + (fun loc lrt -> pure (WLRT.welltyped loc lrt)) + LogicalReturnTypes.pp "lemma" loc lemma_typ end module WDT = struct - open Mu + open Mucore let welltyped (dt_name, { loc; cases }) = let@ _ = @@ -2411,7 +2395,7 @@ module WDT = struct let@ () = ListM.iterM (fun scc -> - let scc_set = SymSet.of_list scc in + let scc_set = Sym.Set.of_list scc in ListM.iterM (fun dt -> let { loc; cases } = List.assoc Sym.equal dt datatypes in @@ -2420,11 +2404,11 @@ module WDT = struct ListM.iterM (fun (id, bt) -> let indirect_deps = - SymSet.of_list + Sym.Set.of_list (List.filter_map BT.is_datatype_bt (BT.contained bt)) in - let bad = SymSet.inter indirect_deps scc_set in - match SymSet.elements bad with + let bad = Sym.Set.inter indirect_deps scc_set in + match Sym.Set.elements bad with | [] -> return () | dt' :: _ -> let err = @@ -2440,7 +2424,7 @@ module WDT = struct ^/^ !^"Indirect recursion via map, set, record," ^^^ !^"or tuple types is not permitted." in - fail (fun _ -> { loc; msg = Generic err })) + fail { loc; msg = Generic err }) args) cases) scc) @@ -2448,3 +2432,136 @@ module WDT = struct in return sccs end + +let datatype = WDT.welltyped + +let datatype_recursion = WDT.check_recursion_ok + +let lemma = WLemma.welltyped + +let function_ = WLFD.welltyped + +let predicate = WRPD.welltyped + +let label_context = WProc.label_context + +let to_argument_type = WProc.typ + +let procedure = WProc.welltyped + +let integer_annot = BaseTyping.integer_annot + +let infer_expr = BaseTyping.infer_expr + +let check_expr = BaseTyping.check_expr + +let function_type = WFT.welltyped + +let logical_constraint = WLC.welltyped + +let oarg_bt_of_pred = WRS.oarg_bt_of_pred + +let default_quantifier_bt = quantifier_bt + +let infer_term = WIT.infer + +let check_term = WIT.check + +let check_ct = WCT.is_ct + +let ensure_same_argument_number = ensure_same_argument_number + +let ensure_bits_type = ensure_bits_type + +module type ErrorReader = sig + type 'a t + + val return : 'a -> 'a t + + val bind : 'a t -> ('a -> 'b t) -> 'b t + + val get_context : unit -> Context.t t + + val lift : ('a, error) Result.t -> 'a t +end + +module Lift (M : ErrorReader) : WellTyped_intf.S with type 'a t := 'a M.t = struct + let lift1 f x = + let ( let@ ) = M.bind in + let@ context = M.get_context () in + M.lift (Result.map fst (run context (f x))) + + + let lift2 f x y = + let ( let@ ) = M.bind in + let@ context = M.get_context () in + M.lift (Result.map fst (f x y context)) + + + let lift3 f x y z = + let ( let@ ) = M.bind in + let@ context = M.get_context () in + M.lift (Result.map fst (f x y z context)) + + + let datatype x = lift1 datatype x + + let datatype_recursion = lift1 datatype_recursion + + let lemma x y z = lift3 lemma x y z + + let function_ = lift1 function_ + + let predicate = lift1 predicate + + let label_context = label_context + + let to_argument_type = to_argument_type + + let procedure x y = lift2 procedure x y + + let integer_annot = integer_annot + + let infer_expr x y = lift2 infer_expr x y + + let check_expr x y z = lift3 check_expr x y z + + let function_type = lift3 function_type + + let logical_constraint = lift2 logical_constraint + + let oarg_bt_of_pred = lift2 oarg_bt_of_pred + + let default_quantifier_bt = default_quantifier_bt + + let infer_term x = lift1 infer_term x + + let check_term x y z = lift3 check_term x y z + + let check_ct = lift2 check_ct + + let ensure_same_argument_number loc type_ n ~expect = + let ( let@ ) = M.bind in + let@ context = M.get_context () in + M.lift + (Result.map fst (run context (ensure_same_argument_number loc type_ n ~expect))) + + + (** TODO This should be removed, but there is a discrepancy between WellTyped + and Check for base typing for bounded_binops. *) + let ensure_base_type loc ~expect has = + (* if not (BT.equal expect has) then *) + (* failwith ("has: " ^ Pp.plain (BT.pp has) ^ ", expect: " ^ Pp.plain (BT.pp expect)); *) + (* M.return () *) + let ( let@ ) = M.bind in + let@ context = M.get_context () in + M.lift (Result.map fst (run context (ensure_base_type loc has ~expect))) + + + (** TODO If this crashes, figure out why WellTyped did not catch it earlier. + If it doesn't, then just delete it *) + let ensure_bits_type = + (* assert (match bt with BT.Bits _ -> true | _ -> false); *) + (* M.return () *) + lift2 ensure_bits_type +end diff --git a/backend/cn/lib/wellTyped.mli b/backend/cn/lib/wellTyped.mli new file mode 100644 index 000000000..d2e5ac199 --- /dev/null +++ b/backend/cn/lib/wellTyped.mli @@ -0,0 +1,49 @@ +val use_ity : bool ref + +type message = + | Global of Global.error + | Mismatch of + { has : Pp.document; + expect : Pp.document + } + | Generic of Pp.document + | Illtyped_it of + { it : Pp.document; + has : Pp.document; + expected : string; + reason : string + } + | Number_arguments of + { type_ : [ `Other | `Input | `Output ]; + has : int; + expect : int + } + | Missing_member of Id.t + | NIA of + { it : IndexTerms.t; + hint : string + } + | Empty_pattern + | Redundant_pattern of Pp.document + | Unknown_variable of Sym.t + +type error = + { loc : Locations.t; + msg : message + } + +include WellTyped_intf.S + +module type ErrorReader = sig + type 'a t + + val return : 'a -> 'a t + + val bind : 'a t -> ('a -> 'b t) -> 'b t + + val get_context : unit -> Context.t t + + val lift : ('a, error) Result.t -> 'a t +end + +module Lift : functor (M : ErrorReader) -> WellTyped_intf.S with type 'a t := 'a M.t diff --git a/backend/cn/lib/wellTyped_intf.ml b/backend/cn/lib/wellTyped_intf.ml new file mode 100644 index 000000000..d3e179f32 --- /dev/null +++ b/backend/cn/lib/wellTyped_intf.ml @@ -0,0 +1,73 @@ +module type S = sig + type 'a t + + val ensure_bits_type : Locations.t -> BaseTypes.t -> unit t + + val ensure_base_type : Locations.t -> expect:BaseTypes.t -> BaseTypes.t -> unit t + + val ensure_same_argument_number + : Locations.t -> + [ `Other | `Input | `Output ] -> + int -> + expect:int -> + unit t + + val check_ct : Locations.t -> Sctypes.ctype -> unit t + + val infer_term : 'bt IndexTerms.annot -> IndexTerms.t t + + val check_term : Locations.t -> BaseTypes.t -> 'bt IndexTerms.annot -> IndexTerms.t t + + val default_quantifier_bt : BaseTypes.t + + val oarg_bt_of_pred : Locations.t -> Request.name -> BaseTypes.t t + + val logical_constraint : Locations.t -> LogicalConstraints.t -> LogicalConstraints.t t + + val function_type + : string -> + Locations.t -> + ReturnTypes.t ArgumentTypes.t -> + ReturnTypes.t ArgumentTypes.t t + + val integer_annot + : Cerb_frontend.Annot.annot list -> + Cerb_frontend.IntegerType.integerType option + + val infer_expr + : (ArgumentTypes.lt * Where.label * Locations.t) Sym.Map.t -> + 'TY Mucore.expr -> + BaseTypes.t Mucore.expr t + + val check_expr + : (ArgumentTypes.lt * Where.label * Locations.t) Sym.Map.t -> + BaseTypes.t -> + 'TY Mucore.expr -> + BaseTypes.t Mucore.expr t + + val procedure + : Locations.t -> + 'TY1 Mucore.args_and_body -> + BaseTypes.t Mucore.args_and_body t + + val label_context + : ReturnTypes.t -> + (Sym.Map.key, 'a Mucore.label_def) Pmap.map -> + (False.t ArgumentTypes.t * Cerb_frontend.Annot.label_annot * Locations.t) Sym.Map.t + + val to_argument_type : ('a * 'b * 'c) Mucore.arguments -> 'c ArgumentTypes.t + + val predicate : Definition.Predicate.t -> Definition.Predicate.t t + + val function_ : Definition.Function.t -> Definition.Function.t t + + val lemma + : Locations.t -> + 'a -> + LogicalReturnTypes.t ArgumentTypes.t -> + LogicalReturnTypes.t ArgumentTypes.t t + + val datatype : 'a * Mucore.datatype -> ('a * Mucore.datatype) t + + val datatype_recursion : (Sym.t * Mucore.datatype) list -> Sym.t list list t +end diff --git a/cerberus-cheri.opam b/cerberus-cheri.opam index ef5093354..301ed6044 100644 --- a/cerberus-cheri.opam +++ b/cerberus-cheri.opam @@ -35,7 +35,7 @@ depends: [ "ounit2" "ppx_deriving" "zarith" - "coq" {>= "8.18.0"} + "coq" {= "8.18.0"} "coq-bbv" {>= "1.3" & <= "1.4"} "coq-sail-stdpp" "coq-ext-lib" diff --git a/cn.opam b/cn.opam index 110108787..65b39174e 100644 --- a/cn.opam +++ b/cn.opam @@ -2,13 +2,25 @@ opam-version: "2.0" synopsis: "The CN type system" description: "The CN type system" maintainer: ["Christopher Pulte "] +authors: [ + "Christopher Pulte" + "Thomas Sewell" + "Dhruv Makwana" + "Rini Banerjee" + "Zain K Aamer" + "Kayvan Memarian" +] +homepage: "https://rems-project.github.io/cn-tutorial" +bug-reports: "https://github.com/rems-project/cerberus/issues" depends: [ "cerberus-lib" "monomorphic" "ocaml" {>= "4.14.0"} "ppx_deriving" + "ppx_deriving_yojson" {>= "3.8.0"} "cmdliner" "ocamlgraph" + "zarith" {>= "1.13"} ] build: [ ["dune" "subst"] {pinned} diff --git a/frontend/model/annot.lem b/frontend/model/annot.lem index fe7301d32..84993e78b 100644 --- a/frontend/model/annot.lem +++ b/frontend/model/annot.lem @@ -89,7 +89,14 @@ type identifier_item_kind = type identifier_env = map Symbol.identifier (maybe (identifier_item_kind * Symbol.sym)) -type loop_attributes = map loop_id (nat * attributes) (* nat is marker id *) +type loop_attribute = + <| marker_id : nat; + attributes : attributes; + loc_condition : Loc.t; + loc_loop : Loc.t; |> + +type loop_attributes = map loop_id loop_attribute +(*type loop_attributes = map loop_id (nat * attributes * Loc.t * Loc.t)*) (* nat is marker id, first loc is location of loop condition, second loc is location of whole loop *) val get_loc: list annot -> maybe Loc.t let rec get_loc annots = diff --git a/frontend/model/cabs_to_ail.lem b/frontend/model/cabs_to_ail.lem index f0cb2df2c..7cf36c554 100644 --- a/frontend/model/cabs_to_ail.lem +++ b/frontend/model/cabs_to_ail.lem @@ -601,7 +601,8 @@ let rec is_integer_constant_expression (AnnotatedExpression () _ loc expr_ as ex | AilEassert _ -> E.return false | AilEoffsetof _ _ -> - E.fail loc (Errors.Desugar_NotYetSupported "offsetof() in `integer constant expressions'") + (* STD §7.19#3 *) + E.return true | AilEstr _ -> E.return false (* @@ -833,7 +834,9 @@ let rec is_arithmetic_constant_expression is_lvalue ((AnnotatedExpression () _ l (* E.return true *) (* TODO: is_lvalue might be wrong depending on the type of e? *) is_arithmetic_constant_expression is_lvalue e - + | AilEoffsetof _ _ -> + (* STD §7.19#3 *) + E.return true | _ -> E.return false @@ -3716,7 +3719,7 @@ and desugar_statement_aux ctx (CabsStatement loc attrs stmt_) = E.return (d_e, d_s) end >>= fun (d_e, d_s) -> let loop_id = Symbol.fresh_int () in - E.record_loop_attribute loop_id attrs >>= fun () -> + E.record_loop_attribute loop_id attrs (Loc.locOf e) loc >>= fun () -> if has_continue s then (* while (E) S ==> while (E) { S; cont: ;} *) E.return begin @@ -3748,7 +3751,7 @@ and desugar_statement_aux ctx (CabsStatement loc attrs stmt_) = E.return (d_e, d_s) end >>= fun (d_e, d_s) -> let loop_id = Symbol.fresh_int () in - E.record_loop_attribute loop_id attrs >>= fun () -> + E.record_loop_attribute loop_id attrs (Loc.locOf e) loc >>= fun () -> if has_continue s then (* do S (E) ==> do { S; cont: ;} (E) *) E.return begin @@ -3779,7 +3782,7 @@ and desugar_statement_aux ctx (CabsStatement loc attrs stmt_) = desugar_init_declarator attrs isAtomic (specifs.alignment_specifiers <> []) base_qs base_ty specifs.storage_classes init ) idecltors >>= fun xs -> let loop_id = Symbol.fresh_int () in - E.record_loop_attribute loop_id attrs_outer >> + E.record_loop_attribute loop_id attrs_outer (match e2_opt with Just e2 -> Loc.locOf e2 | Nothing -> Loc.unknown end) loc >> (* for each [init_declarator] *) E.foldrM (fun opt (acc1, acc2) -> match opt with @@ -3876,7 +3879,7 @@ and desugar_statement_aux ctx (CabsStatement loc attrs stmt_) = E.register_label cont_ident >> E.resolve_label cont_ident >>= fun cont_sym -> let loop_id = Symbol.fresh_int () in - E.record_loop_attribute loop_id attrs >> + E.record_loop_attribute loop_id attrs (match e2_opt with Just e2 -> Loc.locOf e2 | Nothing -> Loc.unknown end) loc >> let ctx' = <| cont_ident_opt= Just cont_ident |> in diff --git a/frontend/model/cabs_to_ail_effect.lem b/frontend/model/cabs_to_ail_effect.lem index 71d9f0fb7..676b15dc3 100644 --- a/frontend/model/cabs_to_ail_effect.lem +++ b/frontend/model/cabs_to_ail_effect.lem @@ -1302,11 +1302,18 @@ let register_cn_datatype magic_loc ident loc mk_cases = -val record_loop_attribute: Annot.loop_id -> Annot.attributes -> desugM unit -let record_loop_attribute id attr = +val record_loop_attribute: Annot.loop_id -> Annot.attributes -> Loc.t -> Loc.t -> desugM unit +let record_loop_attribute id attr loc_condition loc_loop = record_marker () >>= fun marker_id -> get_inner >>= fun st -> - put_inner <|st with loop_attributes = (Map.insert id (marker_id, attr) st.loop_attributes) |> + let loop_attribute = + <| Annot.marker_id = marker_id; + Annot.attributes = attr; + Annot.loc_condition = loc_condition; + Annot.loc_loop = loc_loop; + |> + in + put_inner <|st with loop_attributes = (Map.insert id loop_attribute st.loop_attributes) |> val get_loop_attributes: unit -> desugM Annot.loop_attributes let get_loop_attributes () = diff --git a/frontend/model/translation.lem b/frontend/model/translation.lem index 3d2ad19e0..05c1b1e6b 100644 --- a/frontend/model/translation.lem +++ b/frontend/model/translation.lem @@ -2819,7 +2819,7 @@ end E.return begin C.Expr [Annot.Astd "§6.5.2.3#3, sentence 2"] ( C.Esseq e_wrp.E.sym_pat core_e ( -begin if Global.has_strict_pointer_arith () || Global.is_CHERI () (* || Global.is_PNVI () *) then +begin if Global.is_CHERI () then (Caux.mk_memop_e (Mem_common.PtrMemberShift tag_sym ident) [e_wrp.E.sym_pe]) else Caux.mk_pure_e (Caux.mk_member_shift_pe e_wrp.E.sym_pe tag_sym ident) diff --git a/parsers/c/c_lexer.mll b/parsers/c/c_lexer.mll index 173485bb1..eac9a3e82 100644 --- a/parsers/c/c_lexer.mll +++ b/parsers/c/c_lexer.mll @@ -93,14 +93,14 @@ let lexicon: (string, token) Hashtbl.t = (* BEGIN CN *) -type kw_kind = - | Production - | Experimental - | Unimplemented +type cn_keyword_kind = + | Production + | Experimental + | Unimplemented -let cn_keywords: (string * (kw_kind * Tokens.token)) list = [ +let cn_keywords: (string * (cn_keyword_kind * Tokens.token)) list = [ (* CN 'production' keywords: well-supported and suitable for general use *) - "good" , (Production, CN_GOOD); + "good" , (Production, CN_GOOD); "boolean" , (Production, CN_BOOL); "integer" , (Production, CN_INTEGER); "u8" , (Production, CN_BITS (`U,8)); @@ -150,7 +150,7 @@ let cn_keywords: (string * (kw_kind * Tokens.token)) list = [ (* CN 'experimental' keywords - functional in some cases but not recommended for general use *) - "cn_list" , (Experimental, CN_LIST); + "cn_list" , (Experimental, CN_LIST); "cn_tuple" , (Experimental, CN_TUPLE); "cn_set" , (Experimental, CN_SET); "cn_have" , (Experimental, CN_HAVE); @@ -164,28 +164,45 @@ let cn_keywords: (string * (kw_kind * Tokens.token)) list = [ "unpack" , (Unimplemented, CN_UNPACK); ] -let cn_kw_table = - let kw_table = Hashtbl.create 0 in - List.iter (fun (key, builder) -> Hashtbl.add kw_table key builder) cn_keywords; - kw_table -(* Attempt to lex a CN keyword. These may be: +(* This table is mutated during lexing to reduce the number of warnings + for experimental features. Unfortunately, this makes it so that the + behaviour of the lexer implicitly changes across multiple calls + to [create_lexer]. + + In some sense, this is fine, since Cerberus/CN only processes one + translation unit per invocation from the command line, and we would + likely want warnings to only occur once per invocation. + + However, if this were to change, and especially if this were to be + made concurrent, this would need to be revisited. + + It is possible to thread the seen experimental tokens back to the caller for + them to decide; it is also ugly. *) +let cn_keywords = + let table = Hashtbl.create 0 in + List.iter (fun (key, builder) -> Hashtbl.add table key builder) cn_keywords; + table + +(* Attempt to lex a CN keyword. These may be: * 'production' - well-supported and suitable for general use - * 'experimental' - functional in some cases but not recommended for general use - * 'unimplemented' - non-functional, but the keyword is reserved + * 'experimental' - functional in some cases but not recommended for general use + * 'unimplemented' - non-functional, but the keyword is reserved May raise `Not_found`, indicating `id` is not a recognized CN keyword. *) -let cn_lex_keyword id start_pos end_pos = +let cn_lex_keyword id start_pos end_pos = (* Try to lex CN production keywords *) - match Hashtbl.find cn_kw_table id with - | (Production, kw) -> kw - | (Experimental, kw) -> - prerr_endline + match Hashtbl.find cn_keywords id with + | (Production, kw) -> kw + | (Experimental, kw) -> + (* Only want to warn once _per CN/Cerberus invocation_ *) + Hashtbl.replace cn_keywords id (Production, kw); + prerr_endline (Pp_errors.make_message Cerb_location.(region (start_pos, end_pos) NoCursor) Errors.(CPARSER (Errors.Cparser_experimental_keyword id)) Warning); - kw + kw | (Unimplemented, _) -> raise (Error (Errors.Cparser_unimplemented_keyword id)) (* END CN *) @@ -588,10 +605,10 @@ and initial flags = parse | ['A'-'Z']['0'-'9' 'A'-'Z' 'a'-'z' '_']* as id { if flags.inside_cn then - try - cn_lex_keyword id lexbuf.lex_start_p lexbuf.lex_curr_p + try + cn_lex_keyword id lexbuf.lex_start_p lexbuf.lex_curr_p with Not_found -> - UNAME id + UNAME id else UNAME id } @@ -601,10 +618,10 @@ and initial flags = parse Hashtbl.find lexicon id with Not_found -> if flags.inside_cn then - try - cn_lex_keyword id lexbuf.lex_start_p lexbuf.lex_curr_p + try + cn_lex_keyword id lexbuf.lex_start_p lexbuf.lex_curr_p with Not_found -> - LNAME id + LNAME id else LNAME id } @@ -627,7 +644,7 @@ let create_lexer ~(inside_cn:bool) : [ `LEXER of lexbuf -> token ] = match !lexer_state with | LSRegular -> let at_magic_comments = Switches.(has_switch SW_at_magic_comments) in - let magic_comment_char = + let magic_comment_char = if Switches.(has_switch SW_magic_comment_char_dollar) then '$' else '@' diff --git a/runtime/libcn/dune b/runtime/libcn/dune index 6f31560f0..3b2076aa3 100644 --- a/runtime/libcn/dune +++ b/runtime/libcn/dune @@ -24,6 +24,7 @@ uniform.o urn.o rand.o + size.o test.o)))) (install @@ -38,6 +39,7 @@ (include/cn-testing/uniform.h as runtime/include/cn-testing/uniform.h) (include/cn-testing/urn.h as runtime/include/cn-testing/urn.h) (include/cn-testing/rand.h as runtime/include/cn-testing/rand.h) + (include/cn-testing/size.h as runtime/include/cn-testing/size.h) (include/cn-testing/dsl.h as runtime/include/cn-testing/dsl.h) (include/cn-testing/result.h as runtime/include/cn-testing/result.h) (include/cn-testing/test.h as runtime/include/cn-testing/test.h) diff --git a/runtime/libcn/include/cn-executable/utils.h b/runtime/libcn/include/cn-executable/utils.h index 4c3aeac61..80b228b25 100644 --- a/runtime/libcn/include/cn-executable/utils.h +++ b/runtime/libcn/include/cn-executable/utils.h @@ -138,9 +138,18 @@ void cn_free_sized(void*, size_t len); void cn_print_nr_u64(int i, unsigned long u) ; void cn_print_u64(const char *str, unsigned long u) ; -/* cn_exit callbacks */ -void set_cn_exit_cb(void (*callback)(void)); -void reset_cn_exit_cb(void); +/* cn_failure callbacks */ +enum cn_failure_mode { + CN_FAILURE_ASSERT = 1, + CN_FAILURE_CHECK_OWNERSHIP, + CN_FAILURE_OWNERSHIP_LEAK, + CN_FAILURE_ALLOC +}; + +typedef void (*cn_failure_callback)(enum cn_failure_mode); +void set_cn_failure_cb(cn_failure_callback callback); +void reset_cn_failure_cb(void); +void cn_failure(enum cn_failure_mode mode); /* Conversion functions */ @@ -524,7 +533,7 @@ void ownership_ghost_state_remove(signed long* address_key); void cn_get_ownership(uintptr_t generic_c_ptr, size_t size); void cn_put_ownership(uintptr_t generic_c_ptr, size_t size); void cn_assume_ownership(void *generic_c_ptr, unsigned long size, char *fun); -void cn_check_ownership(enum OWNERSHIP owned_enum, uintptr_t generic_c_ptr, size_t size); +void cn_get_or_put_ownership(enum OWNERSHIP owned_enum, uintptr_t generic_c_ptr, size_t size); /* C ownership checking */ void c_add_to_ghost_state(uintptr_t ptr_to_local, size_t size, signed long stack_depth); diff --git a/runtime/libcn/include/cn-testing/alloc.h b/runtime/libcn/include/cn-testing/alloc.h index ec15f57b6..25cd2611e 100644 --- a/runtime/libcn/include/cn-testing/alloc.h +++ b/runtime/libcn/include/cn-testing/alloc.h @@ -9,12 +9,15 @@ extern "C" { #endif + uint8_t get_null_in_every(void); void set_null_in_every(uint8_t n); - void cn_gen_alloc_reset(void); + int is_sized_null(void); + void set_sized_null(void); + void unset_sized_null(void); + void cn_gen_alloc_reset(void); void* cn_gen_alloc_save(void); - void cn_gen_alloc_restore(void* ptr); void cn_gen_ownership_reset(void); @@ -31,7 +34,7 @@ extern "C" { void cn_gen_ownership_update(void* p, size_t sz); - int cn_gen_ownership_check(cn_pointer* p, size_t sz); + int cn_gen_ownership_check(void* p, size_t sz); #ifdef __cplusplus } diff --git a/runtime/libcn/include/cn-testing/backtrack.h b/runtime/libcn/include/cn-testing/backtrack.h index 1dcbf0e1c..5185ce4f9 100644 --- a/runtime/libcn/include/cn-testing/backtrack.h +++ b/runtime/libcn/include/cn-testing/backtrack.h @@ -2,11 +2,13 @@ #define CN_GEN_BACKTRACK_H #include +#include enum cn_gen_backtrack_request { CN_GEN_BACKTRACK_NONE, CN_GEN_BACKTRACK_ASSERT, - CN_GEN_BACKTRACK_ALLOC + CN_GEN_BACKTRACK_ALLOC, + CN_GEN_BACKTRACK_DEPTH }; enum cn_gen_backtrack_request cn_gen_backtrack_type(void); @@ -21,6 +23,8 @@ void cn_gen_backtrack_relevant_add_many(char* toAdd[]); int cn_gen_backtrack_relevant_contains(char* varname); +void cn_gen_backtrack_depth_exceeded(); + /** * @brief Remaps a relevant variable * diff --git a/runtime/libcn/include/cn-testing/dsl.h b/runtime/libcn/include/cn-testing/dsl.h index e8c29acf5..f6ee72a49 100644 --- a/runtime/libcn/include/cn-testing/dsl.h +++ b/runtime/libcn/include/cn-testing/dsl.h @@ -7,13 +7,55 @@ #include "backtrack.h" -#define CN_GEN_INIT() \ +#define CN_GEN_INIT() CN_GEN_INIT_SIZED(cn_gen_get_max_size()) + +#define CN_GEN_INIT_SIZED(size) \ + if (cn_gen_get_input_timeout() != 0 \ + && cn_gen_get_milliseconds() - cn_gen_get_input_timer() \ + > cn_gen_get_input_timeout()) { \ + cn_gen_backtrack_assert_failure(); \ + goto cn_label_bennet_backtrack; \ + } \ if (0) { \ cn_label_bennet_backtrack: \ + cn_gen_decrement_depth(); \ return NULL; \ + } \ + cn_gen_increment_depth(); \ + if (size <= 0 || cn_gen_depth() == cn_gen_max_depth()) { \ + if (cn_gen_get_depth_failures_allowed() != UINT16_MAX) { \ + static int backtracks; \ + backtracks++; \ + if (backtracks >= cn_gen_get_depth_failures_allowed()) { \ + cn_gen_backtrack_assert_failure(); \ + goto cn_label_bennet_backtrack; \ + } \ + } \ + cn_gen_backtrack_depth_exceeded(); \ + goto cn_label_bennet_backtrack; \ } -#define CN_GEN_UNIFORM(ty, sz) cn_gen_uniform_##ty(sz) +#define CN_GEN_UNIFORM(ty) cn_gen_uniform_##ty(cn_gen_get_size()) + +#define CN_GEN_ALLOC(sz) CN_GEN_ALLOC_SIZED(sz, cn_gen_get_size()) + +#define CN_GEN_ALLOC_SIZED(sz, gen_size) \ + ({ \ + cn_pointer *ptr; \ + uint8_t null_in_every = get_null_in_every(); \ + if (is_sized_null()) { \ + set_null_in_every(gen_size); \ + } \ + if (cn_gen_backtrack_type() != CN_GEN_BACKTRACK_ALLOC && gen_size <= 2) { \ + ptr = convert_to_cn_pointer(NULL); \ + } else { \ + ptr = cn_gen_alloc(sz); \ + } \ + if (is_sized_null()) { \ + set_null_in_every(null_in_every); \ + } \ + ptr; \ + }) #define CN_GEN_LT_(ty, max) cn_gen_lt_##ty(max) @@ -38,18 +80,25 @@ cn_gen_backtrack_relevant_remap_many(from, to); \ } -#define CN_GEN_ASSIGN(p, offset, addr_ty, value, tmp, gen_name, last_var, ...) \ - if (convert_from_cn_pointer(p) == 0) { \ - cn_gen_backtrack_assert_failure(); \ - cn_gen_backtrack_relevant_add((char*)#p); \ +#define CN_GEN_CALL_PATH_VARS(...) \ + if (cn_gen_backtrack_type() == CN_GEN_BACKTRACK_DEPTH) { \ + char* toAdd[] = { __VA_ARGS__, NULL }; \ + cn_gen_backtrack_relevant_add_many(toAdd); \ + } + +#define CN_GEN_ASSIGN(pointer, addr, addr_ty, value, tmp, gen_name, last_var, ...) \ + if (convert_from_cn_pointer(pointer) == 0) { \ + cn_gen_backtrack_relevant_add((char*)#pointer); \ + cn_gen_backtrack_alloc_set(8); \ goto cn_label_##last_var##_backtrack; \ } \ - void *tmp##_ptr = convert_from_cn_pointer(cn_pointer_add_cn_bits_u64(p, offset)); \ + void* tmp##_ptr = convert_from_cn_pointer(addr); \ if (!cn_gen_alloc_check(tmp##_ptr, sizeof(addr_ty))) { \ - cn_gen_backtrack_relevant_add((char*)#p); \ - cn_bits_u64* tmp##_size = cn_bits_u64_add( \ - offset, \ - convert_to_cn_bits_u64(sizeof(addr_ty))); \ + cn_gen_backtrack_relevant_add((char*)#pointer); \ + cn_bits_u64* tmp##_size = convert_to_cn_bits_u64( \ + (uintptr_t)tmp##_ptr \ + + sizeof(addr_ty) \ + - (uintptr_t)convert_from_cn_pointer(pointer)); \ cn_gen_backtrack_alloc_set(convert_from_cn_bits_u64(tmp##_size)); \ goto cn_label_##last_var##_backtrack; \ } \ @@ -64,15 +113,15 @@ #define CN_GEN_LET_BEGIN(backtracks, var) \ int var##_backtracks = backtracks; \ + alloc_checkpoint var##_checkpoint = alloc_save_checkpoint(); \ + void *var##_alloc_checkpoint = cn_gen_alloc_save(); \ + void *var##_ownership_checkpoint = cn_gen_ownership_save(); \ cn_label_##var##_gen: \ ; \ - alloc_checkpoint var##_checkpoint = alloc_save_checkpoint(); \ - void *var##_alloc_checkpoint = cn_gen_alloc_save(); \ - void *var##_ownership_checkpoint = cn_gen_ownership_save(); - #define CN_GEN_LET_BODY(ty, var, gen) \ - ty* var = gen; + ty* var = gen; \ + cn_gen_rand_checkpoint var##_rand_checkpoint = cn_gen_rand_save(); #define CN_GEN_LET_END(backtracks, var, last_var, ...) \ if (cn_gen_backtrack_type() != CN_GEN_BACKTRACK_NONE) { \ @@ -86,13 +135,17 @@ if (var##_backtracks <= 0) { \ goto cn_label_##last_var##_backtrack; \ } \ - if (cn_gen_backtrack_type() == CN_GEN_BACKTRACK_ASSERT) { \ + if (cn_gen_backtrack_type() == CN_GEN_BACKTRACK_ASSERT \ + || cn_gen_backtrack_type() == CN_GEN_BACKTRACK_DEPTH) { \ var##_backtracks--; \ cn_gen_backtrack_reset(); \ } else if (cn_gen_backtrack_type() == CN_GEN_BACKTRACK_ALLOC) { \ if (toAdd[0] != NULL) { \ goto cn_label_##last_var##_backtrack; \ } \ + if (cn_gen_backtrack_alloc_get() > 0) { \ + cn_gen_rand_restore(var##_rand_checkpoint); \ + } \ } \ goto cn_label_##var##_gen; \ } else { \ @@ -114,8 +167,10 @@ if (0) { \ cn_label_##i##_backtrack: \ ; \ - char *toAdd[] = { __VA_ARGS__ }; \ - cn_gen_backtrack_relevant_add_many(toAdd); \ + if (cn_gen_backtrack_relevant_contains((char*)#i)) { \ + char *toAdd[] = { __VA_ARGS__ }; \ + cn_gen_backtrack_relevant_add_many(toAdd); \ + } \ goto cn_label_##last_var##_backtrack; \ } \ \ @@ -143,19 +198,20 @@ tmp##_num_choices += 2; \ } \ tmp##_num_choices /= 2; \ - struct int_urn* tmp##_urn = urn_from_array(tmp##_choices, tmp##_num_choices); \ - cn_label_##tmp##_gen: \ - ; \ + struct cn_gen_int_urn* tmp##_urn = urn_from_array(tmp##_choices, tmp##_num_choices);\ alloc_checkpoint tmp##_checkpoint = alloc_save_checkpoint(); \ void *tmp##_alloc_checkpoint = cn_gen_alloc_save(); \ void *tmp##_ownership_checkpoint = cn_gen_ownership_save(); \ + cn_label_##tmp##_gen: \ + ; \ uint64_t tmp = urn_remove(tmp##_urn); \ if (0) { \ cn_label_##tmp##_backtrack: \ free_after(tmp##_checkpoint); \ cn_gen_alloc_restore(tmp##_alloc_checkpoint); \ cn_gen_ownership_restore(tmp##_ownership_checkpoint); \ - if (cn_gen_backtrack_type() == CN_GEN_BACKTRACK_ASSERT \ + if ((cn_gen_backtrack_type() == CN_GEN_BACKTRACK_ASSERT \ + || cn_gen_backtrack_type() == CN_GEN_BACKTRACK_DEPTH) \ && tmp##_urn->size != 0) { \ cn_gen_backtrack_reset(); \ goto cn_label_##tmp##_gen; \ @@ -179,5 +235,50 @@ } \ urn_free(tmp##_urn); \ +#define CN_GEN_SPLIT_BEGIN(tmp, size, ...) \ + int tmp##_backtracks = cn_gen_get_size_split_backtracks_allowed(); \ + alloc_checkpoint tmp##_checkpoint = alloc_save_checkpoint(); \ + void *tmp##_alloc_checkpoint = cn_gen_alloc_save(); \ + void *tmp##_ownership_checkpoint = cn_gen_ownership_save(); \ + cn_label_##tmp##_gen: \ + { \ + size_t* vars[] = { __VA_ARGS__ }; \ + int count = 0; \ + for (int i = 0; vars[i] != NULL; i++) { \ + count += 1; \ + } + +#define CN_GEN_SPLIT_END(tmp, size, last_var, ...) \ + if (count >= size) { \ + cn_gen_backtrack_depth_exceeded(); \ + char* toAdd[] = { __VA_ARGS__ }; \ + cn_gen_backtrack_relevant_add_many(toAdd); \ + goto cn_label_##last_var##_backtrack; \ + } \ + cn_gen_split(size - count - 1, vars, count); \ + for (int i = 0; i < count; i++) { \ + *(vars[i]) = *(vars[i]) + 1; \ + } \ + } \ + if (0) { \ + cn_label_##tmp##_backtrack: \ + free_after(tmp##_checkpoint); \ + cn_gen_alloc_restore(tmp##_alloc_checkpoint); \ + cn_gen_ownership_restore(tmp##_ownership_checkpoint); \ + if (cn_gen_backtrack_relevant_contains(#tmp)) { \ + char* toAdd[] = { __VA_ARGS__ }; \ + cn_gen_backtrack_relevant_add_many(toAdd); \ + if (tmp##_backtracks <= 0) { \ + goto cn_label_##last_var##_backtrack; \ + } \ + tmp##_backtracks--; \ + cn_gen_backtrack_reset(); \ + goto cn_label_##tmp##_gen; \ + } else { \ + goto cn_label_##last_var##_backtrack; \ + } \ + } + + #endif // CN_GEN_DSL_H diff --git a/runtime/libcn/include/cn-testing/prelude.h b/runtime/libcn/include/cn-testing/prelude.h index 870e9d9cf..77dbeea7d 100644 --- a/runtime/libcn/include/cn-testing/prelude.h +++ b/runtime/libcn/include/cn-testing/prelude.h @@ -7,6 +7,7 @@ #include #include #include +#include #include #include diff --git a/runtime/libcn/include/cn-testing/rand.h b/runtime/libcn/include/cn-testing/rand.h index c2e47ef30..a746488cb 100644 --- a/runtime/libcn/include/cn-testing/rand.h +++ b/runtime/libcn/include/cn-testing/rand.h @@ -8,9 +8,72 @@ extern "C" { #endif void cn_gen_srand(uint64_t seed); - uint64_t cn_gen_rand(void); + uint8_t cn_gen_uniform_u8(uint8_t); + uint16_t cn_gen_uniform_u16(uint16_t); + uint32_t cn_gen_uniform_u32(uint32_t); + uint64_t cn_gen_uniform_u64(uint64_t); + + int8_t cn_gen_uniform_i8(uint8_t); + int16_t cn_gen_uniform_i16(uint16_t); + int32_t cn_gen_uniform_i32(uint32_t); + int64_t cn_gen_uniform_i64(uint64_t); + + uint8_t cn_gen_range_u8(uint8_t, uint8_t); + uint16_t cn_gen_range_u16(uint16_t, uint16_t); + uint32_t cn_gen_range_u32(uint32_t, uint32_t); + uint64_t cn_gen_range_u64(uint64_t, uint64_t); + + int8_t cn_gen_range_i8(int8_t, int8_t); + int16_t cn_gen_range_i16(int16_t, int16_t); + int32_t cn_gen_range_i32(int32_t, int32_t); + int64_t cn_gen_range_i64(int64_t, int64_t); + + uint8_t cn_gen_lt_u8(uint8_t); + uint16_t cn_gen_lt_u16(uint16_t); + uint32_t cn_gen_lt_u32(uint32_t); + uint64_t cn_gen_lt_u64(uint64_t); + + int8_t cn_gen_lt_i8(int8_t); + int16_t cn_gen_lt_i16(int16_t); + int32_t cn_gen_lt_i32(int32_t); + int64_t cn_gen_lt_i64(int64_t); + + uint8_t cn_gen_ge_u8(uint8_t); + uint16_t cn_gen_ge_u16(uint16_t); + uint32_t cn_gen_ge_u32(uint32_t); + uint64_t cn_gen_ge_u64(uint64_t); + + int8_t cn_gen_ge_i8(int8_t); + int16_t cn_gen_ge_i16(int16_t); + int32_t cn_gen_ge_i32(int32_t); + int64_t cn_gen_ge_i64(int64_t); + + uint8_t cn_gen_mult_range_u8(uint8_t, uint8_t, uint8_t); + uint16_t cn_gen_mult_range_u16(uint16_t, uint16_t, uint16_t); + uint32_t cn_gen_mult_range_u32(uint32_t, uint32_t, uint32_t); + uint64_t cn_gen_mult_range_u64(uint64_t, uint64_t, uint64_t); + + int8_t cn_gen_mult_range_i8(int8_t, int8_t, int8_t); + int16_t cn_gen_mult_range_i16(int16_t, int16_t, int16_t); + int32_t cn_gen_mult_range_i32(int32_t, int32_t, int32_t); + int64_t cn_gen_mult_range_i64(int64_t, int64_t, int64_t); + + uint8_t cn_gen_mult_u8(uint8_t); + uint16_t cn_gen_mult_u16(uint16_t); + uint32_t cn_gen_mult_u32(uint32_t); + uint64_t cn_gen_mult_u64(uint64_t); + + int8_t cn_gen_mult_i8(int8_t); + int16_t cn_gen_mult_i16(int16_t); + int32_t cn_gen_mult_i32(int32_t); + int64_t cn_gen_mult_i64(int64_t); + + void cn_gen_shuffle(void* arr, size_t len, size_t size); + + void cn_gen_split(size_t n, size_t* arr[], size_t len); + uint64_t cn_gen_rand_retry(void); typedef void* cn_gen_rand_checkpoint; diff --git a/runtime/libcn/include/cn-testing/size.h b/runtime/libcn/include/cn-testing/size.h new file mode 100644 index 000000000..445e8b86e --- /dev/null +++ b/runtime/libcn/include/cn-testing/size.h @@ -0,0 +1,28 @@ +#include +#include + +size_t cn_gen_get_size(void); +void cn_gen_set_size(size_t sz); + +size_t cn_gen_get_max_size(void); +void cn_gen_set_max_size(size_t sz); + +uint16_t cn_gen_depth(); +uint16_t cn_gen_max_depth(); +void cn_gen_set_max_depth(uint16_t msd); +void cn_gen_increment_depth(); +void cn_gen_decrement_depth(); + +void cn_gen_set_depth_failures_allowed(uint16_t allowed); +uint16_t cn_gen_get_depth_failures_allowed(); + +void cn_gen_set_size_split_backtracks_allowed(uint16_t allowed); +uint16_t cn_gen_get_size_split_backtracks_allowed(); + +void cn_gen_set_input_timeout(uint8_t seconds); +uint8_t cn_gen_get_input_timeout(void); + +void cn_gen_set_input_timer(uint64_t time); +uint64_t cn_gen_get_input_timer(void); + +uint64_t cn_gen_get_milliseconds(void); diff --git a/runtime/libcn/include/cn-testing/test.h b/runtime/libcn/include/cn-testing/test.h index bb88dc5f1..81bb50923 100644 --- a/runtime/libcn/include/cn-testing/test.h +++ b/runtime/libcn/include/cn-testing/test.h @@ -3,50 +3,94 @@ #include #include +#include #include -typedef enum cn_test_result cn_test_case_fn(void); +enum cn_test_gen_progress { + CN_TEST_GEN_PROGRESS_NONE = 0, + CN_TEST_GEN_PROGRESS_FINAL = 1, + CN_TEST_GEN_PROGRESS_ALL = 2 +}; -void cn_register_test_case(char* suite, char* name, cn_test_case_fn* func); +typedef enum cn_test_result cn_test_case_fn(enum cn_test_gen_progress); -#define CN_UNIT_TEST_CASE(Name) \ - static jmp_buf buf_##Name; \ +void cn_register_test_case(const char* suite, const char* name, cn_test_case_fn* func); + +void print_test_info(const char* suite, const char* name, int tests, int discards); + + +#define CN_UNIT_TEST_CASE_NAME(FuncName) cn_test_const_##FuncName + +#define CN_UNIT_TEST_CASE(FuncName) \ + static jmp_buf buf_##FuncName; \ \ - void cn_test_##Name##_fail () { \ - longjmp(buf_##Name, 1); \ + void cn_test_const_##FuncName##_fail () { \ + longjmp(buf_##FuncName, 1); \ } \ \ - enum cn_test_result cn_test_##Name () { \ - if (setjmp(buf_##Name)) { \ + enum cn_test_result cn_test_const_##FuncName () { \ + if (setjmp(buf_##FuncName)) { \ return CN_TEST_FAIL; \ } \ - set_cn_exit_cb(&cn_test_##Name##_fail); \ + set_cn_failure_cb(&cn_test_const_##FuncName##_fail); \ \ CN_TEST_INIT(); \ - Name(); \ + FuncName(); \ \ return CN_TEST_PASS; \ } -#define CN_RANDOM_TEST_CASE_WITH_CUSTOM_INIT(Name, Samples, Init, ...) \ +#define CN_REGISTER_UNIT_TEST_CASE(Suite, FuncName) \ + cn_register_test_case( \ + #Suite, \ + #FuncName, \ + &CN_UNIT_TEST_CASE_NAME(FuncName)); + +#define CN_RANDOM_TEST_CASE_WITH_CUSTOM_INIT(Suite, Name, Samples, Init, ...) \ static jmp_buf buf_##Name; \ \ - void cn_test_##Name##_fail () { \ - longjmp(buf_##Name, 1); \ + void cn_test_gen_##Name##_fail (enum cn_failure_mode mode) { \ + longjmp(buf_##Name, mode); \ } \ \ - enum cn_test_result cn_test_##Name () { \ - if (setjmp(buf_##Name)) { \ - return CN_TEST_FAIL; \ - } \ - set_cn_exit_cb(&cn_test_##Name##_fail); \ - \ + enum cn_test_result cn_test_gen_##Name (enum cn_test_gen_progress progress_level) { \ cn_gen_rand_checkpoint checkpoint = cn_gen_rand_save(); \ - for (int i = 0; i < Samples; i++) { \ + int i = 0, d = 0; \ + set_cn_failure_cb(&cn_test_gen_##Name##_fail); \ + switch (setjmp(buf_##Name)) { \ + case CN_FAILURE_ASSERT: \ + case CN_FAILURE_CHECK_OWNERSHIP: \ + case CN_FAILURE_OWNERSHIP_LEAK: \ + if (progress_level == CN_TEST_GEN_PROGRESS_FINAL) { \ + print_test_info(#Suite, #Name, i, d); \ + } \ + return CN_TEST_FAIL; \ + case CN_FAILURE_ALLOC: \ + cn_gen_rand_replace(checkpoint); \ + d++; \ + break; \ + } \ + for (; i < Samples; i++) { \ + if (progress_level == CN_TEST_GEN_PROGRESS_ALL) { \ + printf("\r"); \ + print_test_info(#Suite, #Name, i, d); \ + } \ + if (d == 10 * Samples) { \ + if (progress_level == CN_TEST_GEN_PROGRESS_FINAL) { \ + print_test_info(#Suite, #Name, i, d); \ + } \ + return CN_TEST_GEN_FAIL; \ + } \ + size_t sz = cn_gen_uniform_cn_bits_u16(cn_gen_get_max_size())->val + 1; \ + cn_gen_set_size(sz); \ CN_TEST_INIT(); \ + cn_gen_set_input_timer(cn_gen_get_milliseconds()); \ struct cn_gen_##Name##_record *res = cn_gen_##Name(); \ if (cn_gen_backtrack_type() != CN_GEN_BACKTRACK_NONE) { \ - return CN_TEST_GEN_FAIL; \ + cn_gen_rand_replace(checkpoint); \ + i--; \ + d++; \ + continue; \ } \ assume_##Name(__VA_ARGS__); \ Init(res); \ @@ -54,16 +98,30 @@ void cn_register_test_case(char* suite, char* name, cn_test_case_fn* func); cn_gen_rand_replace(checkpoint); \ } \ \ + if (progress_level != CN_TEST_GEN_PROGRESS_NONE) { \ + if (progress_level == CN_TEST_GEN_PROGRESS_ALL) { \ + printf("\r"); \ + } \ + print_test_info(#Suite, #Name, i, d); \ + } \ return CN_TEST_PASS; \ } -#define CN_RANDOM_TEST_CASE_WITH_INIT(Name, Samples, ...) \ +#define CN_RANDOM_TEST_CASE_WITH_INIT(Suite, Name, Samples, ...) \ CN_RANDOM_TEST_CASE_WITH_CUSTOM_INIT( \ - Name, Samples, cn_test_##Name##_init, __VA_ARGS__) + Suite, Name, Samples, cn_test_gen_##Name##_init, __VA_ARGS__) + + +#define CN_RANDOM_TEST_CASE_NAME(FuncName) cn_test_gen_##FuncName +#define CN_RANDOM_TEST_CASE(Suite, Name, Samples, ...) \ + CN_RANDOM_TEST_CASE_WITH_CUSTOM_INIT(Suite, Name, Samples, , __VA_ARGS__) -#define CN_RANDOM_TEST_CASE(Name, Samples, ...) \ - CN_RANDOM_TEST_CASE_WITH_CUSTOM_INIT(Name, Samples, , __VA_ARGS__) +#define CN_REGISTER_RANDOM_TEST_CASE(Suite, FuncName) \ + cn_register_test_case( \ + #Suite, \ + #FuncName, \ + &CN_RANDOM_TEST_CASE_NAME(FuncName)); int cn_test_main(int argc, char* argv[]); @@ -76,13 +134,4 @@ int cn_test_main(int argc, char* argv[]); cn_gen_alloc_reset(); \ cn_gen_ownership_reset(); -#define CN_TEST_GENERATE(name) ({ \ - struct cn_gen_##name##_record* res = cn_gen_##name(); \ - if (cn_gen_backtrack_type() != CN_GEN_BACKTRACK_NONE) { \ - printf("generation failed\n"); \ - return 1; \ - } \ - res; \ -}) - #endif // CN_TEST_H diff --git a/runtime/libcn/include/cn-testing/urn.h b/runtime/libcn/include/cn-testing/urn.h index f0159587a..64495f17e 100644 --- a/runtime/libcn/include/cn-testing/urn.h +++ b/runtime/libcn/include/cn-testing/urn.h @@ -7,26 +7,26 @@ extern "C" { #endif - struct int_tree { + struct cn_gen_int_tree { uint64_t weight; uint64_t value; - struct int_tree* left; - struct int_tree* right; + struct cn_gen_int_tree* left; + struct cn_gen_int_tree* right; }; - struct int_urn { + struct cn_gen_int_urn { uint8_t size; - struct int_tree* tree; + struct cn_gen_int_tree* tree; }; - struct int_urn* urn_from_array(uint64_t elems[], uint8_t len); + struct cn_gen_int_urn* urn_from_array(uint64_t elems[], uint8_t len); - void urn_insert(struct int_urn* urn, uint64_t weight, uint64_t value); + void urn_insert(struct cn_gen_int_urn* urn, uint64_t weight, uint64_t value); - uint64_t urn_remove(struct int_urn* urn); + uint64_t urn_remove(struct cn_gen_int_urn* urn); - void urn_free(struct int_urn* urn); + void urn_free(struct cn_gen_int_urn* urn); #ifdef __cplusplus } diff --git a/runtime/libcn/libexec/cn-runtime-single-file.sh b/runtime/libcn/libexec/cn-runtime-single-file.sh index 1d33d3a37..cdf35555c 100755 --- a/runtime/libcn/libexec/cn-runtime-single-file.sh +++ b/runtime/libcn/libexec/cn-runtime-single-file.sh @@ -1,7 +1,7 @@ #!/bin/bash set -euo pipefail -o noclobber -USAGE="USAGE: $0 -h\n $0 [-ovq] FILE.c" +USAGE="USAGE: $0 -h\n $0 [-nvq] FILE.c" function echo_and_err() { printf "$1\n" @@ -9,16 +9,16 @@ function echo_and_err() { } QUIET="" -CHECK_OWNERSHIP="" +NO_CHECK_OWNERSHIP="" -while getopts "hoq" flag; do +while getopts "hnq" flag; do case "$flag" in h) printf "${USAGE}" exit 0 ;; - o) - CHECK_OWNERSHIP="--with-ownership-checking" + n) + NO_CHECK_OWNERSHIP="--without-ownership-checking" ;; q) QUIET=1 @@ -57,7 +57,7 @@ EXEC_DIR=$(mktemp -d -t 'cn-exec.XXXX') if cn instrument "${INPUT_FN}" \ --output-decorated="${INPUT_BASENAME}-exec.c" \ --output-decorated-dir="${EXEC_DIR}" \ - ${CHECK_OWNERSHIP}; then + ${NO_CHECK_OWNERSHIP}; then [ "${QUIET}" ] || echo "Generating C files from CN-annotated source." else echo_and_err "Failed to generate C files from CN-annotatated source." diff --git a/runtime/libcn/src/cn-executable/alloc.c b/runtime/libcn/src/cn-executable/alloc.c index 3ca5be534..81e01fe2d 100644 --- a/runtime/libcn/src/cn-executable/alloc.c +++ b/runtime/libcn/src/cn-executable/alloc.c @@ -3,6 +3,7 @@ #include #include +#include // #define foo(x)\ // [ x ] = #x @@ -44,8 +45,8 @@ void *alloc_(long nbytes, const char *str, int line) { // printf("Alloc called: %s:%d\n", str, line); void *res = curr; if ((char *) curr + nbytes - buf > MEM_SIZE) { - printf("Out of memory! %lu\n", count); - exit(1); + cn_failure(CN_FAILURE_ALLOC); + return NULL; } count++; curr += nbytes; diff --git a/runtime/libcn/src/cn-executable/utils.c b/runtime/libcn/src/cn-executable/utils.c index 7eec0c387..62125092d 100644 --- a/runtime/libcn/src/cn-executable/utils.c +++ b/runtime/libcn/src/cn-executable/utils.c @@ -27,18 +27,29 @@ enum cn_logging_level set_cn_logging_level(enum cn_logging_level new_level) { return old_level; } -void cn_exit_aux(void) { - exit(SIGABRT); +void cn_failure_default(enum cn_failure_mode mode) { + switch (mode) { + case CN_FAILURE_ALLOC: + printf("Out of memory!"); + case CN_FAILURE_ASSERT: + case CN_FAILURE_CHECK_OWNERSHIP: + case CN_FAILURE_OWNERSHIP_LEAK: + exit(SIGABRT); + } } -void static (*cn_exit)(void) = &cn_exit_aux; +static cn_failure_callback cn_failure_aux = &cn_failure_default; -void set_cn_exit_cb(void (*callback)(void)) { - cn_exit = callback; +void cn_failure(enum cn_failure_mode mode) { + cn_failure_aux(mode); } -void reset_cn_exit_cb(void) { - cn_exit = &cn_exit_aux; +void set_cn_failure_cb(cn_failure_callback callback) { + cn_failure_aux = callback; +} + +void reset_cn_failure_cb(void) { + cn_failure_aux = &cn_failure_default; } void print_error_msg_info(struct cn_error_message_info *info) { @@ -54,7 +65,7 @@ void print_error_msg_info(struct cn_error_message_info *info) { } else { cn_printf(CN_LOGGING_ERROR, "Internal error: no error_msg_info available."); - cn_exit_aux(); + exit(SIGABRT); } } @@ -74,7 +85,7 @@ void cn_assert(cn_bool *cn_b) { if (!(cn_b->val)) { print_error_msg_info(error_msg_info); cn_printf(CN_LOGGING_ERROR, "CN assertion failed."); - cn_exit(); + cn_failure(CN_FAILURE_ASSERT); } } @@ -161,7 +172,7 @@ void ghost_stack_depth_decr(void) { if (*depth > cn_stack_depth) { print_error_msg_info(error_msg_info); cn_printf(CN_LOGGING_ERROR, "Leak check failed, ownership leaked for pointer "FMT_PTR"\n", *key); - cn_exit(); + cn_failure(CN_FAILURE_OWNERSHIP_LEAK); // cn_printf(CN_LOGGING_INFO, FMT_PTR_2 " (%d),", *key, *depth); } } @@ -223,7 +234,7 @@ void cn_assume_ownership(void *generic_c_ptr, unsigned long size, char *fun) { } -void cn_check_ownership(enum OWNERSHIP owned_enum, uintptr_t generic_c_ptr, size_t size) { +void cn_get_or_put_ownership(enum OWNERSHIP owned_enum, uintptr_t generic_c_ptr, size_t size) { nr_owned_predicates++; switch (owned_enum) { @@ -277,7 +288,7 @@ void c_ownership_check(char *access_kind, uintptr_t generic_c_ptr, int offset, s cn_printf(CN_LOGGING_ERROR, " ==> "FMT_PTR"[%d] ("FMT_PTR") not owned at expected function call stack depth %ld\n", generic_c_ptr, i, (uintptr_t)((char*)generic_c_ptr + i), expected_stack_depth); cn_printf(CN_LOGGING_ERROR, " ==> (owned at stack depth: %d)\n", curr_depth); } - cn_exit(); + cn_failure(CN_FAILURE_CHECK_OWNERSHIP); } } // cn_printf(CN_LOGGING_INFO, "\n"); diff --git a/runtime/libcn/src/cn-testing/backtrack.c b/runtime/libcn/src/cn-testing/backtrack.c index a90794f69..4c4b7bd2c 100644 --- a/runtime/libcn/src/cn-testing/backtrack.c +++ b/runtime/libcn/src/cn-testing/backtrack.c @@ -19,14 +19,23 @@ static size_t more_alloc_needed = 0; void cn_gen_backtrack_reset(void) { type = CN_GEN_BACKTRACK_NONE; - to_retry = NULL; more_alloc_needed = 0; + + while (to_retry != NULL) { + void* tmp = to_retry->next; + free(to_retry); + to_retry = tmp; + } } void cn_gen_backtrack_assert_failure(void) { type = CN_GEN_BACKTRACK_ASSERT; } +void cn_gen_backtrack_depth_exceeded() { + type = CN_GEN_BACKTRACK_DEPTH; +} + void cn_gen_backtrack_relevant_add(char* varname) { struct name_list* new_node = (struct name_list*)malloc(sizeof(struct name_list)); *new_node = (struct name_list){ diff --git a/runtime/libcn/src/cn-testing/gen_alloc.c b/runtime/libcn/src/cn-testing/gen_alloc.c index e7577bc1b..789e91c38 100644 --- a/runtime/libcn/src/cn-testing/gen_alloc.c +++ b/runtime/libcn/src/cn-testing/gen_alloc.c @@ -57,30 +57,48 @@ static void update_ownership(void* ptr, size_t sz) { ownership_curr = (char*)ownership_curr + sizeof(struct pointer_data); } -static uint8_t null_in_every = 4; +static uint8_t null_in_every = 5; + +uint8_t get_null_in_every(void) { + return null_in_every; +} void set_null_in_every(uint8_t n) { null_in_every = n; } +static int sized_null = 0; + +int is_sized_null(void) { + return sized_null; +} + +void set_sized_null(void) { + sized_null = 1; +} + +void unset_sized_null(void) { + sized_null = 0; +} + cn_pointer* cn_gen_alloc(cn_bits_u64* sz) { uint64_t bytes = convert_from_cn_bits_u64(sz); if (cn_gen_backtrack_type() == CN_GEN_BACKTRACK_ALLOC) { bytes = cn_gen_backtrack_alloc_get(); cn_gen_backtrack_reset(); } - - if (bytes == 0) { - void* p; + else if (bytes == 0) { uint64_t rnd = convert_from_cn_bits_u8(cn_gen_uniform_cn_bits_u8(null_in_every)); if (rnd == 0) { - p = NULL; + bytes = 0; } else { - p = alloc(1); - update_alloc(p, 1); + bytes = 8; } - return convert_to_cn_pointer(p); + } + + if (bytes == 0) { + return convert_to_cn_pointer(NULL); } else { void* p = alloc(bytes); @@ -154,7 +172,7 @@ void cn_gen_ownership_update(void* p, size_t sz) { update_ownership(p, sz); } -int cn_gen_ownership_check(cn_pointer* p, size_t sz) { +int cn_gen_ownership_check(void* p, size_t sz) { if (ownership_curr == ownership_buf) { return 1; } diff --git a/runtime/libcn/src/cn-testing/rand.c b/runtime/libcn/src/cn-testing/rand.c index 85a8c711c..92f009c80 100644 --- a/runtime/libcn/src/cn-testing/rand.c +++ b/runtime/libcn/src/cn-testing/rand.c @@ -2,6 +2,7 @@ #include #include #include +#include #include @@ -94,6 +95,179 @@ uint64_t genrand(void) { // End of Mersenne twister // ///////////////////////////// +// Sized generation according to Lemire: https://doi.org/10.1145/3230636 +#define UNSIGNED_GEN(sm, lg) \ +uint##sm##_t cn_gen_uniform_u##sm(uint##sm##_t s) { \ + uint##sm##_t x = cn_gen_rand(); \ + if (s == 0) { \ + return x; \ + } \ + \ + uint##lg##_t m = (uint##lg##_t)x * (uint##lg##_t)s; \ + uint##sm##_t l = m; /* m % pow(2, sm) */ \ + if (l < s) { \ + uint##lg##_t t = (UINT##sm##_MAX - (s - 1)) % s; \ + while (l < t) { \ + x = cn_gen_rand(); \ + m = x * s; \ + l = m; /* m % pow(2, sm) */ \ + } \ + } \ + return m >> sm; \ +} + +UNSIGNED_GEN(8, 16); +UNSIGNED_GEN(16, 32); +UNSIGNED_GEN(32, 64); + +// OpenJDK 9 implementation, according to the definition in Lemire. +uint64_t cn_gen_uniform_u64(uint64_t s) { + uint64_t x = cn_gen_rand(); + if (s == 0) { + return x; + } + + uint64_t r = x % s; + while (x - r > UINT64_MAX - (s - 1)) { + x = cn_gen_rand(); + r = x % s; + } + return r; +} + +#define SIGNED_GEN(sm) \ +int##sm##_t cn_gen_uniform_i##sm(uint##sm##_t s) { \ + uint##sm##_t x = cn_gen_uniform_u##sm(s); \ + if (s == 0) { \ + return x; \ + } \ + uint##sm##_t offset = (s + 1) >> 2; \ + return x - offset; \ +} + +SIGNED_GEN(8); +SIGNED_GEN(16); +SIGNED_GEN(32); +SIGNED_GEN(64); + +#define RANGE_GEN(sm) \ +uint##sm##_t cn_gen_range_u##sm(uint##sm##_t min, uint##sm##_t max) { \ + uint##sm##_t x = cn_gen_uniform_u##sm(max - min); \ + return x + min; \ +} \ +int##sm##_t cn_gen_range_i##sm(int##sm##_t min, int##sm##_t max) { \ + return cn_gen_range_u##sm(min, max); \ +} + +RANGE_GEN(8); +RANGE_GEN(16); +RANGE_GEN(32); +RANGE_GEN(64); + +#define INEQ_GEN(sm)\ +uint##sm##_t cn_gen_lt_u##sm(uint##sm##_t max) { \ + return cn_gen_range_u##sm(0, max); \ +} \ +int##sm##_t cn_gen_lt_i##sm(int##sm##_t max) { \ + return cn_gen_range_i##sm(INT##sm##_MIN, max); \ +} \ +uint##sm##_t cn_gen_ge_u##sm(uint##sm##_t min) { \ + return cn_gen_range_u##sm(min, 0); \ +} \ +int##sm##_t cn_gen_ge_i##sm(int##sm##_t min) { \ + return cn_gen_range_i##sm(min, INT##sm##_MIN); \ +} + +INEQ_GEN(8); +INEQ_GEN(16); +INEQ_GEN(32); +INEQ_GEN(64); + +#define MULT_RANGE_GEN(sm) \ +uint##sm##_t cn_gen_mult_range_u##sm( \ + uint##sm##_t mul, \ + uint##sm##_t min, \ + uint##sm##_t max \ +) { \ + assert(mul != 0); \ + uint##sm##_t x = cn_gen_range_u##sm(min / mul, max / mul + (max % mul != 0)); \ + return x * mul; \ +} \ +int##sm##_t cn_gen_mult_range_i##sm( \ + int##sm##_t mul, \ + int##sm##_t min, \ + int##sm##_t max \ +) { \ + assert(mul != 0); \ + int##sm##_t x = cn_gen_range_i##sm(min / mul, max / mul + (max % mul != 0)); \ + return x * mul; \ +} + +MULT_RANGE_GEN(8); +MULT_RANGE_GEN(16); +MULT_RANGE_GEN(32); +MULT_RANGE_GEN(64); + +#define MULT_GEN(sm) \ +uint##sm##_t cn_gen_mult_u##sm(uint##sm##_t mul) { \ + return cn_gen_mult_range_u##sm(mul, 0, UINT##sm##_MAX); \ +} \ +int##sm##_t cn_gen_mult_i##sm(int##sm##_t mul) { \ + return cn_gen_mult_range_i##sm(mul, INT##sm##_MIN, INT##sm##_MAX); \ +} + +MULT_GEN(8); +MULT_GEN(16); +MULT_GEN(32); +MULT_GEN(64); + +void cn_gen_shuffle(void* arr, size_t len, size_t size) { + // byte size is implementation-defined (6.5.3.4, bullet 2) + // but `sizeof(char) == 1` is guaranteed. + char tmp[size]; + char* p = arr; + + for (int i = len - 1; i >= 0; i--) { + uint8_t j = cn_gen_range_u8(0, i + 1); + memcpy(tmp, arr + i * size, size); + memcpy(arr + i * size, arr + j * size, size); + memcpy(arr + j * size, tmp, size); + } +} + +static int comp_size_t(const void* x, const void* y) { + size_t a = *(const size_t*)x; + size_t b = *(const size_t*)y; + + if (a < b) return -1; + if (b > a) return 1; + return 0; +} + +void cn_gen_split(size_t n, size_t* arr[], size_t len) { + if (len == 1) { + *(arr[0]) = n; + return; + } + + if (len == 2) { + *(arr[0]) = (size_t)cn_gen_range_u64(0, n + 1); + *(arr[1]) = n - *(arr[0]); + return; + } + + int used = 0; + for (int i = 0; i < len - 1; i++) { + int left = n - (len - i) + 1 - used; + size_t rnd = (size_t)cn_gen_range_u64(1, left + 1); + *(arr[i]) = rnd; + used += rnd; + } + *(arr[len - 1]) = n - 1 - used; + + cn_gen_shuffle(&arr, len, sizeof(size_t*)); +} + struct choice_list { uint64_t choice; struct choice_list* next; @@ -167,7 +341,16 @@ void cn_gen_rand_restore(cn_gen_rand_checkpoint checkpoint) { choice_history = checkpoint; } +void free_list(struct choice_list* curr) { + while (curr != NULL) { + struct choice_list* tmp = curr; + curr = curr->next; + free(tmp); + } +} + void cn_gen_rand_replace(cn_gen_rand_checkpoint checkpoint) { cn_gen_rand_restore(checkpoint); + free_list(choice_history->next); choice_history->next = 0; } diff --git a/runtime/libcn/src/cn-testing/size.c b/runtime/libcn/src/cn-testing/size.c new file mode 100644 index 000000000..63662efab --- /dev/null +++ b/runtime/libcn/src/cn-testing/size.c @@ -0,0 +1,119 @@ +#include + +static size_t global_size = 20; + +size_t cn_gen_get_size(void) { + return global_size; +} + +void cn_gen_set_size(size_t sz) { + global_size = sz; +} + +static size_t global_max_size = 25; + +size_t cn_gen_get_max_size(void) { + return global_max_size; +} + +void cn_gen_set_max_size(size_t sz) { + global_max_size = sz; +} + +static uint16_t stack_depth = 0; +static uint16_t max_stack_depth = UINT8_MAX; + +uint16_t cn_gen_depth() { + return stack_depth; +} + +uint16_t cn_gen_max_depth() { + return max_stack_depth; +} + +void cn_gen_set_max_depth(uint16_t msd) { + max_stack_depth = msd; +} + +void cn_gen_increment_depth() { + stack_depth++; +} + +void cn_gen_decrement_depth() { + stack_depth--; +} + +static uint16_t depth_failures_allowed = UINT16_MAX; + +void cn_gen_set_depth_failures_allowed(uint16_t allowed) { + depth_failures_allowed = allowed; +} + +uint16_t cn_gen_get_depth_failures_allowed() { + return depth_failures_allowed; +} + +static uint16_t size_split_backtracks_allowed = 0; + +void cn_gen_set_size_split_backtracks_allowed(uint16_t allowed) { + size_split_backtracks_allowed = allowed; +} + +uint16_t cn_gen_get_size_split_backtracks_allowed() { + return size_split_backtracks_allowed; +} + +static uint8_t timeout = 0; + +void cn_gen_set_input_timeout(uint8_t seconds) { + timeout = seconds; +} + +uint8_t cn_gen_get_input_timeout(void) { + return timeout; +} + +static uint64_t timer = 0; + +void cn_gen_set_input_timer(uint64_t time) { + timer = time; +} + +uint64_t cn_gen_get_input_timer(void) { + return timer; +} + +#if defined (__unix__) || (defined (__APPLE__) && defined (__MACH__)) +#include +#elif defined(_WIN32) || defined(_WIN64) +#include + +/// Taken from https://stackoverflow.com/questions/10905892/equivalent-of-gettimeofday-for-windows +int gettimeofday(struct timeval* tp, struct timezone* tzp) +{ + // Note: some broken versions only have 8 trailing zero's, the correct epoch has 9 trailing zero's + // This magic number is the number of 100 nanosecond intervals since January 1, 1601 (UTC) + // until 00:00:00 January 1, 1970 + static const uint64_t EPOCH = ((uint64_t)116444736000000000ULL); + + SYSTEMTIME system_time; + FILETIME file_time; + uint64_t time; + + GetSystemTime(&system_time); + SystemTimeToFileTime(&system_time, &file_time); + time = ((uint64_t)file_time.dwLowDateTime); + time += ((uint64_t)file_time.dwHighDateTime) << 32; + + tp->tv_sec = (long)((time - EPOCH) / 10000000L); + tp->tv_usec = (long)(system_time.wMilliseconds * 1000); + return 0; +} +#endif + +uint64_t cn_gen_get_milliseconds(void) { + struct timeval tv; + + gettimeofday(&tv, NULL); + return (((uint64_t)tv.tv_sec) * 1000) + (tv.tv_usec / 1000); +} diff --git a/runtime/libcn/src/cn-testing/test.c b/runtime/libcn/src/cn-testing/test.c index 485854410..dcc639503 100644 --- a/runtime/libcn/src/cn-testing/test.c +++ b/runtime/libcn/src/cn-testing/test.c @@ -1,22 +1,22 @@ -#include #include #include #include #include #include #include +#include #include +#include #include #include #include - -typedef enum cn_test_result cn_test_case_fn(void); +#include struct cn_test_case { - char* suite; - char* name; + const char* suite; + const char* name; cn_test_case_fn* func; }; @@ -25,7 +25,7 @@ struct cn_test_case { static struct cn_test_case test_cases[CN_TEST_MAX_TEST_CASES]; static uint16_t num_test_cases = 0; -void cn_register_test_case(char* suite, char* name, cn_test_case_fn* func) { +void cn_register_test_case(const char* suite, const char* name, cn_test_case_fn* func) { if (num_test_cases == CN_TEST_MAX_TEST_CASES) { printf("Tried to register too many tests."); exit(1); @@ -38,13 +38,32 @@ void cn_register_test_case(char* suite, char* name, cn_test_case_fn* func) { }; } +void print_test_info(const char* suite, const char* name, int tests, int discards) { + if (tests == 0 && discards == 0) { + printf("Testing %s::%s:", suite, name); + } + else if (discards == 0) { + printf("Testing %s::%s: %d runs", suite, name, tests); + } + else { + printf("Testing %s::%s: %d runs; %d discarded", suite, name, tests, discards); + } + + fflush(stdout); +} + int cn_test_main(int argc, char* argv[]) { + int begin_time = cn_gen_get_milliseconds(); set_cn_logging_level(CN_LOGGING_NONE); - cn_gen_srand(time(NULL)); + cn_gen_srand(cn_gen_get_milliseconds()); + enum cn_test_gen_progress progress_level = CN_TEST_GEN_PROGRESS_ALL; uint64_t seed = cn_gen_rand(); int interactive = 0; enum cn_logging_level logging_level = CN_LOGGING_ERROR; + int timeout = 0; + int input_timeout = 5000; + int exit_fast = 0; for (int i = 0; i < argc; i++) { char* arg = argv[i]; @@ -59,8 +78,44 @@ int cn_test_main(int argc, char* argv[]) { logging_level = strtol(argv[i + 1], NULL, 10); i++; } + else if (strcmp("--progress-level", arg) == 0) { + progress_level = strtol(argv[i + 1], NULL, 10); + i++; + } + else if (strcmp("--input-timeout", arg) == 0) { + input_timeout = strtol(argv[i + 1], NULL, 10); + i++; + } else if (strcmp("--null-in-every", arg) == 0) { - set_null_in_every(strtol(argv[i + 1], NULL, 16)); + set_null_in_every(strtol(argv[i + 1], NULL, 10)); + i++; + } + else if (strcmp("--until-timeout", arg) == 0) { + timeout = strtol(argv[i + 1], NULL, 10); + i++; + } + else if (strcmp("--exit-fast", arg) == 0) { + exit_fast = 1; + } + else if (strcmp("--max-stack-depth", arg) == 0) { + cn_gen_set_max_depth(strtoul(argv[i + 1], NULL, 10)); + i++; + } + else if (strcmp("--max-generator-size", arg) == 0) { + uint64_t sz = strtoul(argv[i + 1], NULL, 10); + assert(sz != 0); + cn_gen_set_max_size(sz); + i++; + } + else if (strcmp("--sized-null", arg) == 0) { + set_sized_null(); + } + else if (strcmp("--allowed-depth-failures", arg) == 0) { + cn_gen_set_depth_failures_allowed(strtoul(argv[i + 1], NULL, 10)); + i++; + } + else if (strcmp("--allowed-size-split-backtracks", arg) == 0) { + cn_gen_set_size_split_backtracks_allowed(strtoul(argv[i + 1], NULL, 10)); i++; } } @@ -69,42 +124,95 @@ int cn_test_main(int argc, char* argv[]) { printf("Running in interactive mode\n"); } + if (timeout != 0) { + printf("Running until timeout of %d seconds\n", timeout); + } + printf("Using seed: %016" PRIx64 "\n", seed); cn_gen_srand(seed); cn_gen_rand(); // Junk to get something to make a checkpoint from + cn_gen_rand_checkpoint checkpoints[CN_TEST_MAX_TEST_CASES]; + enum cn_test_result results[CN_TEST_MAX_TEST_CASES]; + memset(results, CN_TEST_SKIP, CN_TEST_MAX_TEST_CASES * sizeof(enum cn_test_result)); + + int timediff = 0; + + do { + for (int i = 0; i < num_test_cases; i++) { + if (results[i] == CN_TEST_FAIL) { + continue; + } + + struct cn_test_case* test_case = &test_cases[i]; + if (progress_level == CN_TEST_GEN_PROGRESS_ALL) { + print_test_info(test_case->suite, test_case->name, 0, 0); + } + checkpoints[i] = cn_gen_rand_save(); + cn_gen_set_input_timeout(input_timeout); + enum cn_test_result result = test_case->func(progress_level); + if (!(results[i] == CN_TEST_PASS && result == CN_TEST_GEN_FAIL)) { + results[i] = result; + } + if (progress_level == CN_TEST_GEN_PROGRESS_NONE) { + continue; + } + + printf("\n"); + switch (result) { + case CN_TEST_PASS: + printf("PASSED\n"); + break; + case CN_TEST_FAIL: + printf("FAILED\n"); + set_cn_logging_level(logging_level); + cn_gen_rand_restore(checkpoints[i]); + cn_gen_set_input_timeout(0); + test_case->func(CN_TEST_GEN_PROGRESS_NONE); + set_cn_logging_level(CN_LOGGING_NONE); + printf("\n\n"); + break; + case CN_TEST_GEN_FAIL: + printf("FAILED TO GENERATE VALID INPUT\n"); + break; + case CN_TEST_SKIP: + printf("SKIPPED\n"); + break; + } + + if (exit_fast && result == CN_TEST_FAIL) { + goto outside_loop; + } + + if (timeout != 0) { + timediff = cn_gen_get_milliseconds() / 1000 - begin_time; + } + } + if (timediff < timeout) { + printf("\n%d seconds remaining, rerunning tests\n\n", timeout - timediff); + } + } while (timediff < timeout); + +outside_loop: + ; int passed = 0; int failed = 0; int errored = 0; int skipped = 0; - cn_gen_rand_checkpoint checkpoints[CN_TEST_MAX_TEST_CASES]; - enum cn_test_result results[CN_TEST_MAX_TEST_CASES]; for (int i = 0; i < num_test_cases; i++) { - struct cn_test_case* test_case = &test_cases[i]; - printf("Testing %s::%s: ", test_case->suite, test_case->name); - checkpoints[i] = cn_gen_rand_save(); - results[i] = test_case->func(); switch (results[i]) { case CN_TEST_PASS: passed++; - printf("PASSED\n"); break; case CN_TEST_FAIL: failed++; - printf("FAILED\n"); - set_cn_logging_level(logging_level); - cn_gen_rand_restore(checkpoints[i]); - test_case->func(); - set_cn_logging_level(CN_LOGGING_NONE); break; case CN_TEST_GEN_FAIL: errored++; - printf("FAILED TO GENERATE VALID INPUT\n"); break; case CN_TEST_SKIP: skipped++; - printf("SKIPPED\n"); break; } } @@ -155,9 +263,9 @@ int cn_test_main(int argc, char* argv[]) { cn_gen_rand_restore(checkpoints[mapToCase[testcase - 1]]); set_cn_logging_level(CN_LOGGING_INFO); - reset_cn_exit_cb(); + reset_cn_failure_cb(); // raise(SIGTRAP); // Trigger breakpoint - test_cases[mapToCase[testcase - 1]].func(); + test_cases[mapToCase[testcase - 1]].func(0); } return !(failed == 0 && errored == 0); diff --git a/runtime/libcn/src/cn-testing/uniform.c b/runtime/libcn/src/cn-testing/uniform.c index c69b0282a..79a184854 100644 --- a/runtime/libcn/src/cn-testing/uniform.c +++ b/runtime/libcn/src/cn-testing/uniform.c @@ -4,68 +4,13 @@ #include #include -// Sized generation according to Lemire: https://doi.org/10.1145/3230636 -#define UNSIGNED_GEN(sm, lg) \ -static uint##sm##_t uniform_u##sm(uint##sm##_t s) { \ - uint##sm##_t x = cn_gen_rand(); \ - if (s == 0) { \ - return x; \ - } \ - \ - uint##lg##_t m = (uint##lg##_t)x * (uint##lg##_t)s; \ - uint##sm##_t l = m; /* m % pow(2, sm) */ \ - if (l < s) { \ - uint##lg##_t t = (UINT##sm##_MAX - (s - 1)) % s; \ - while (l < t) { \ - x = cn_gen_rand(); \ - m = x * s; \ - l = m; /* m % pow(2, sm) */ \ - } \ - } \ - return m >> sm; \ -} - -UNSIGNED_GEN(8, 16); -UNSIGNED_GEN(16, 32); -UNSIGNED_GEN(32, 64); - -// OpenJDK 9 implementation, according to the definition in Lemire. -static uint64_t uniform_u64(uint64_t s) { - uint64_t x = cn_gen_rand(); - if (s == 0) { - return x; - } - - uint64_t r = x % s; - while (x - r > UINT64_MAX - (s - 1)) { - x = cn_gen_rand(); - r = x % s; - } - return r; -} - -#define SIGNED_GEN(sm) \ -static int##sm##_t uniform_i##sm(uint##sm##_t s) { \ - uint##sm##_t x = uniform_u##sm(s); \ - if (s == 0) { \ - return x; \ - } \ - uint##sm##_t offset = (s + 1) >> 2; \ - return x - offset; \ -} - -SIGNED_GEN(8); -SIGNED_GEN(16); -SIGNED_GEN(32); -SIGNED_GEN(64); - #define BITS_GEN(sm) \ cn_bits_u##sm* cn_gen_uniform_cn_bits_u##sm(uint64_t sz) { \ - return convert_to_cn_bits_u##sm(uniform_u##sm(sz)); \ + return convert_to_cn_bits_u##sm(cn_gen_uniform_u##sm(sz)); \ } \ \ cn_bits_i##sm* cn_gen_uniform_cn_bits_i##sm(uint64_t sz) { \ - return convert_to_cn_bits_i##sm(uniform_i##sm(sz)); \ + return convert_to_cn_bits_i##sm(cn_gen_uniform_i##sm(sz)); \ } BITS_GEN(8); @@ -74,18 +19,11 @@ BITS_GEN(32); BITS_GEN(64); #define RANGE_GEN(sm) \ -uint##sm##_t range_u##sm(uint##sm##_t min, uint##sm##_t max) { \ - uint##sm##_t x = uniform_u##sm(max - min); \ - return x + min; \ -} \ -int##sm##_t range_i##sm(int##sm##_t min, int##sm##_t max) { \ - return range_u##sm(min, max); \ -} \ cn_bits_u##sm* cn_gen_range_cn_bits_u##sm(cn_bits_u##sm* min, cn_bits_u##sm* max) { \ - return convert_to_cn_bits_u##sm(range_u##sm(min->val, max->val)); \ + return convert_to_cn_bits_u##sm(cn_gen_range_u##sm(min->val, max->val)); \ } \ cn_bits_i##sm* cn_gen_range_cn_bits_i##sm(cn_bits_i##sm* min, cn_bits_i##sm* max) { \ - return convert_to_cn_bits_i##sm(range_i##sm(min->val, max->val)); \ + return convert_to_cn_bits_i##sm(cn_gen_range_i##sm(min->val, max->val)); \ } RANGE_GEN(8); @@ -94,29 +32,17 @@ RANGE_GEN(32); RANGE_GEN(64); #define INEQ_GEN(sm)\ -uint##sm##_t lt_u##sm(uint##sm##_t max) { \ - return range_u##sm(0, max); \ -} \ -int##sm##_t lt_i##sm(int##sm##_t max) { \ - return range_i##sm(INT##sm##_MIN, max); \ -} \ cn_bits_u##sm* cn_gen_lt_cn_bits_u##sm(cn_bits_u##sm* max) { \ - return convert_to_cn_bits_u##sm(lt_u##sm(max->val)); \ + return convert_to_cn_bits_u##sm(cn_gen_lt_u##sm(max->val)); \ } \ cn_bits_i##sm* cn_gen_lt_cn_bits_i##sm(cn_bits_i##sm* max) { \ - return convert_to_cn_bits_i##sm(lt_i##sm(max->val)); \ -} \ -uint##sm##_t ge_u##sm(uint##sm##_t min) { \ - return range_u##sm(min, 0); \ -} \ -int##sm##_t ge_i##sm(int##sm##_t min) { \ - return range_i##sm(min, INT##sm##_MIN); \ + return convert_to_cn_bits_i##sm(cn_gen_lt_i##sm(max->val)); \ } \ cn_bits_u##sm* cn_gen_ge_cn_bits_u##sm(cn_bits_u##sm* min) { \ - return convert_to_cn_bits_u##sm(ge_u##sm(min->val)); \ + return convert_to_cn_bits_u##sm(cn_gen_ge_u##sm(min->val)); \ } \ cn_bits_i##sm* cn_gen_ge_cn_bits_i##sm(cn_bits_i##sm* min) { \ - return convert_to_cn_bits_i##sm(ge_i##sm(min->val)); \ + return convert_to_cn_bits_i##sm(cn_gen_ge_i##sm(min->val)); \ } INEQ_GEN(8); @@ -125,37 +51,21 @@ INEQ_GEN(32); INEQ_GEN(64); #define MULT_RANGE_GEN(sm) \ -uint##sm##_t mult_range_u##sm( \ - uint##sm##_t mul, \ - uint##sm##_t min, \ - uint##sm##_t max \ -) { \ - assert(mul != 0); \ - uint##sm##_t x = range_u##sm(min / mul, max / mul + (max % mul != 0)); \ - return x * mul; \ -} \ -int##sm##_t mult_range_i##sm( \ - int##sm##_t mul, \ - int##sm##_t min, \ - int##sm##_t max \ -) { \ - assert(mul != 0); \ - int##sm##_t x = range_i##sm(min / mul, max / mul + (max % mul != 0)); \ - return x * mul; \ -} \ cn_bits_u##sm* cn_gen_mult_range_cn_bits_u##sm( \ cn_bits_u##sm* mul, \ cn_bits_u##sm* min, \ cn_bits_u##sm* max \ ) { \ - return convert_to_cn_bits_u##sm(mult_range_u##sm(mul->val, min->val, max->val)); \ + return convert_to_cn_bits_u##sm( \ + cn_gen_mult_range_u##sm(mul->val, min->val, max->val)); \ } \ cn_bits_i##sm* cn_gen_mult_range_cn_bits_i##sm( \ cn_bits_i##sm* mul, \ cn_bits_i##sm* min, \ cn_bits_i##sm* max \ ) { \ - return convert_to_cn_bits_i##sm(mult_range_i##sm(mul->val, min->val, max->val)); \ + return convert_to_cn_bits_i##sm( \ + cn_gen_mult_range_i##sm(mul->val, min->val, max->val)); \ } MULT_RANGE_GEN(8); @@ -164,17 +74,11 @@ MULT_RANGE_GEN(32); MULT_RANGE_GEN(64); #define MULT_GEN(sm) \ -uint##sm##_t mult_u##sm(uint##sm##_t mul) { \ - return mult_range_u##sm(mul, 0, UINT##sm##_MAX); \ -} \ -int##sm##_t mult_i##sm(int##sm##_t mul) { \ - return mult_range_i##sm(mul, INT##sm##_MIN, INT##sm##_MAX); \ -}\ cn_bits_u##sm* cn_gen_mult_cn_bits_u##sm(cn_bits_u##sm* mul) { \ - return convert_to_cn_bits_u##sm(mult_u##sm(mul->val)); \ + return convert_to_cn_bits_u##sm(cn_gen_mult_u##sm(mul->val)); \ } \ cn_bits_i##sm* cn_gen_mult_cn_bits_i##sm(cn_bits_i##sm* mul) { \ - return convert_to_cn_bits_i##sm(mult_i##sm(mul->val)); \ + return convert_to_cn_bits_i##sm(cn_gen_mult_i##sm(mul->val)); \ } MULT_GEN(8); diff --git a/runtime/libcn/src/cn-testing/urn.c b/runtime/libcn/src/cn-testing/urn.c index 182dd2e78..539a46e6a 100644 --- a/runtime/libcn/src/cn-testing/urn.c +++ b/runtime/libcn/src/cn-testing/urn.c @@ -4,13 +4,13 @@ #include #include -int is_leaf(struct int_tree* tree) { +int is_leaf(struct cn_gen_int_tree* tree) { return tree->left == NULL && tree->right == NULL; } -uint64_t sample_tree_det(struct int_tree* tree, uint64_t index) { +uint64_t sample_tree_det(struct cn_gen_int_tree* tree, uint64_t index) { if (tree == NULL) { return -1; } @@ -26,20 +26,20 @@ uint64_t sample_tree_det(struct int_tree* tree, uint64_t index) { return sample_tree_det(tree->right, index - tree->left->weight); } -uint64_t sample_urn(struct int_urn* urn) { +uint64_t sample_urn(struct cn_gen_int_urn* urn) { uint64_t index = convert_from_cn_bits_u64(cn_gen_uniform_cn_bits_u64(urn->tree->weight)); return sample_tree_det(urn->tree, index); } -struct int_tree* insert_tree(uint8_t path, struct int_tree* tree, struct int_tree* leaf) { +struct cn_gen_int_tree* insert_tree(uint8_t path, struct cn_gen_int_tree* tree, struct cn_gen_int_tree* leaf) { if (tree == NULL) { return leaf; } if (is_leaf(tree)) { - struct int_tree* res = (struct int_tree*)malloc(sizeof(struct int_tree)); + struct cn_gen_int_tree* res = (struct cn_gen_int_tree*)malloc(sizeof(struct cn_gen_int_tree)); res->weight = tree->weight + leaf->weight; res->left = tree; res->right = leaf; @@ -57,8 +57,8 @@ struct int_tree* insert_tree(uint8_t path, struct int_tree* tree, struct int_tre return tree; } -void urn_insert(struct int_urn* urn, uint64_t weight, uint64_t value) { - struct int_tree* leaf = (struct int_tree*)malloc(sizeof(struct int_tree)); +void urn_insert(struct cn_gen_int_urn* urn, uint64_t weight, uint64_t value) { + struct cn_gen_int_tree* leaf = (struct cn_gen_int_tree*)malloc(sizeof(struct cn_gen_int_tree)); leaf->weight = weight; leaf->value = value; leaf->left = NULL; @@ -70,12 +70,14 @@ void urn_insert(struct int_urn* urn, uint64_t weight, uint64_t value) { -struct int_urn* urn_from_array(uint64_t elems[], uint8_t len) { - struct int_urn* urn = (struct int_urn*)malloc(sizeof(struct int_urn)); +struct cn_gen_int_urn* urn_from_array(uint64_t elems[], uint8_t len) { + struct cn_gen_int_urn* urn = (struct cn_gen_int_urn*)malloc(sizeof(struct cn_gen_int_urn)); urn->size = 0; urn->tree = NULL; for (uint16_t i = 0; i < 2 * (uint16_t)len; i += 2) { - urn_insert(urn, elems[i], elems[i + 1]); + if (elems[i] != 0) { + urn_insert(urn, elems[i], elems[i + 1]); + } } return urn; } @@ -90,7 +92,7 @@ struct replace_res { uint64_t valueNew; }; -struct replace_res replace_tree(struct int_tree* tree, uint64_t weight, uint64_t value, uint64_t index) { +struct replace_res replace_tree(struct cn_gen_int_tree* tree, uint64_t weight, uint64_t value, uint64_t index) { if (tree == NULL) { assert(false); } @@ -126,7 +128,7 @@ struct replace_res replace_tree(struct int_tree* tree, uint64_t weight, uint64_t } } -uint64_t replace(struct int_urn* urn, uint64_t weight, uint64_t value, uint64_t index) { +uint64_t replace(struct cn_gen_int_urn* urn, uint64_t weight, uint64_t value, uint64_t index) { return replace_tree(urn->tree, weight, value, index).valueOld; } @@ -136,10 +138,10 @@ struct uninsert_res { uint64_t lowerBound; - struct int_tree* tree; + struct cn_gen_int_tree* tree; }; -struct uninsert_res uninsert_tree(uint8_t path, struct int_tree* tree) { +struct uninsert_res uninsert_tree(uint8_t path, struct cn_gen_int_tree* tree) { if (tree == NULL) { assert(false); } @@ -172,12 +174,12 @@ struct uninsert_res uninsert_tree(uint8_t path, struct int_tree* tree) { } } -struct uninsert_res uninsert_urn(struct int_urn* urn) { +struct uninsert_res uninsert_urn(struct cn_gen_int_urn* urn) { urn->size -= 1; return uninsert_tree(urn->size, urn->tree); } -uint64_t remove_urn_det(struct int_urn* urn, uint64_t index) { +uint64_t remove_urn_det(struct cn_gen_int_urn* urn, uint64_t index) { struct uninsert_res res = uninsert_urn(urn); if (res.tree == NULL) { @@ -195,12 +197,12 @@ uint64_t remove_urn_det(struct int_urn* urn, uint64_t index) { } } -uint64_t urn_remove(struct int_urn* urn) { +uint64_t urn_remove(struct cn_gen_int_urn* urn) { uint64_t index = convert_from_cn_bits_u64(cn_gen_uniform_cn_bits_u64(urn->tree->weight)); return remove_urn_det(urn, index); } -void tree_free(struct int_tree* tree) { +void tree_free(struct cn_gen_int_tree* tree) { if (tree == NULL) { return; } @@ -214,7 +216,7 @@ void tree_free(struct int_tree* tree) { return free(tree); } -void urn_free(struct int_urn* urn) { +void urn_free(struct cn_gen_int_urn* urn) { free(urn->tree); free(urn); } \ No newline at end of file diff --git a/tests/cn-exec-performance-stats.py b/tests/cn-exec-performance-stats.py index d5a8280d9..6dc5138e8 100755 --- a/tests/cn-exec-performance-stats.py +++ b/tests/cn-exec-performance-stats.py @@ -85,7 +85,6 @@ def gen_instr_cmd(f, input_basename): instr_cmd_prefix = "cn instrument" instr_cmd = time_cmd_str + instr_cmd_prefix + " " + tests_path + "/" + f instr_cmd += " --output-decorated=" + input_basename + "-exec.c" - instr_cmd += " --with-ownership-checking" return instr_cmd def gen_compile_cmd(input_basename, instrumented): diff --git a/tests/cn-test-gen/src/bin_tree.pass.c b/tests/cn-test-gen/src/bin_tree.pass.c new file mode 100644 index 000000000..d36b12089 --- /dev/null +++ b/tests/cn-test-gen/src/bin_tree.pass.c @@ -0,0 +1,45 @@ +void* cn_malloc(unsigned long size); + +struct int_tree { + int key; + struct int_tree* left; + struct int_tree* right; +}; + +/*@ + datatype binary_tree { + Tree_Leaf {}, + Tree_Node { i32 key, datatype binary_tree left, datatype binary_tree right } + } + predicate (datatype binary_tree) IntTree(pointer p) { + if (is_null(p)) { + return Tree_Leaf {}; + } else { + take n = Owned(p); + take l = IntTree(n.left); + take r = IntTree(n.right); + return Tree_Node { key: n.key, left: l, right: r }; + } + } +@*/ + +struct int_tree* deepCopyRecursive(struct int_tree* p) + /*@ + requires + take T = IntTree(p); + ensures + take T_ = IntTree(p); + T == T_; + take T2 = IntTree(return); + T == T2; + @*/ +{ + if (p == 0) { + return 0; + } + struct int_tree* q = cn_malloc(sizeof(struct int_tree)); + q->key = p->key; + q->left = deepCopyRecursive(p->left); + q->right = deepCopyRecursive(p->right); + return q; +} diff --git a/tests/cn-test-gen/src/bounds.pass.c b/tests/cn-test-gen/src/bounds.pass.c new file mode 100644 index 000000000..1928980c0 --- /dev/null +++ b/tests/cn-test-gen/src/bounds.pass.c @@ -0,0 +1,35 @@ +void bounds1(int size, int* p) +/*@ +requires + take a1 = each(u64 i; 0u64 <= i && i < (u64)size) { Owned(array_shift(p,i)) }; +ensures + take a2 = each(u64 i; 0u64 <= i && i < (u64)size) { Owned(array_shift(p,i)) }; +@*/ +{} + +void bounds2(int size, int* p) +/*@ +requires + take a1 = each(u64 i; i < (u64)size) { Owned(array_shift(p,i)) }; +ensures + take a2 = each(u64 i; i < (u64)size) { Owned(array_shift(p,i)) }; +@*/ +{} + +void bounds3(int size, int* p) +/*@ +requires + take a1 = each(i32 i; -1i32 < i && i < size) { Owned(array_shift(p,i)) }; +ensures + take a2 = each(i32 i; -1i32 < i && i < size) { Owned(array_shift(p,i)) }; +@*/ +{} + +void bounds4(int* p) +/*@ +requires + take a1 = each(i32 i; i == 1i32 || i == 2i32 || i == 5i32) { Owned(array_shift(p,i)) }; +ensures + take a2 = each(i32 i; i == 1i32 || i == 2i32 || i == 5i32) { Owned(array_shift(p,i)) }; +@*/ +{} diff --git a/tests/cn-test-gen/src/bst.fail.c b/tests/cn-test-gen/src/bst.fail.c new file mode 100644 index 000000000..c608670e9 --- /dev/null +++ b/tests/cn-test-gen/src/bst.fail.c @@ -0,0 +1,405 @@ +#include + +#define KEY int +#define VALUE long + +struct MapNode { + KEY key; + VALUE value; + struct MapNode *smaller; + struct MapNode *larger; +}; + +extern void* cn_malloc(size_t size); +extern void cn_free_sized(void *ptr, size_t size); + + +/*@ + +type_synonym KEY = i32 +type_synonym VALUE = i64 +type_synonym NodeData = { KEY key, VALUE value } + +function (KEY) defaultKey() { 0i32 } + +datatype ValueOption { + ValueNone {}, + ValueSome { VALUE value } +} + + +// ----------------------------------------------------------------------------- +// Intervals + +// Non-empty, closed intervals +type_synonym Interval = { KEY lower, KEY upper } + +function (Interval) defaultInterval() { + { lower: defaultKey(), upper: defaultKey() } +} + +datatype IntervalOption { + IntervalNone {}, + IntervalSome { Interval i } +} + +function (boolean) isIntervalSome(IntervalOption i) { + match i { + IntervalNone {} => { false } + IntervalSome { i:_ } => { true } + } +} + +function (Interval) fromIntervalOption(IntervalOption i) { + match i { + IntervalNone {} => { defaultInterval() } + IntervalSome { i:j } => { j } + } +} + + +function (IntervalOption) + joinInterval(IntervalOption optSmaller, KEY val, IntervalOption optLarger) { + match optSmaller { + IntervalNone {} => { + match optLarger { + IntervalNone {} => { + IntervalSome { i: { lower: val, upper: val } } + } + IntervalSome { i: larger } => { + if (val < larger.lower) { + IntervalSome { i: { lower: val, upper: larger.upper } } + } else { + IntervalNone {} + } + } + } + } + IntervalSome { i: smaller } => { + if (val > smaller.upper) { + match optLarger { + IntervalNone {} => { + IntervalSome { i: { lower: smaller.lower, upper: val } } + } + IntervalSome { i: larger } => { + if (val < larger.lower) { + IntervalSome { i: { lower: smaller.lower, upper: larger.upper } } + } else { + IntervalNone {} + } + } + } + } else { + IntervalNone {} + } + } + } +} + + + +// ----------------------------------------------------------------------------- + + + + +// A binary dearch tree +datatype BST { + Leaf {}, + Node { NodeData data, BST smaller, BST larger } +} + +function (boolean) hasRoot(KEY key, BST tree) { + match tree { + Leaf {} => { false } + Node { data: data, smaller: _, larger: _ } => { data.key == key } + } +} + +function [rec] (ValueOption) lookup(KEY key, BST tree) { + match tree { + Leaf {} => { ValueNone {} } + Node { data: data, smaller: smaller, larger: larger } => { + if (data.key == key) { + ValueSome { value: data.value } + } else { + if (data.key < key) { + lookup(key,larger) + } else { + lookup(key,smaller) + } + } + } + } +} + +function [rec] (boolean) member(KEY k, BST tree) { + match tree { + Leaf {} => { false } + Node { data: data, smaller: smaller, larger: larger } => { + data.key == k || + k < data.key && member(k,smaller) || + k > data.key && member(k,larger) + } + } +} + +function [rec] (BST) insert(KEY key, VALUE value, BST tree) { + match tree { + Leaf {} => { Node { data: { key: key, value: value }, + smaller: Leaf {}, larger: Leaf {} } } + Node { data: data, smaller: smaller, larger: larger } => { + if (data.key == key) { + Node { data: { key: key, value: value }, + smaller: smaller, larger: larger } + } else { + if (data.key < key) { + Node { data: data, + smaller: smaller, larger: insert(key,value,larger) } + } else { + Node { data: data, + smaller: insert(key,value,smaller), larger: larger } + } + } + } + } +} + +function [rec] (BST) setKey(KEY k, BST root, BST value) { + match root { + Leaf {} => { value } + Node { data: data, smaller: smaller, larger: larger } => { + if (k < data.key) { + Node { data: data, smaller: setKey(k, smaller, value), larger: larger } + } else { + Node { data: data, smaller: smaller, larger: setKey(k, larger, value) } + } + } + } +} + + + + +// ***************************************************************************** +// Consuming an entire tree +// ***************************************************************************** + + +// Semantic data stored at a node +function (NodeData) getNodeData(struct MapNode node) { + { key: node.key, value: node.value } +} + +type_synonym RangedBST = { BST tree, IntervalOption range } +type_synonym RangedNode = { + struct MapNode node, + BST smaller, + BST larger, + Interval range +} + +predicate RangedNode RangedNode(pointer root) { + take node = Owned(root); + take smaller = RangedBST(node.smaller); + take larger = RangedBST(node.larger); + let rangeOpt = joinInterval(smaller.range, node.key, larger.range); + assert (isIntervalSome(rangeOpt)); + return { node: node, smaller: smaller.tree, larger: larger.tree, + range: fromIntervalOption(rangeOpt) }; +} + +// A binary search tree, and the interval for all its keys. +predicate RangedBST RangedBST(pointer root) { + if (is_null(root)) { + return { tree: Leaf {}, range: IntervalNone{} }; + } else { + take node = RangedNode(root); + let data = getNodeData(node.node); + return { tree: Node { data: data, smaller: node.smaller, larger: node.larger }, + range: IntervalSome { i: node.range } }; + } +} + +// An arbitrary binary search tree. +predicate BST BST(pointer root) { + take result = RangedBST(root); + return result.tree; +} + + + + +// ***************************************************************************** +// Focusing on a node in the tree +// ***************************************************************************** + +type_synonym BSTNodeFocus = + { BST done, struct MapNode node, BST smaller, BST larger } + +datatype BSTFocus { + AtLeaf { BST tree }, + AtNode { BST done, struct MapNode node, BST smaller, BST larger } +} + +predicate BSTFocus BSTFocus(pointer root, pointer child) { + if (is_null(child)) { + take tree = BST(root); + return AtLeaf { tree: tree }; + } else { + take node = RangedNode(child); + take result = BSTNodeUpTo(root, child, node.node, node.range); + return AtNode { done: result.tree, node: node.node, + smaller: node.smaller, larger: node.larger }; + } +} + +// Consume parts of the tree starting at `p` until we get to `c`. +// We do not consume `c`. +// `child` is the node stored at `c`. +predicate RangedBST BSTNodeUpTo(pointer p, pointer c, struct MapNode child, Interval range) { + if (ptr_eq(p,c)) { + return { tree: Leaf {}, range: IntervalSome { i: range } }; + } else { + take parent = Owned(p); + take result = BSTNodeChildUpTo(c, child, range, parent); + return result; + } +} + +// Starting at a parent with data `data` and children `smaller` and `larger`, +// we go toward `c`, guided by its value, `target`. +predicate RangedBST + BSTNodeChildUpTo(pointer c, struct MapNode target, Interval range, struct MapNode parent) { + if (parent.key < target.key) { + take small = RangedBST(parent.smaller); + take large = BSTNodeUpTo(parent.larger, c, target, range); + let node = getNodeData(parent); + let optRange = joinInterval(small.range, node.key, large.range); + assert(isIntervalSome(optRange)); + return { tree: Node { data: node, smaller: small.tree, larger: large.tree }, + range: optRange }; + } else { + if (parent.key > target.key) { + take small = BSTNodeUpTo(parent.smaller, c, target, range); + take large = RangedBST(parent.larger); + let node = getNodeData(parent); + let optRange = joinInterval(small.range, node.key, large.range); + assert(isIntervalSome(optRange)); + return { tree: Node { data: node, smaller: small.tree, larger: large.tree }, + range: optRange }; + } else { + // We should never get here, but asserting `false` is not allowed + return { tree: Leaf {}, range: IntervalNone {} }; + }} +} + +function (BST) unfocus(BSTFocus focus) { + match focus { + AtLeaf { tree: tree } => { tree } + AtNode { done: tree, node: node, smaller: smaller, larger: larger } => { + let bst = Node { data: getNodeData(node), smaller: smaller, larger: larger }; + setKey(node.key, tree, bst) + } + } +} + +function (BST) focusDone(BSTFocus focus) { + match focus { + AtLeaf { tree: tree } => { tree } + AtNode { done: tree, node: _, smaller: _, larger: _ } => { tree } + } +} + + + +@*/ + + +/* Allocate a new singleton node */ +struct MapNode *newNode(KEY key, VALUE value) +/*@ +requires + true; +ensures + take node = Owned(return); + node.key == key; + node.value == value; + is_null(node.smaller); + is_null(node.larger); +@*/ +{ + struct MapNode *node = (struct MapNode*)cn_malloc(sizeof(struct MapNode)); + node->key = key; + node->value = value; + node->smaller = 0; + node->larger = 0; + return node; +} + + +struct MapNode *findParent(struct MapNode **node, KEY key) +/*@ +requires + take tree_ptr = Owned(node); + take tree = BST(tree_ptr); +ensures + take cur_ptr = Owned(node); + let not_found = is_null(cur_ptr); + not_found == !member(key, tree); + take focus = BSTFocus(tree_ptr, return); + unfocus(focus) == tree; + match focus { + AtLeaf { tree: _ } => { + not_found || ptr_eq(cur_ptr,tree_ptr) && hasRoot(key, tree) + } + AtNode { done: _, node: parent, smaller: _, larger: _ } => { + let tgt = if (key < parent.key) { parent.smaller } else { parent.larger }; + ptr_eq(cur_ptr,tgt) + } + }; +@*/ +{ + struct MapNode *parent = 0; + struct MapNode *cur = *node; + while (cur) + { + KEY k = cur->key; + if (k == key) { + *node = cur; + return parent; + } + parent = cur; + cur = k < key? cur->larger : cur->smaller; + } + *node = cur; + return parent; +} + +/* Insert an element into a map. Overwrites previous if already present. */ +void map_insert(struct MapNode **root, KEY key, VALUE value) +/*@ +requires + take root_ptr = Owned(root); + take tree = BST(root_ptr); +ensures + take new_root = Owned(root); + take new_tree = BST(new_root); + new_tree == insert(key, value, tree); +@*/ +{ + struct MapNode *search = *root; + struct MapNode *parent = findParent(&search, key); + + if (!parent) { + *root = newNode(key,value); + return; + } + + struct MapNode *new_node = newNode(key,value); + if (parent->key < key) { + parent->larger = new_node; + } else { + parent->smaller = new_node; + } +} diff --git a/tests/cn-test-gen/src/bst.pass.c b/tests/cn-test-gen/src/bst.pass.c new file mode 100644 index 000000000..8b67d436c --- /dev/null +++ b/tests/cn-test-gen/src/bst.pass.c @@ -0,0 +1,555 @@ +#include + +#define KEY int +#define VALUE long + +struct MapNode { + KEY key; + VALUE value; + struct MapNode *smaller; + struct MapNode *larger; +}; + +extern void* cn_malloc(size_t size); +extern void cn_free_sized(void *ptr, size_t size); + + +/*@ + +type_synonym KEY = i32 +type_synonym VALUE = i64 +type_synonym NodeData = { KEY key, VALUE value } + +function (KEY) defaultKey() { 0i32 } +function (VALUE) defaultValue() { 0i64 } +function (NodeData) defaultNodeData() { + { key: defaultKey(), value: defaultValue() } +} + +datatype ValueOption { + ValueNone {}, + ValueSome { VALUE value } +} + + +// ----------------------------------------------------------------------------- +// Intervals + +// Non-empty, closed intervals +type_synonym Interval = { KEY lower, KEY upper } + +function (Interval) defaultInterval() { + { lower: defaultKey(), upper: defaultKey() } +} + +datatype IntervalOption { + IntervalNone {}, + IntervalSome { Interval i } +} + +function (boolean) isIntervalSome(IntervalOption i) { + match i { + IntervalNone {} => { false } + IntervalSome { i:_ } => { true } + } +} + +function (Interval) fromIntervalOption(IntervalOption i) { + match i { + IntervalNone {} => { defaultInterval() } + IntervalSome { i:j } => { j } + } +} + + +function (IntervalOption) + joinInterval(IntervalOption optSmaller, KEY val, IntervalOption optLarger) { + match optSmaller { + IntervalNone {} => { + match optLarger { + IntervalNone {} => { + IntervalSome { i: { lower: val, upper: val } } + } + IntervalSome { i: larger } => { + if (val < larger.lower) { + IntervalSome { i: { lower: val, upper: larger.upper } } + } else { + IntervalNone {} + } + } + } + } + IntervalSome { i: smaller } => { + if (val > smaller.upper) { + match optLarger { + IntervalNone {} => { + IntervalSome { i: { lower: smaller.lower, upper: val } } + } + IntervalSome { i: larger } => { + if (val < larger.lower) { + IntervalSome { i: { lower: smaller.lower, upper: larger.upper } } + } else { + IntervalNone {} + } + } + } + } else { + IntervalNone {} + } + } + } +} + + + +// ----------------------------------------------------------------------------- + + + + +// A binary dearch tree +datatype BST { + Leaf {}, + Node { NodeData data, BST smaller, BST larger } +} + +function (boolean) hasRoot(KEY key, BST tree) { + match tree { + Leaf {} => { false } + Node { data: data, smaller: _, larger: _ } => { data.key == key } + } +} + +function (boolean) isLeaf(BST tree) { + match tree { + Leaf {} => { true } + Node { data: _, smaller: _, larger: _ } => { false } + } +} + +function [rec] (ValueOption) lookup(KEY key, BST tree) { + match tree { + Leaf {} => { ValueNone {} } + Node { data: data, smaller: smaller, larger: larger } => { + if (data.key == key) { + ValueSome { value: data.value } + } else { + if (data.key < key) { + lookup(key,larger) + } else { + lookup(key,smaller) + } + } + } + } +} + +function [rec] (boolean) member(KEY k, BST tree) { + match tree { + Leaf {} => { false } + Node { data: data, smaller: smaller, larger: larger } => { + data.key == k || + k < data.key && member(k,smaller) || + k > data.key && member(k,larger) + } + } +} + +function [rec] (BST) insert(KEY key, VALUE value, BST tree) { + match tree { + Leaf {} => { Node { data: { key: key, value: value }, + smaller: Leaf {}, larger: Leaf {} } } + Node { data: data, smaller: smaller, larger: larger } => { + if (data.key == key) { + Node { data: { key: key, value: value }, + smaller: smaller, larger: larger } + } else { + if (data.key < key) { + Node { data: data, + smaller: smaller, larger: insert(key,value,larger) } + } else { + Node { data: data, + smaller: insert(key,value,smaller), larger: larger } + } + } + } + } +} + +function [rec] (BST) setKey(KEY k, BST root, BST value) { + match root { + Leaf {} => { value } + Node { data: data, smaller: smaller, larger: larger } => { + if (k < data.key) { + Node { data: data, smaller: setKey(k, smaller, value), larger: larger } + } else { + Node { data: data, smaller: smaller, larger: setKey(k, larger, value) } + } + } + } +} + + + + +// ***************************************************************************** +// Consuming an entire tree +// ***************************************************************************** + + +// Semantic data stored at a node +function (NodeData) getNodeData(struct MapNode node) { + { key: node.key, value: node.value } +} + +type_synonym RangedBST = { BST tree, IntervalOption range } +type_synonym RangedNode = { + struct MapNode node, + BST smaller, + BST larger, + Interval range +} + +predicate RangedNode RangedNode(pointer root) { + take node = Owned(root); + take smaller = RangedBST(node.smaller); + take larger = RangedBST(node.larger); + let rangeOpt = joinInterval(smaller.range, node.key, larger.range); + assert (isIntervalSome(rangeOpt)); + return { node: node, smaller: smaller.tree, larger: larger.tree, + range: fromIntervalOption(rangeOpt) }; +} + +// A binary search tree, and the interval for all its keys. +predicate RangedBST RangedBST(pointer root) { + if (is_null(root)) { + return { tree: Leaf {}, range: IntervalNone{} }; + } else { + take node = RangedNode(root); + let data = getNodeData(node.node); + return { tree: Node { data: data, smaller: node.smaller, larger: node.larger }, + range: IntervalSome { i: node.range } }; + } +} + +// An arbitrary binary search tree. +predicate BST BST(pointer root) { + take result = RangedBST(root); + return result.tree; +} + + + + +// ***************************************************************************** +// Focusing on a node in the tree +// ***************************************************************************** + +type_synonym BSTNodeFocus = + { BST done, struct MapNode node, BST smaller, BST larger } + +datatype BSTFocus { + AtLeaf { BST tree }, + AtNode { BST done, struct MapNode node, BST smaller, BST larger } +} + +predicate BSTFocus BSTFocus(pointer root, pointer child) { + if (is_null(child)) { + take tree = BST(root); + return AtLeaf { tree: tree }; + } else { + take node = RangedNode(child); + take result = BSTNodeUpTo(root, child, node.node, node.range); + return AtNode { done: result.tree, node: node.node, + smaller: node.smaller, larger: node.larger }; + } +} + +// Consume parts of the tree starting at `p` until we get to `c`. +// We do not consume `c`. +// `child` is the node stored at `c`. +predicate RangedBST BSTNodeUpTo(pointer p, pointer c, struct MapNode child, Interval range) { + if (ptr_eq(p,c)) { + return { tree: Leaf {}, range: IntervalSome { i: range } }; + } else { + take parent = Owned(p); + take result = BSTNodeChildUpTo(c, child, range, parent); + return result; + } +} + +// Starting at a parent with data `data` and children `smaller` and `larger`, +// we go toward `c`, guided by its value, `target`. +predicate RangedBST + BSTNodeChildUpTo(pointer c, struct MapNode target, Interval range, struct MapNode parent) { + if (parent.key < target.key) { + take small = RangedBST(parent.smaller); + take large = BSTNodeUpTo(parent.larger, c, target, range); + let node = getNodeData(parent); + let optRange = joinInterval(small.range, node.key, large.range); + assert(isIntervalSome(optRange)); + return { tree: Node { data: node, smaller: small.tree, larger: large.tree }, + range: optRange }; + } else { + if (parent.key > target.key) { + take small = BSTNodeUpTo(parent.smaller, c, target, range); + take large = RangedBST(parent.larger); + let node = getNodeData(parent); + let optRange = joinInterval(small.range, node.key, large.range); + assert(isIntervalSome(optRange)); + return { tree: Node { data: node, smaller: small.tree, larger: large.tree }, + range: optRange }; + } else { + // We should never get here, but asserting `false` is not allowed + return { tree: Leaf {}, range: IntervalNone {} }; + }} +} + +function (BST) unfocus(BSTFocus focus) { + match focus { + AtLeaf { tree: tree } => { tree } + AtNode { done: tree, node: node, smaller: smaller, larger: larger } => { + let bst = Node { data: getNodeData(node), smaller: smaller, larger: larger }; + setKey(node.key, tree, bst) + } + } +} + +function (BST) focusDone(BSTFocus focus) { + match focus { + AtLeaf { tree: tree } => { tree } + AtNode { done: tree, node: _, smaller: _, larger: _ } => { tree } + } +} + + + +@*/ + + +/* Allocate a new singleton node */ +struct MapNode *newNode(KEY key, VALUE value) +/*@ +requires + true; +ensures + take node = Owned(return); + node.key == key; + node.value == value; + is_null(node.smaller); + is_null(node.larger); +@*/ +{ + struct MapNode *node = (struct MapNode*)cn_malloc(sizeof(struct MapNode)); + node->key = key; + node->value = value; + node->smaller = 0; + node->larger = 0; + return node; +} + + +struct MapNode *findParent(struct MapNode **node, KEY key) +/*@ +requires + take tree_ptr = Owned(node); + take tree = BST(tree_ptr); +ensures + take cur_ptr = Owned(node); + let not_found = is_null(cur_ptr); + not_found == !member(key, tree); + take focus = BSTFocus(tree_ptr, return); + unfocus(focus) == tree; + match focus { + AtLeaf { tree: _ } => { + not_found || ptr_eq(cur_ptr,tree_ptr) && hasRoot(key, tree) + } + AtNode { done: _, node: parent, smaller: _, larger: _ } => { + let tgt = if (key < parent.key) { parent.smaller } else { parent.larger }; + ptr_eq(cur_ptr,tgt) + } + }; +@*/ +{ + struct MapNode *parent = 0; + struct MapNode *cur = *node; + while (cur) + { + KEY k = cur->key; + if (k == key) { + *node = cur; + return parent; + } + parent = cur; + cur = k < key? cur->larger : cur->smaller; + } + *node = cur; + return parent; +} + +/* Insert an element into a map. Overwrites previous if already present. */ +void map_insert(struct MapNode **root, KEY key, VALUE value) +/*@ +requires + take root_ptr = Owned(root); + take tree = BST(root_ptr); +ensures + take new_root = Owned(root); + take new_tree = BST(new_root); + new_tree == insert(key, value, tree); +@*/ +{ + struct MapNode *search = *root; + struct MapNode *parent = findParent(&search, key); + if (search) { + search->value = value; + return; + } + + if (!parent) { + *root = newNode(key,value); + return; + } + + struct MapNode *new_node = newNode(key,value); + if (parent->key < key) { + parent->larger = new_node; + } else { + parent->smaller = new_node; + } +} + +/*@ +function [rec] ({ boolean empty, NodeData data, BST tree }) delLeast(BST root) { + match root { + Leaf {} => { { empty: true, data: defaultNodeData(), tree: Leaf {} } } + Node { data: data, smaller: smaller, larger: larger } => { + if (isLeaf(smaller)) { + { empty: false, data: data, tree: larger } + } else { + let res = delLeast(smaller); + { empty: false, + data: res.data, + tree: Node { data: data, smaller: res.tree, larger: larger } + } + } + } + } +} + +predicate (void) DeleteSmallest(pointer cur, NodeData data) { + if (is_null(cur)) { + assert(data == defaultNodeData()); + return; + } else { + take node = Owned(cur); + assert(node.key == data.key); + assert(node.value == data.value); + return; + } +} +@*/ + +struct MapNode* deleteSmallest(struct MapNode **root) +/*@ + requires + take root_ptr = Owned(root); + take tree = BST(root_ptr); + ensures + take new_root = Owned(root); + take new_tree = BST(new_root); + let res = delLeast(tree); + new_tree == res.tree; + take unused = DeleteSmallest(return, res.data); +@*/ +{ + struct MapNode *cur = *root; + if (!cur) return 0; + + struct MapNode *parent = 0; + while (cur->smaller) { + parent = cur; + cur = cur->smaller; + } + + if (parent) { + parent->smaller = cur->larger; + } + //! // + else { + *root = cur->larger; + } + //!! forget_to_update_root // + //! // + + return cur; +} + +/*@ +function [rec] (BST) delKey(KEY key, BST root) { + match root { + Leaf {} => { Leaf {} } + Node { data: data, smaller: smaller, larger: larger } => { + if (key == data.key) { + let res = delLeast(larger); + if (res.empty) { + smaller + } else { + Node { data: res.data, smaller: smaller, larger: res.tree } + } + } else { + //! // + if (key < data.key) { + Node { data: data, smaller: delKey(key, smaller), larger: larger } + } else { + Node { data: data, smaller: smaller, larger: delKey(key, larger) } + } + //!! delete_4_spec // + //! if (key < data.key) { delKey(key, smaller) } else { delKey(key, larger) } // + //!! delete_5_spec // + //! if (key > data.key) { Node { data: data, smaller: delKey(key, smaller), larger: larger } } else { Node { data: data, smaller: smaller, larger: delKey(key, larger) } } // + } + } + } +} +@*/ + +void deleteKey(struct MapNode **root, KEY key) +/*@ +requires + take root_ptr = Owned(root); + take tree = BST(root_ptr); +ensures + take new_ptr = Owned(root); + take new_tree = BST(new_ptr); + delKey(key, tree) == new_tree; +@*/ +{ + struct MapNode *found = *root; + struct MapNode *parent = findParent(&found, key); + + if (!found) { return; } + struct MapNode *remove = deleteSmallest(&found->larger); + if (remove) { + found->key = remove->key; + found->value = remove->value; + } else { + remove = found; + //! // + if (!parent) { + //!! always_update_root_instead_of_parent // + //! if (1) { // + *root = found->smaller; + //! // + } else if (key < parent->key) { + //!! always_assign_smaller // + //! } else if (1) { // + parent->smaller = found->smaller; + } else if (key > parent->key) { + parent->larger = found->smaller; + } else { + /* unreachable */ + } + } + cn_free_sized(remove, sizeof(struct MapNode)); +} diff --git a/tests/cn-test-gen/src/enum1.pass.c b/tests/cn-test-gen/src/enum1.pass.c new file mode 100644 index 000000000..df29512a3 --- /dev/null +++ b/tests/cn-test-gen/src/enum1.pass.c @@ -0,0 +1,7 @@ +enum color { + Red, Green, Blue +}; + +enum color identity(enum color x) { + return x; +} diff --git a/tests/cn-test-gen/src/enum2.pass.c b/tests/cn-test-gen/src/enum2.pass.c new file mode 100644 index 000000000..d0a54e46d --- /dev/null +++ b/tests/cn-test-gen/src/enum2.pass.c @@ -0,0 +1,7 @@ +enum color { + Red, Green, Blue +}; + +enum color identity() { + return Red; +} diff --git a/tests/cn-test-gen/src/preserve.pass.c b/tests/cn-test-gen/src/preserve.pass.c deleted file mode 100644 index 81657e8e6..000000000 --- a/tests/cn-test-gen/src/preserve.pass.c +++ /dev/null @@ -1,9 +0,0 @@ -void preserve(int size, int *p) -/*@ -requires - take a1 = each(u64 i; 0u64 <= i && i < (u64)size) { Owned(array_shift(p,i)) }; -ensures - take a2 = each(u64 i; 0u64 <= i && i < (u64)size) { Owned(array_shift(p,i)) }; -@*/ -{ -} diff --git a/tests/cn-test-gen/src/sized_array.pass.c b/tests/cn-test-gen/src/sized_array.pass.c new file mode 100644 index 000000000..4931eba82 --- /dev/null +++ b/tests/cn-test-gen/src/sized_array.pass.c @@ -0,0 +1,12 @@ +struct foo { + int bar[16]; +}; + +void test_gen_const_array(struct foo* c) +/*@ +requires take Client_in = Owned(c); +ensures take Client_out = Owned(c); +@*/ +{ + return; +} diff --git a/tests/cn-test-gen/src/sorted_list.cons.fail.c b/tests/cn-test-gen/src/sorted_list.cons.fail.c new file mode 100644 index 000000000..dc3efb8b5 --- /dev/null +++ b/tests/cn-test-gen/src/sorted_list.cons.fail.c @@ -0,0 +1,52 @@ +// Sorted list + +struct List +{ + int value; + struct List* next; +}; + +/*@ +datatype IntList { + Nil {}, + Cons { i32 head, IntList tail } +} + +function (boolean) validCons(i32 head, IntList tail) { + match tail { + Nil {} => { true } + Cons { head: next, tail: _ } => { head <= next } + } +} + +predicate IntList ListSegment(pointer from, pointer to) { + if (ptr_eq(from,to)) { + return Nil {}; + } else { + take head = Owned(from); + take tail = ListSegment(head.next, to); + assert(validCons(head.value,tail)); + return Cons { head: head.value, tail: tail }; + } +} +@*/ + +void *cn_malloc(unsigned long size); + + +// This is invalid because we don't preserve the sorted invariant. +void cons(int x, struct List** xs) +/*@ + requires + take list_ptr = Owned(xs); + take list = ListSegment(list_ptr,NULL); + ensures + take new_list_ptr = Owned(xs); + take new_list = ListSegment(new_list_ptr,NULL); +@*/ +{ + struct List *node = (struct List*) cn_malloc(sizeof(struct List)); + node->value = x; + node->next = *xs; + *xs = node; +} diff --git a/tests/cn-test-gen/src/sorted_list.insert.fail.c b/tests/cn-test-gen/src/sorted_list.insert.fail.c new file mode 100644 index 000000000..8740aefac --- /dev/null +++ b/tests/cn-test-gen/src/sorted_list.insert.fail.c @@ -0,0 +1,82 @@ +// Sorted list + +struct List +{ + int value; + struct List* next; +}; + +/*@ +datatype IntList { + Nil {}, + Cons { i32 head, IntList tail } +} + +function (boolean) validCons(i32 head, IntList tail) { + match tail { + Nil {} => { true } + Cons { head: next, tail: _ } => { head <= next } + } +} + +function [rec] (IntList) insertList(boolean dups, i32 x, IntList xs) { + match xs { + Nil {} => { Cons { head: x, tail: Nil {} } } + Cons { head: head, tail: tail } => { + if (head < x) { + Cons { head: head, tail: insertList(dups, x,tail) } + } else { + if (!dups && head == x) { + xs + } else { + Cons { head: x, tail: xs } + } + } + } + } +} + +predicate IntList ListSegment(pointer from, pointer to) { + if (ptr_eq(from,to)) { + return Nil {}; + } else { + take head = Owned(from); + take tail = ListSegment(head.next, to); + assert(validCons(head.value,tail)); + return Cons { head: head.value, tail: tail }; + } +} +@*/ + +void *cn_malloc(unsigned long size); + +void insert(int x, struct List **xs) +/*@ + requires + take list_ptr = Owned(xs); + take list = ListSegment(list_ptr,NULL); + ensures + take new_list_ptr = Owned(xs); + take new_list = ListSegment(new_list_ptr,NULL); + new_list == insertList(false,x,list); +@*/ +{ + struct List *node = (struct List*) cn_malloc(sizeof(struct List)); + node->value = x; + + struct List* prev = 0; + struct List* cur = *xs; + while (cur && cur->value < x) { + prev = cur; + cur = cur->next; + } + + if (prev) { + prev->next = node; + node->next = cur; + } else { + node->next = *xs; + *xs = node; + } + +} diff --git a/tests/cn-test-gen/src/sorted_list.insert.pass.c b/tests/cn-test-gen/src/sorted_list.insert.pass.c new file mode 100644 index 000000000..69e3da2ed --- /dev/null +++ b/tests/cn-test-gen/src/sorted_list.insert.pass.c @@ -0,0 +1,82 @@ +// Sorted list + +struct List +{ + int value; + struct List* next; +}; + +/*@ +datatype IntList { + Nil {}, + Cons { i32 head, IntList tail } +} + +function (boolean) validCons(i32 head, IntList tail) { + match tail { + Nil {} => { true } + Cons { head: next, tail: _ } => { head <= next } + } +} + +function [rec] (IntList) insertList(boolean dups, i32 x, IntList xs) { + match xs { + Nil {} => { Cons { head: x, tail: Nil {} } } + Cons { head: head, tail: tail } => { + if (head < x) { + Cons { head: head, tail: insertList(dups, x,tail) } + } else { + if (!dups && head == x) { + xs + } else { + Cons { head: x, tail: xs } + } + } + } + } +} + +predicate IntList ListSegment(pointer from, pointer to) { + if (ptr_eq(from,to)) { + return Nil {}; + } else { + take head = Owned(from); + take tail = ListSegment(head.next, to); + assert(validCons(head.value,tail)); + return Cons { head: head.value, tail: tail }; + } +} +@*/ + +void *cn_malloc(unsigned long size); + +void insert(int x, struct List **xs) +/*@ + requires + take list_ptr = Owned(xs); + take list = ListSegment(list_ptr,NULL); + ensures + take new_list_ptr = Owned(xs); + take new_list = ListSegment(new_list_ptr,NULL); + new_list == insertList(true,x,list); +@*/ +{ + struct List *node = (struct List*) cn_malloc(sizeof(struct List)); + node->value = x; + + struct List* prev = 0; + struct List* cur = *xs; + while (cur && cur->value < x) { + prev = cur; + cur = cur->next; + } + + if (prev) { + prev->next = node; + node->next = cur; + } else { + node->next = *xs; + *xs = node; + } + +} diff --git a/tests/cn-test-gen/src/sorted_list.sum.pass.c b/tests/cn-test-gen/src/sorted_list.sum.pass.c new file mode 100644 index 000000000..62dd72263 --- /dev/null +++ b/tests/cn-test-gen/src/sorted_list.sum.pass.c @@ -0,0 +1,52 @@ +// Sorted list + +struct List +{ + int value; + struct List* next; +}; + +/*@ +datatype IntList { + Nil {}, + Cons { i32 head, IntList tail } +} + +function (boolean) validCons(i32 head, IntList tail) { + match tail { + Nil {} => { true } + Cons { head: next, tail: _ } => { head <= next } + } +} + +predicate IntList ListSegment(pointer from, pointer to) { + if (ptr_eq(from,to)) { + return Nil {}; + } else { + take head = Owned(from); + take tail = ListSegment(head.next, to); + assert(validCons(head.value,tail)); + return Cons { head: head.value, tail: tail }; + } +} +@*/ + + +// This is a valid spec, even though to verify with CN we'd need a loop invariant. +int sum(struct List* xs) +/*@ + requires + take l1 = ListSegment(xs,NULL); + ensures + take l2 = ListSegment(xs,NULL); + l1 == l2; + true; +@*/ +{ + int result = 0; + while(xs) { + result += xs->value; + xs = xs->next; + } + return result; +} diff --git a/tests/cn/alloc_create.c.verify b/tests/cn/alloc_create.c.verify new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn/alloc_create.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn/alloc_token.c.verify b/tests/cn/alloc_token.c.verify new file mode 100644 index 000000000..e1522bb41 --- /dev/null +++ b/tests/cn/alloc_token.c.verify @@ -0,0 +1 @@ +return code: 0 diff --git a/tests/cn/and_or_precedence.error.c.verify b/tests/cn/and_or_precedence.error.c.verify new file mode 100644 index 000000000..dab54766c --- /dev/null +++ b/tests/cn/and_or_precedence.error.c.verify @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: g1 -- fail +tests/cn/and_or_precedence.error.c:15:13: error: Unprovable constraint + /*@ assert (false); @*/ + ^~~~~~~~~~~~~~~ +Constraint from tests/cn/and_or_precedence.error.c:15:13: + /*@ assert (false); @*/ + ^~~~~~~~~~~~~~~ +State file: file:///tmp/state__and_or_precedence.error.c__g1.html diff --git a/tests/cn/append.c.verify b/tests/cn/append.c.verify new file mode 100644 index 000000000..88a4dc256 --- /dev/null +++ b/tests/cn/append.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: IntList_append -- pass +[2/2]: split -- pass diff --git a/tests/cn/arith_type.error.c.verify b/tests/cn/arith_type.error.c.verify new file mode 100644 index 000000000..89c33c743 --- /dev/null +++ b/tests/cn/arith_type.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/arith_type.error.c:8:21: error: Type error + let x = negate() + true; + ^ +Expression 'true' has type 'boolean'. +I expected it to have type 'integer' because of tests/cn/arith_type.error.c:8:10: + let x = negate() + true; + ~~~~~~^~ diff --git a/tests/cn/arrow_access.c.verify b/tests/cn/arrow_access.c.verify new file mode 100644 index 000000000..e451e2eea --- /dev/null +++ b/tests/cn/arrow_access.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: arrow_access_1 -- pass +[2/2]: arrow_access_2 -- pass diff --git a/tests/cn/assert_on_toplevel.error.c.verify b/tests/cn/assert_on_toplevel.error.c.verify new file mode 100644 index 000000000..81eb93822 --- /dev/null +++ b/tests/cn/assert_on_toplevel.error.c.verify @@ -0,0 +1,5 @@ +return code: 2 +tests/cn/assert_on_toplevel.error.c:2:5: error: unexpected token before 'assert' +parsing "cn_toplevel'": expected "cn_toplevel" + assert @*/ + ^~~~~~ diff --git a/tests/cn/b_or.c.verify b/tests/cn/b_or.c.verify new file mode 100644 index 000000000..a17639e1c --- /dev/null +++ b/tests/cn/b_or.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: f -- pass diff --git a/tests/cn/b_xor.c.verify b/tests/cn/b_xor.c.verify new file mode 100644 index 000000000..a17639e1c --- /dev/null +++ b/tests/cn/b_xor.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: f -- pass diff --git a/tests/cn/bad_col.error.c.verify b/tests/cn/bad_col.error.c.verify new file mode 100644 index 000000000..448606b92 --- /dev/null +++ b/tests/cn/bad_col.error.c.verify @@ -0,0 +1,5 @@ +return code: 1 +tests/cn/bad_col.error.c:3:32: error: unexpected token after '+' and before 'function' +parsing "add_expr": seen "add_expr PLUS", expecting "mul_expr" + x < 2147483647 + function; @*/ + ^~~~~~~~ diff --git a/tests/cn/bad_constructor_user.error.c.verify b/tests/cn/bad_constructor_user.error.c.verify new file mode 100644 index 000000000..896996060 --- /dev/null +++ b/tests/cn/bad_constructor_user.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/bad_constructor_user.error.c:9:19: error: Type error + Cons { head : 0, tail : Nil {} } + ^ +Expression '0' has type 'integer'. +I expected it to have type 'i32' because of tests/cn/bad_constructor_user.error.c:9:5: + Cons { head : 0, tail : Nil {} } + ~~~~~^~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn/bad_function_call.error.c.verify b/tests/cn/bad_function_call.error.c.verify new file mode 100644 index 000000000..54d2810f6 --- /dev/null +++ b/tests/cn/bad_function_call.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/bad_function_call.error.c:7:12: error: Type error + id_int(x) + ^ +Expression 'x' has type 'i32'. +I expected it to have type 'integer' because of tests/cn/bad_function_call.error.c:2:1: +function (integer) id_int(integer x) { +^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn/bad_record.error.c.verify b/tests/cn/bad_record.error.c.verify new file mode 100644 index 000000000..bb6d84cbe --- /dev/null +++ b/tests/cn/bad_record.error.c.verify @@ -0,0 +1,4 @@ +return code: 2 +tests/cn/bad_record.error.c:3:43: error: field `x' duplicated +type_synonym wrong = { integer x, integer x } + ^ diff --git a/tests/cn/bad_record2.error.c.verify b/tests/cn/bad_record2.error.c.verify new file mode 100644 index 000000000..3988a0513 --- /dev/null +++ b/tests/cn/bad_record2.error.c.verify @@ -0,0 +1,4 @@ +return code: 2 +tests/cn/bad_record2.error.c:6:15: error: field `x' duplicated + { x: p.x, x: p.y } + ^ diff --git a/tests/cn/bad_recursion.error.c.verify b/tests/cn/bad_recursion.error.c.verify new file mode 100644 index 000000000..5f7a54443 --- /dev/null +++ b/tests/cn/bad_recursion.error.c.verify @@ -0,0 +1,6 @@ +return code: 1 +tests/cn/bad_recursion.error.c:3:1: error: Illegal datatype definition. +Constructor argument 'b' is given type 'map', which indirectly refers to 'datatype bad'. +Indirect recursion via map, set, record, or tuple types is not permitted. +datatype bad { Bad { map b } } +^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn/bad_resource_var.error.c.verify b/tests/cn/bad_resource_var.error.c.verify new file mode 100644 index 000000000..1fa821a13 --- /dev/null +++ b/tests/cn/bad_resource_var.error.c.verify @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: inc -- fail +tests/cn/bad_resource_var.error.c:1:1: error: Unprovable constraint +void inc(int* p) +~~~~~^~~~~~~~~~~ +Constraint from tests/cn/bad_resource_var.error.c:5:13: + X2 < 2147483647i32; @*/ + ^~~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__bad_resource_var.error.c__inc.html diff --git a/tests/cn/before_from_bytes.error.c.verify b/tests/cn/before_from_bytes.error.c.verify new file mode 100644 index 000000000..dab7dd396 --- /dev/null +++ b/tests/cn/before_from_bytes.error.c.verify @@ -0,0 +1,13 @@ +return code: 1 +tests/cn/before_from_bytes.error.c:6:9: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*@ to_bytes Owned(p); @*/ + ^~~~~~~~ +tests/cn/before_from_bytes.error.c:7:9: warning: extract: index added, no resources (yet) extracted. + /*@ extract Owned, 2u64; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~ +[1/1]: main -- fail +tests/cn/before_from_bytes.error.c:8:5: error: Missing resource for writing + p_char[2] = 0xff; + ~~~~~~~~~~^~~~~~ +Resource needed: Block(&&x[(u64)2'i32]) +State file: file:///tmp/state__before_from_bytes.error.c__main.html diff --git a/tests/cn/before_to_bytes.error.c.verify b/tests/cn/before_to_bytes.error.c.verify new file mode 100644 index 000000000..9b0a8a511 --- /dev/null +++ b/tests/cn/before_to_bytes.error.c.verify @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: main -- fail +tests/cn/before_to_bytes.error.c:6:5: error: Missing resource for writing + p_char[2] = 0xff; + ~~~~~~~~~~^~~~~~ +Resource needed: Block(&&x[(u64)2'i32]) +State file: file:///tmp/state__before_to_bytes.error.c__main.html diff --git a/tests/cn/bitwise_and.c.verify b/tests/cn/bitwise_and.c.verify new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn/bitwise_and.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn/bitwise_and_type_left.error.c.verify b/tests/cn/bitwise_and_type_left.error.c.verify new file mode 100644 index 000000000..be59b8dd1 --- /dev/null +++ b/tests/cn/bitwise_and_type_left.error.c.verify @@ -0,0 +1,5 @@ +return code: 1 +tests/cn/bitwise_and_type_left.error.c:3:17: error: Ill-typed application of binary operation '&' . + /*@ assert (0 & 1i32 == 0i32); @*/ + ~~^~~~~~ +'0' has type 'integer', '1'i32' has type 'i32'. diff --git a/tests/cn/bitwise_and_type_right.error.c.verify b/tests/cn/bitwise_and_type_right.error.c.verify new file mode 100644 index 000000000..bcfa695e6 --- /dev/null +++ b/tests/cn/bitwise_and_type_right.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/bitwise_and_type_right.error.c:3:24: error: Type error + /*@ assert (0i32 & 1 == 0i32); @*/ + ^ +Expression '1' has type 'integer'. +I expected it to have type 'i32' because of tests/cn/bitwise_and_type_right.error.c:3:17: + /*@ assert (0i32 & 1 == 0i32); @*/ + ^ diff --git a/tests/cn/bitwise_compl.c.verify b/tests/cn/bitwise_compl.c.verify new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn/bitwise_compl.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn/bitwise_compl_precedence.c.verify b/tests/cn/bitwise_compl_precedence.c.verify new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn/bitwise_compl_precedence.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn/bitwise_compl_type.error.c.verify b/tests/cn/bitwise_compl_type.error.c.verify new file mode 100644 index 000000000..c21c11f6c --- /dev/null +++ b/tests/cn/bitwise_compl_type.error.c.verify @@ -0,0 +1,5 @@ +return code: 1 +tests/cn/bitwise_compl_type.error.c:3:18: error: Mismatched types. + /*@ assert (~0 == -1); @*/ + ^ +Expected value of type 'bitvector' but found value of type 'integer' diff --git a/tests/cn/block_type.c.verify b/tests/cn/block_type.c.verify new file mode 100644 index 000000000..1bb6cba68 --- /dev/null +++ b/tests/cn/block_type.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: block_notype_1 -- pass +[2/2]: block_notype_2 -- pass diff --git a/tests/cn/builtin_ctz.c.verify b/tests/cn/builtin_ctz.c.verify new file mode 100644 index 000000000..a17639e1c --- /dev/null +++ b/tests/cn/builtin_ctz.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: f -- pass diff --git a/tests/cn/builtin_ctz_val.c.verify b/tests/cn/builtin_ctz_val.c.verify new file mode 100644 index 000000000..a17639e1c --- /dev/null +++ b/tests/cn/builtin_ctz_val.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: f -- pass diff --git a/tests/cn/cn_inline.c.verify b/tests/cn/cn_inline.c.verify new file mode 100644 index 000000000..5e3efbb37 --- /dev/null +++ b/tests/cn/cn_inline.c.verify @@ -0,0 +1,6 @@ +return code: 0 +tests/cn/cn_inline.c:13:5: warning: experimental keyword 'cn_function' (use of experimental features is discouraged) +/*@ cn_function lookup_size_shift_cn; @*/ + ^~~~~~~~~~~ +[1/2]: lookup_size_shift -- pass +[2/2]: f -- pass diff --git a/tests/cn/cnfunction_mismatched_args1.error.c.verify b/tests/cn/cnfunction_mismatched_args1.error.c.verify new file mode 100644 index 000000000..c58d4f650 --- /dev/null +++ b/tests/cn/cnfunction_mismatched_args1.error.c.verify @@ -0,0 +1,7 @@ +return code: 1 +tests/cn/cnfunction_mismatched_args1.error.c:6:5: warning: experimental keyword 'cn_function' (use of experimental features is discouraged) +/*@ cn_function bw_or; @*/ + ^~~~~~~~~~~ +tests/cn/cnfunction_mismatched_args1.error.c:5:1: error: mismatched argument number for c_bw_or -> bw_or +int c_bw_or(int x) +~~~~^~~~~~~~~~~~~~ diff --git a/tests/cn/cnfunction_mismatched_args2.error.c.verify b/tests/cn/cnfunction_mismatched_args2.error.c.verify new file mode 100644 index 000000000..d357d91a4 --- /dev/null +++ b/tests/cn/cnfunction_mismatched_args2.error.c.verify @@ -0,0 +1,7 @@ +return code: 1 +tests/cn/cnfunction_mismatched_args2.error.c:6:5: warning: experimental keyword 'cn_function' (use of experimental features is discouraged) +/*@ cn_function bw_or; @*/ + ^~~~~~~~~~~ +tests/cn/cnfunction_mismatched_args2.error.c:5:1: error: mismatched argument number for c_bw_or -> bw_or +int c_bw_or(int x, int y, int z) +~~~~^~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn/cnfunction_mismatched_args3.error.c.verify b/tests/cn/cnfunction_mismatched_args3.error.c.verify new file mode 100644 index 000000000..09416403a --- /dev/null +++ b/tests/cn/cnfunction_mismatched_args3.error.c.verify @@ -0,0 +1,7 @@ +return code: 1 +tests/cn/cnfunction_mismatched_args3.error.c:6:5: warning: experimental keyword 'cn_function' (use of experimental features is discouraged) +/*@ cn_function bw_or; @*/ + ^~~~~~~~~~~ +tests/cn/cnfunction_mismatched_args3.error.c:5:1: error: mismatched arguments: (u32 y) and (i32 y) +int c_bw_or(int x, int y) +~~~~^~~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn/cnfunction_mismatched_args4.error.c.verify b/tests/cn/cnfunction_mismatched_args4.error.c.verify new file mode 100644 index 000000000..a46ca7b5e --- /dev/null +++ b/tests/cn/cnfunction_mismatched_args4.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/cnfunction_mismatched_args4.error.c:6:5: warning: experimental keyword 'cn_function' (use of experimental features is discouraged) +/*@ cn_function bw_or; @*/ + ^~~~~~~~~~~ +tests/cn/cnfunction_mismatched_args4.error.c:6:5: error: cn_function: return-type mismatch: +c_bw_or : i32 -> bw_or : u32 +/*@ cn_function bw_or; @*/ + ^~~~~~~~~~~~~~~~~~ diff --git a/tests/cn/copy_alloc_id.c.verify b/tests/cn/copy_alloc_id.c.verify new file mode 100644 index 000000000..403d4a98c --- /dev/null +++ b/tests/cn/copy_alloc_id.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: f1 -- pass +[2/3]: f2 -- pass +[3/3]: main -- pass diff --git a/tests/cn/copy_alloc_id.error.c.verify b/tests/cn/copy_alloc_id.error.c.verify new file mode 100644 index 000000000..1912b9b83 --- /dev/null +++ b/tests/cn/copy_alloc_id.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn/copy_alloc_id.error.c:4:12: error: Pointer `p` needs allocation ID + int* q = __cerbvar_copy_alloc_id(p_int + 0ULL, p); + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +(UB missing short message): UB_CERB004_unspecified__copy_alloc_id +State file: file:///tmp/state__copy_alloc_id.error.c__f.html diff --git a/tests/cn/copy_alloc_id2.error.c.verify b/tests/cn/copy_alloc_id2.error.c.verify new file mode 100644 index 000000000..49f644d43 --- /dev/null +++ b/tests/cn/copy_alloc_id2.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn/copy_alloc_id2.error.c:10:12: error: Pointer `p` needs to be live for copy_alloc_id + int* q = __cerbvar_copy_alloc_id(p_int + 0ULL, p); + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Need an Alloc or Owned in context with same allocation id +State file: file:///tmp/state__copy_alloc_id2.error.c__f.html diff --git a/tests/cn/create_rdonly.c.verify b/tests/cn/create_rdonly.c.verify new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn/create_rdonly.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn/disj_nonnull.c.verify b/tests/cn/disj_nonnull.c.verify new file mode 100644 index 000000000..aebb850c1 --- /dev/null +++ b/tests/cn/disj_nonnull.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: globals -- pass +[2/2]: main -- pass diff --git a/tests/cn/division.c.verify b/tests/cn/division.c.verify new file mode 100644 index 000000000..49eb5132a --- /dev/null +++ b/tests/cn/division.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: division -- pass diff --git a/tests/cn/division_by_0.error.c.verify b/tests/cn/division_by_0.error.c.verify new file mode 100644 index 000000000..26b354deb --- /dev/null +++ b/tests/cn/division_by_0.error.c.verify @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: division -- fail +tests/cn/division_by_0.error.c:6:12: error: Undefined behaviour + return x / y; + ~~^~~ +the value of the second operand of a '/' operator is zero (§6.5.5#5, sentence 2) +State file: file:///tmp/state__division_by_0.error.c__division.html diff --git a/tests/cn/division_casting.c.verify b/tests/cn/division_casting.c.verify new file mode 100644 index 000000000..49eb5132a --- /dev/null +++ b/tests/cn/division_casting.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: division -- pass diff --git a/tests/cn/division_precedence.c.verify b/tests/cn/division_precedence.c.verify new file mode 100644 index 000000000..1b05d9f8a --- /dev/null +++ b/tests/cn/division_precedence.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: divide_no_parenthesis -- pass +[2/3]: multiply_then_divide -- pass +[3/3]: divide_multiply_add_subtract -- pass diff --git a/tests/cn/division_return_sign.error.c.verify b/tests/cn/division_return_sign.error.c.verify new file mode 100644 index 000000000..f12610a77 --- /dev/null +++ b/tests/cn/division_return_sign.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/division_return_sign.error.c:7:25: error: Type error + ensures return == x/y; @*/ + ^ +Expression 'y' has type 'u32'. +I expected it to have type 'i32' because of tests/cn/division_return_sign.error.c:7:23: + ensures return == x/y; @*/ + ^ diff --git a/tests/cn/division_return_size.error.c.verify b/tests/cn/division_return_size.error.c.verify new file mode 100644 index 000000000..d059aaf6f --- /dev/null +++ b/tests/cn/division_return_size.error.c.verify @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: different_size -- fail +tests/cn/division_return_size.error.c:9:5: error: integer value not representable at type signed int + return x / y; + ^~~~~~~~~~~~~ +Value: (i64)x / y +State file: file:///tmp/state__division_return_size.error.c__different_size.html diff --git a/tests/cn/division_with_constants.c.verify b/tests/cn/division_with_constants.c.verify new file mode 100644 index 000000000..892106973 --- /dev/null +++ b/tests/cn/division_with_constants.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: divide_by_ten -- pass +[2/3]: divide_by_neg_ten -- pass +[3/3]: division_diff_sign -- pass diff --git a/tests/cn/doubling.c.verify b/tests/cn/doubling.c.verify new file mode 100644 index 000000000..e21c36d77 --- /dev/null +++ b/tests/cn/doubling.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: add_self -- pass +[2/2]: add_self_twice -- pass diff --git a/tests/cn/duplicate_datatype_var.error.c.verify b/tests/cn/duplicate_datatype_var.error.c.verify new file mode 100644 index 000000000..70654f4b5 --- /dev/null +++ b/tests/cn/duplicate_datatype_var.error.c.verify @@ -0,0 +1,4 @@ +return code: 1 +tests/cn/duplicate_datatype_var.error.c:5:22: error: Re-using member name x within datatype definition (SMT limitation). + Single { integer x } + ^ diff --git a/tests/cn/duplicate_pattern_var.error.c.verify b/tests/cn/duplicate_pattern_var.error.c.verify new file mode 100644 index 000000000..b4c60a1e6 --- /dev/null +++ b/tests/cn/duplicate_pattern_var.error.c.verify @@ -0,0 +1,4 @@ +return code: 2 +tests/cn/duplicate_pattern_var.error.c:15:43: error: redeclaration of variable + Cons { head : Point { x : a , y : a } , tail : tail } => { a + b + sum(tail) } + ^ diff --git a/tests/cn/enum_and_and.c.verify b/tests/cn/enum_and_and.c.verify new file mode 100644 index 000000000..7213715e9 --- /dev/null +++ b/tests/cn/enum_and_and.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: foo -- pass diff --git a/tests/cn/extract_verbose.c.verify b/tests/cn/extract_verbose.c.verify new file mode 100644 index 000000000..1a3d525ad --- /dev/null +++ b/tests/cn/extract_verbose.c.verify @@ -0,0 +1,23 @@ +return code: 0 +tests/cn/extract_verbose.c:10:27: warning: 'extract' expects a 'u64', but '1' with type 'integer' was provided. This will become an error in the future. + /*@ extract Owned, 1; @*/ + ^ +tests/cn/extract_verbose.c:11:27: warning: 'extract' expects a 'u64', but '1' with type 'integer' was provided. This will become an error in the future. + /*@ extract Owned, 1; @*/ + ^ +tests/cn/extract_verbose.c:14:27: warning: 'extract' expects a 'u64', but '12' with type 'integer' was provided. This will become an error in the future. + /*@ extract Owned, 12; @*/ + ^ +tests/cn/extract_verbose.c:10:7: warning: extract: index added, no resources (yet) extracted. + /*@ extract Owned, 1; @*/ + ^~~~~~~~~~~~~~~~~~~~~~ +tests/cn/extract_verbose.c:11:7: warning: extract: index added, no resources (yet) extracted. + /*@ extract Owned, 1; @*/ + ^~~~~~~~~~~~~~~~~~~~~~ +tests/cn/extract_verbose.c:13:7: warning: extract: index added, no resources (yet) extracted. + /*@ extract Owned, 1u64; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~ +tests/cn/extract_verbose.c:14:7: warning: extract: index added, no resources (yet) extracted. + /*@ extract Owned, 12; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~ +[1/1]: f -- pass diff --git a/tests/cn/failing_postcond.error.c.verify b/tests/cn/failing_postcond.error.c.verify new file mode 100644 index 000000000..fe739f1fa --- /dev/null +++ b/tests/cn/failing_postcond.error.c.verify @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: inc -- fail +tests/cn/failing_postcond.error.c:5:5: error: Unprovable constraint + return x + 1; + ^~~~~~~~~~~~~ +Constraint from tests/cn/failing_postcond.error.c:3:13: +/*@ ensures return < 2147483647i32; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__failing_postcond.error.c__inc.html diff --git a/tests/cn/failing_precond.error.c.verify b/tests/cn/failing_precond.error.c.verify new file mode 100644 index 000000000..d98e2153b --- /dev/null +++ b/tests/cn/failing_precond.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/failing_precond.error.c:2:18: error: Type error +/*@ requires x < 2147483647; @*/ + ^ +Expression '2147483647' has type 'integer'. +I expected it to have type 'i32' because of tests/cn/failing_precond.error.c:2:14: +/*@ requires x < 2147483647; @*/ + ^ diff --git a/tests/cn/forloop_with_decl.c.verify b/tests/cn/forloop_with_decl.c.verify new file mode 100644 index 000000000..b9ced8656 --- /dev/null +++ b/tests/cn/forloop_with_decl.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: for_with_decl -- pass diff --git a/tests/cn/from_bytes.error.c.verify b/tests/cn/from_bytes.error.c.verify new file mode 100644 index 000000000..aac42624f --- /dev/null +++ b/tests/cn/from_bytes.error.c.verify @@ -0,0 +1,11 @@ +return code: 1 +tests/cn/from_bytes.error.c:5:9: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*@ to_bytes Owned(p); @*/ + ^~~~~~~~ +tests/cn/from_bytes.error.c:6:9: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*@ from_bytes Alloc(p); @*/ // <-- proof fails here, but this is a no-op in runtime + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn/from_bytes.error.c:6:9: error: byte conversion only supports Owned/Block + /*@ from_bytes Alloc(p); @*/ // <-- proof fails here, but this is a no-op in runtime + ^~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn/fun_addrs_cn_stmt.c.verify b/tests/cn/fun_addrs_cn_stmt.c.verify new file mode 100644 index 000000000..2822fb76c --- /dev/null +++ b/tests/cn/fun_addrs_cn_stmt.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: g -- pass +[2/2]: f -- pass diff --git a/tests/cn/fun_ptr_extern.c.verify b/tests/cn/fun_ptr_extern.c.verify new file mode 100644 index 000000000..f89dd0f7f --- /dev/null +++ b/tests/cn/fun_ptr_extern.c.verify @@ -0,0 +1,5 @@ +return code: 0 +[1/4]: f1 -- pass +[2/4]: get_int_binop -- pass +[3/4]: call_site -- pass +[4/4]: main -- pass diff --git a/tests/cn/fun_ptr_known.c.verify b/tests/cn/fun_ptr_known.c.verify new file mode 100644 index 000000000..d966d7146 --- /dev/null +++ b/tests/cn/fun_ptr_known.c.verify @@ -0,0 +1,5 @@ +return code: 0 +[1/4]: f1 -- pass +[2/4]: f2 -- pass +[3/4]: f3 -- pass +[4/4]: main -- pass diff --git a/tests/cn/fun_ptr_three_opts.c.verify b/tests/cn/fun_ptr_three_opts.c.verify new file mode 100644 index 000000000..dcfcf08ca --- /dev/null +++ b/tests/cn/fun_ptr_three_opts.c.verify @@ -0,0 +1,7 @@ +return code: 0 +[1/6]: f1 -- pass +[2/6]: f2 -- pass +[3/6]: f3 -- pass +[4/6]: get_int_binop -- pass +[5/6]: call_site -- pass +[6/6]: main -- pass diff --git a/tests/cn/get_from_arr.c.verify b/tests/cn/get_from_arr.c.verify new file mode 100644 index 000000000..5aabc6bff --- /dev/null +++ b/tests/cn/get_from_arr.c.verify @@ -0,0 +1,14 @@ +return code: 0 +tests/cn/get_from_arr.c:7:19: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. +/*@ requires take IA = each (i32 j; 0i32 <= j && j < 10i32) + ^ +tests/cn/get_from_arr.c:9:18: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. +/*@ ensures take IA2 = each (i32 j; 0i32 <= j && j < 10i32) + ^ +tests/cn/get_from_arr.c:14:28: warning: 'extract' expects a 'u64', but '4'i32' with type 'i32' was provided. This will become an error in the future. + /*@ extract Owned, 4i32; @*/ + ^ +tests/cn/get_from_arr.c:15:7: warning: nothing instantiated + /*@ instantiate good, 4i32; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +[1/1]: get_from_arr -- pass diff --git a/tests/cn/get_from_array.c.verify b/tests/cn/get_from_array.c.verify new file mode 100644 index 000000000..f9411a18f --- /dev/null +++ b/tests/cn/get_from_array.c.verify @@ -0,0 +1,15 @@ +return code: 0 +tests/cn/get_from_array.c:16:5: warning: experimental keyword 'cn_function' (use of experimental features is discouraged) +/*@ cn_function global_array_width; @*/ + ^~~~~~~~~~~ +tests/cn/get_from_array.c:24:8: warning: 'each' expects a 'u64', but 'i' with type 'i32' was provided. This will become an error in the future. + take Arr = each (i32 i; 0i32 <= i && i < global_array_width ()) + ^ +tests/cn/get_from_array.c:40:28: warning: 'extract' expects a 'u64', but '(i32)idx' with type 'i32' was provided. This will become an error in the future. + /*@ extract Owned, ((i32) idx); @*/ + ^~~~~~~~~ +[1/2]: get_global_array_width_for_cn -- pass +tests/cn/get_from_array.c:41:7: warning: nothing instantiated + /*@ instantiate good, ((i32) idx); @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +[2/2]: set_a_pointer -- pass diff --git a/tests/cn/ghost_pointer_to_bitvec_cast.c.verify b/tests/cn/ghost_pointer_to_bitvec_cast.c.verify new file mode 100644 index 000000000..f1de7d51d --- /dev/null +++ b/tests/cn/ghost_pointer_to_bitvec_cast.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: test_cast_loc_to_various -- pass +[2/2]: main -- pass diff --git a/tests/cn/gnu_case_ranges.c.verify b/tests/cn/gnu_case_ranges.c.verify new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn/gnu_case_ranges.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn/gnu_choose.c.verify b/tests/cn/gnu_choose.c.verify new file mode 100644 index 000000000..e51cabdb4 --- /dev/null +++ b/tests/cn/gnu_choose.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: f -- pass +[2/3]: g -- pass +[3/3]: main -- pass diff --git a/tests/cn/gnu_ctz.c.verify b/tests/cn/gnu_ctz.c.verify new file mode 100644 index 000000000..a0ab8fde2 --- /dev/null +++ b/tests/cn/gnu_ctz.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: ctz -- pass +[2/2]: main -- pass diff --git a/tests/cn/gnu_ffs.c.verify b/tests/cn/gnu_ffs.c.verify new file mode 100644 index 000000000..6a005aa32 --- /dev/null +++ b/tests/cn/gnu_ffs.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: ffs -- pass +[2/2]: main -- pass diff --git a/tests/cn/gnu_types_compatible.c.verify b/tests/cn/gnu_types_compatible.c.verify new file mode 100644 index 000000000..e51cabdb4 --- /dev/null +++ b/tests/cn/gnu_types_compatible.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: f -- pass +[2/3]: g -- pass +[3/3]: main -- pass diff --git a/tests/cn/has_alloc_id.c.verify b/tests/cn/has_alloc_id.c.verify new file mode 100644 index 000000000..e51cabdb4 --- /dev/null +++ b/tests/cn/has_alloc_id.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: f -- pass +[2/3]: g -- pass +[3/3]: main -- pass diff --git a/tests/cn/has_alloc_id.error.c.verify b/tests/cn/has_alloc_id.error.c.verify new file mode 100644 index 000000000..288d8c3c6 --- /dev/null +++ b/tests/cn/has_alloc_id.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/has_alloc_id.error.c:9:30: error: Type error + /*@ assert (has_alloc_id(0u64)); @*/ + ^ +Expression '0'u64' has type 'u64'. +I expected it to have type 'pointer' because of tests/cn/has_alloc_id.error.c:9:17: + /*@ assert (has_alloc_id(0u64)); @*/ + ~~~~~~~~~~~~^~~~~~ diff --git a/tests/cn/has_alloc_id_ptr_eq.error.c.verify b/tests/cn/has_alloc_id_ptr_eq.error.c.verify new file mode 100644 index 000000000..75d9103df --- /dev/null +++ b/tests/cn/has_alloc_id_ptr_eq.error.c.verify @@ -0,0 +1,12 @@ +return code: 1 +tests/cn/has_alloc_id_ptr_eq.error.c:10:12: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + return p == q; + ~~^~~~ +[1/1]: f -- fail +tests/cn/has_alloc_id_ptr_eq.error.c:10:5: error: Unprovable constraint + return p == q; + ^~~~~~~~~~~~~~ +Constraint from tests/cn/has_alloc_id_ptr_eq.error.c:7:5: + return == 1i32; + ^~~~~~~~~~~~~~~ +State file: file:///tmp/state__has_alloc_id_ptr_eq.error.c__f.html diff --git a/tests/cn/has_alloc_id_ptr_eq2.error.c.verify b/tests/cn/has_alloc_id_ptr_eq2.error.c.verify new file mode 100644 index 000000000..70c6d12ac --- /dev/null +++ b/tests/cn/has_alloc_id_ptr_eq2.error.c.verify @@ -0,0 +1,12 @@ +return code: 1 +tests/cn/has_alloc_id_ptr_eq2.error.c:10:12: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + return p == q; + ~~^~~~ +[1/1]: f -- fail +tests/cn/has_alloc_id_ptr_eq2.error.c:10:5: error: Unprovable constraint + return p == q; + ^~~~~~~~~~~~~~ +Constraint from tests/cn/has_alloc_id_ptr_eq2.error.c:7:5: + return == 0i32; + ^~~~~~~~~~~~~~~ +State file: file:///tmp/state__has_alloc_id_ptr_eq2.error.c__f.html diff --git a/tests/cn/has_alloc_id_ptr_neq.c.verify b/tests/cn/has_alloc_id_ptr_neq.c.verify new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn/has_alloc_id_ptr_neq.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn/has_alloc_id_ptr_neq.error.c.verify b/tests/cn/has_alloc_id_ptr_neq.error.c.verify new file mode 100644 index 000000000..94131267d --- /dev/null +++ b/tests/cn/has_alloc_id_ptr_neq.error.c.verify @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: f -- fail +tests/cn/has_alloc_id_ptr_neq.error.c:11:5: error: Unprovable constraint + return p != q; + ^~~~~~~~~~~~~~ +Constraint from tests/cn/has_alloc_id_ptr_neq.error.c:8:5: + return == 0i32; + ^~~~~~~~~~~~~~~ +State file: file:///tmp/state__has_alloc_id_ptr_neq.error.c__f.html diff --git a/tests/cn/has_alloc_id_shift.c.verify b/tests/cn/has_alloc_id_shift.c.verify new file mode 100644 index 000000000..32acd623f --- /dev/null +++ b/tests/cn/has_alloc_id_shift.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: array_shift -- pass +[2/3]: member_shift -- pass +[3/3]: main -- pass diff --git a/tests/cn/implies.c.verify b/tests/cn/implies.c.verify new file mode 100644 index 000000000..02dc41acf --- /dev/null +++ b/tests/cn/implies.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: identity -- pass diff --git a/tests/cn/implies2.error.c.verify b/tests/cn/implies2.error.c.verify new file mode 100644 index 000000000..448c8e393 --- /dev/null +++ b/tests/cn/implies2.error.c.verify @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: identity -- fail +tests/cn/implies2.error.c:4:9: error: Unprovable constraint + /*@ assert((x == 0i32) implies (y == 1i32));@*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Constraint from tests/cn/implies2.error.c:4:9: + /*@ assert((x == 0i32) implies (y == 1i32));@*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__implies2.error.c__identity.html diff --git a/tests/cn/implies3.error.c.verify b/tests/cn/implies3.error.c.verify new file mode 100644 index 000000000..2d7b1bede --- /dev/null +++ b/tests/cn/implies3.error.c.verify @@ -0,0 +1,5 @@ +return code: 1 +tests/cn/implies3.error.c:1:1: error: proc/fun makes inconsistent assumptions +int foo () +~~~~^~~~~~ +State file: file:///tmp/state__implies3.error.c.html diff --git a/tests/cn/implies_associativity.c.verify b/tests/cn/implies_associativity.c.verify new file mode 100644 index 000000000..7213715e9 --- /dev/null +++ b/tests/cn/implies_associativity.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: foo -- pass diff --git a/tests/cn/implies_precedence.c.verify b/tests/cn/implies_precedence.c.verify new file mode 100644 index 000000000..7213715e9 --- /dev/null +++ b/tests/cn/implies_precedence.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: foo -- pass diff --git a/tests/cn/incomplete_match.error.c.verify b/tests/cn/incomplete_match.error.c.verify new file mode 100644 index 000000000..96ce317d7 --- /dev/null +++ b/tests/cn/incomplete_match.error.c.verify @@ -0,0 +1,4 @@ +return code: 1 +tests/cn/incomplete_match.error.c:9:3: error: Incomplete pattern + match t { + ^~~~~~~~~ diff --git a/tests/cn/inconsistent.error.c.verify b/tests/cn/inconsistent.error.c.verify new file mode 100644 index 000000000..d0a2acb96 --- /dev/null +++ b/tests/cn/inconsistent.error.c.verify @@ -0,0 +1,5 @@ +return code: 1 +tests/cn/inconsistent.error.c:1:1: error: proc/fun makes inconsistent assumptions +void f() +~~~~~^~~ +State file: file:///tmp/state__inconsistent.error.c.html diff --git a/tests/cn/inconsistent2.error.c.verify b/tests/cn/inconsistent2.error.c.verify new file mode 100644 index 000000000..845303060 --- /dev/null +++ b/tests/cn/inconsistent2.error.c.verify @@ -0,0 +1,11 @@ +return code: 1 +tests/cn/inconsistent2.error.c:9:19: warning: 'each' expects a 'u64', but 'i' with type 'i32' was provided. This will become an error in the future. +/*@ requires take f1 = each(i32 i; 0i32 <= i && i <= 0i32) { False(p + i, i) }; + ^ +tests/cn/inconsistent2.error.c:12:22: warning: 'extract' expects a 'u64', but '0'i32' with type 'i32' was provided. This will become an error in the future. + /*@ extract False, 0i32; @*/ + ^ +tests/cn/inconsistent2.error.c:8:1: error: return type makes inconsistent assumptions +void f (int *p) +~~~~~^~~~~~~~~~ +State file: file:///tmp/state__inconsistent2.error.c.html diff --git a/tests/cn/inconsistent3.error.c.verify b/tests/cn/inconsistent3.error.c.verify new file mode 100644 index 000000000..b576af0bd --- /dev/null +++ b/tests/cn/inconsistent3.error.c.verify @@ -0,0 +1,5 @@ +return code: 1 +tests/cn/inconsistent3.error.c:1:1: error: return type makes inconsistent assumptions +void f (int *p) +~~~~~^~~~~~~~~~ +State file: file:///tmp/state__inconsistent3.error.c.html diff --git a/tests/cn/increments.c.verify b/tests/cn/increments.c.verify new file mode 100644 index 000000000..6da074677 --- /dev/null +++ b/tests/cn/increments.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: direct -- pass +[2/2]: indirect -- pass diff --git a/tests/cn/int_to_ptr.c.verify b/tests/cn/int_to_ptr.c.verify new file mode 100644 index 000000000..8dfd8221e --- /dev/null +++ b/tests/cn/int_to_ptr.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: cast -- pass +[2/2]: main -- pass diff --git a/tests/cn/int_to_ptr.error.c.verify b/tests/cn/int_to_ptr.error.c.verify new file mode 100644 index 000000000..d93ed004a --- /dev/null +++ b/tests/cn/int_to_ptr.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: cast -- pass +[2/2]: main -- fail +tests/cn/int_to_ptr.error.c:16:12: error: Missing resource for reading + return *p == 0; + ^~ +Resource needed: Owned(call_cast0.return) +State file: file:///tmp/state__int_to_ptr.error.c__main.html diff --git a/tests/cn/left_shift_const.c.verify b/tests/cn/left_shift_const.c.verify new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn/left_shift_const.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn/lexer_hack_parse.error.c.verify b/tests/cn/lexer_hack_parse.error.c.verify new file mode 100644 index 000000000..e0b0ddb05 --- /dev/null +++ b/tests/cn/lexer_hack_parse.error.c.verify @@ -0,0 +1,5 @@ +return code: 2 +tests/cn/lexer_hack_parse.error.c:14:13: error: unexpected token after '>' and before 'Cons' +parsing "match_case": seen "pattern EQ GT", expecting "LBRACE expr RBRACE" + Cons {} + ^~~~ diff --git a/tests/cn/list_literal_type.error.c.verify b/tests/cn/list_literal_type.error.c.verify new file mode 100644 index 000000000..61ce79877 --- /dev/null +++ b/tests/cn/list_literal_type.error.c.verify @@ -0,0 +1,5 @@ +return code: 2 +tests/cn/list_literal_type.error.c:3:15: error: unexpected token after 'list' and before '<' +Please add error message for state 1869 to parsers/c/c_parser_error.messages +function (list) nonempty_list() { + ^ diff --git a/tests/cn/list_rev01.c.verify b/tests/cn/list_rev01.c.verify new file mode 100644 index 000000000..0c40cadc3 --- /dev/null +++ b/tests/cn/list_rev01.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: rev_list -- pass diff --git a/tests/cn/magic_comment_not_closed.c.verify b/tests/cn/magic_comment_not_closed.c.verify new file mode 100644 index 000000000..344e1e068 --- /dev/null +++ b/tests/cn/magic_comment_not_closed.c.verify @@ -0,0 +1,5 @@ +return code: 0 +tests/cn/magic_comment_not_closed.c:1:19: warning: magic comment syntax at open but not close +/*@ assert(true); */ + ^ +[1/1]: main -- pass diff --git a/tests/cn/map_set.error.c.verify b/tests/cn/map_set.error.c.verify new file mode 100644 index 000000000..cdb400495 --- /dev/null +++ b/tests/cn/map_set.error.c.verify @@ -0,0 +1,4 @@ +return code: 2 +tests/cn/map_set.error.c:3:24: error: the type name `bool' is not declared +function (map) write_to_012(integer foo, map my_map) { + ^ diff --git a/tests/cn/mask_ptr.c.verify b/tests/cn/mask_ptr.c.verify new file mode 100644 index 000000000..297a9e53c --- /dev/null +++ b/tests/cn/mask_ptr.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: foo_integer -- pass +[2/2]: foo -- pass diff --git a/tests/cn/match.c.verify b/tests/cn/match.c.verify new file mode 100644 index 000000000..941d1e7b0 --- /dev/null +++ b/tests/cn/match.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: check_foo -- pass +[2/2]: main -- pass diff --git a/tests/cn/max_min_consts.c.verify b/tests/cn/max_min_consts.c.verify new file mode 100644 index 000000000..164a4a72d --- /dev/null +++ b/tests/cn/max_min_consts.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: check_cn_max_min_consts -- pass +[2/2]: main -- pass diff --git a/tests/cn/max_pipes.error.c.verify b/tests/cn/max_pipes.error.c.verify new file mode 100644 index 000000000..2dcac92d8 --- /dev/null +++ b/tests/cn/max_pipes.error.c.verify @@ -0,0 +1,45 @@ +return code: 1 +[1/11]: f_22 -- pass +[2/11]: f_32 -- fail +[3/11]: _OSSwapInt16 -- fail +[4/11]: _OSSwapInt32 -- fail +[5/11]: OSReadSwapInt16 -- fail +[6/11]: OSReadSwapInt32 -- fail +[7/11]: OSReadSwapInt64 -- fail +[8/11]: f_61 -- pass +[9/11]: f_73 -- fail +[10/11]: f_91 -- pass +[11/11]: f_103 -- pass +tests/cn/max_pipes.error.c:37:1: error: Undefined behaviour +static uint8_t f_32() { +~~~~~~~~~~~~~~~^~~~~~~~ +the value of a non-void function that ended without a return statement is used +State file: file:///tmp/state__max_pipes.error.c__f_32.html +tests/cn/max_pipes.error.c:58:1: error: Undefined behaviour +uint16_t _OSSwapInt16(_data) {} +~~~~~~~~~^~~~~~~~~~~~~~~~~~~~~~ +the value of a non-void function that ended without a return statement is used +State file: file:///tmp/state__max_pipes.error.c___OSSwapInt16.html +tests/cn/max_pipes.error.c:59:40: error: Unknown function 'bswap32_proxy' +uint32_t _OSSwapInt32(_data) { _data = __builtin_bswap32(_data); } + ^~~~~~~~~~~~~~~~~ +tests/cn/max_pipes.error.c:63:1: error: Undefined behaviour +uint16_t OSReadSwapInt16(_offset) {} +~~~~~~~~~^~~~~~~~~~~~~~~~~~~~~~~~~~~ +the value of a non-void function that ended without a return statement is used +State file: file:///tmp/state__max_pipes.error.c__OSReadSwapInt16.html +tests/cn/max_pipes.error.c:64:1: error: Undefined behaviour +uint32_t OSReadSwapInt32() {} +~~~~~~~~~^~~~~~~~~~~~~~~~~~~~ +the value of a non-void function that ended without a return statement is used +State file: file:///tmp/state__max_pipes.error.c__OSReadSwapInt32.html +tests/cn/max_pipes.error.c:65:1: error: Undefined behaviour +uint64_t OSReadSwapInt64() {} +~~~~~~~~~^~~~~~~~~~~~~~~~~~~~ +the value of a non-void function that ended without a return statement is used +State file: file:///tmp/state__max_pipes.error.c__OSReadSwapInt64.html +tests/cn/max_pipes.error.c:82:17: error: `&(&&d_47[(u64)0'i32])[(u64)O_c1]` out of bounds + switch (d_47[c][s]) { + ^~~~~~~ +(UB missing short message): UB_CERB004_unspecified__pointer_add +State file: file:///tmp/state__max_pipes.error.c__f_73.html diff --git a/tests/cn/memcpy.c.verify b/tests/cn/memcpy.c.verify new file mode 100644 index 000000000..c354d7b31 --- /dev/null +++ b/tests/cn/memcpy.c.verify @@ -0,0 +1,26 @@ +return code: 0 +tests/cn/memcpy.c:3:19: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. +/*@ requires take dstStart = each (i32 j; 0i32 <= j && j < n) + ^ +tests/cn/memcpy.c:5:19: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take srcStart = each (i32 j; 0i32 <= j && j < n) + ^ +tests/cn/memcpy.c:7:18: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + ensures take dstEnd = each (i32 j; 0i32 <= j && j < n) + ^ +tests/cn/memcpy.c:9:18: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take srcEnd = each (i32 j; 0i32 <= j && j < n) + ^ +tests/cn/memcpy.c:17:16: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + /*@ inv take dstInv = each (i32 j; 0i32 <= j && j < n) + ^ +tests/cn/memcpy.c:19:16: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take srcInv = each (i32 j; 0i32 <= j && j < n) + ^ +tests/cn/memcpy.c:28:30: warning: 'extract' expects a 'u64', but '(i32)read_&i0' with type 'i32' was provided. This will become an error in the future. + /*@ extract Owned, (i32)i; @*/ + ^~~~~~ +tests/cn/memcpy.c:29:9: warning: nothing instantiated + /*@ instantiate good, (i32)i; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +[1/1]: naive_memcpy -- pass diff --git a/tests/cn/mergesort.c b/tests/cn/mergesort.c index 3c7a2e02c..07341a1b5 100644 --- a/tests/cn/mergesort.c +++ b/tests/cn/mergesort.c @@ -1,172 +1,246 @@ -struct int_list { - int head; - struct int_list* tail; +struct node { + int value; + struct node *next; }; /*@ -datatype seq { - Seq_Nil {}, - Seq_Cons {i32 head, datatype seq tail} +datatype list { + Nil {}, + Cons {i32 head, list tail} } -predicate (datatype seq) IntList(pointer p) { +predicate (list) List(pointer p) { if (is_null(p)) { - return Seq_Nil{}; + return Nil {}; } else { - take H = Owned(p); - assert (is_null(H.tail) || !addr_eq(H.tail, NULL)); - take tl = IntList(H.tail); - return (Seq_Cons { head: H.head, tail: tl }); + take node = Owned(p); + take tl = List(node.next); + return (Cons { head: node.value, tail: tl }); } } +@*/ -function [rec] ({datatype seq fst, datatype seq snd}) cn_split(datatype seq xs) -{ +/*@ +function [rec] ({list fst, list snd}) cn_split(list xs) { match xs { - Seq_Nil {} => { - {fst: Seq_Nil{}, snd: Seq_Nil{}} + Nil {} => { + {fst: Nil {}, snd: Nil {}} } - Seq_Cons {head: h1, tail: Seq_Nil{}} => { - {fst: Seq_Nil{}, snd: xs} + Cons {head: h1, tail: Nil {}} => { + {fst: xs, snd: Nil {}} } - Seq_Cons {head: h1, tail: Seq_Cons {head : h2, tail : tl2 }} => { + Cons {head: h1, tail: Cons {head : h2, tail : tl2 }} => { let P = cn_split(tl2); - {fst: Seq_Cons { head: h1, tail: P.fst}, - snd: Seq_Cons { head: h2, tail: P.snd}} + {fst: Cons { head: h1, tail: P.fst}, + snd: Cons { head: h2, tail: P.snd}} } } } -function [rec] (datatype seq) cn_merge(datatype seq xs, datatype seq ys) { +function [rec] (list) cn_merge(list xs, list ys) { match xs { - Seq_Nil {} => { ys } - Seq_Cons {head: x, tail: xs1} => { - match ys { - Seq_Nil {} => { xs } - Seq_Cons{ head: y, tail: ys1} => { - let tail = cn_merge(xs1, ys1); - (x < y) ? - (Seq_Cons{ head: x, tail: Seq_Cons {head: y, tail: tail}}) - : (Seq_Cons{ head: y, tail: Seq_Cons {head: x, tail: tail}}) - } - } + Nil {} => { + ys + } + Cons {head: x, tail: xs_} => { + match ys { + Nil {} => { + xs + } + Cons {head: y, tail: ys_} => { + if (x <= y) { + Cons {head: x, tail: cn_merge(xs_, ys)} + } else { + Cons {head: y, tail: cn_merge(xs, ys_)} + } + } } + } } } -function [rec] (datatype seq) cn_mergesort(datatype seq xs) { +function [rec] (list) cn_mergesort(list xs) { match xs { - Seq_Nil{} => { xs } - Seq_Cons{head: x, tail: Seq_Nil{}} => { xs } - Seq_Cons{head: x, tail: Seq_Cons{head: y, tail: zs}} => { - let P = cn_split(xs); - let L1 = cn_mergesort(P.fst); - let L2 = cn_mergesort(P.snd); - cn_merge(L1, L2) - } + Nil {} => { + xs + } + Cons {head: x, tail: Nil {}} => { + xs + } + Cons {head: x, tail: Cons {head: y, tail: zs}} => { + let P = cn_split(xs); + let L1 = cn_mergesort(P.fst); + let L2 = cn_mergesort(P.snd); + cn_merge(L1, L2) + } + } +} + +function (boolean) smaller (i32 head, list xs) { + match xs { + Nil {} => { + true } + Cons {head : x, tail : _} => { + head <= x + } + } +} + +function [rec] (boolean) is_sorted(list xs) { + match xs { + Nil {} => { + true + } + Cons {head: head, tail: tail} => { + smaller (head, tail) && is_sorted(tail) + } + } +} + +function (list) tl (list xs) { + match xs { + Nil {} => { + Nil {} + } + Cons {head : _, tail : tail} => { + tail + } + } } @*/ -struct int_list_pair { - struct int_list* fst; - struct int_list* snd; +struct node_pair { + struct node *fst; + struct node *snd; }; -struct int_list_pair split(struct int_list *xs) -/*@ requires is_null(xs) || !addr_eq(xs, NULL); @*/ -/*@ requires take Xs = IntList(xs); @*/ -/*@ ensures take Ys = IntList(return.fst); @*/ -/*@ ensures take Zs = IntList(return.snd); @*/ -/*@ ensures is_null(return.fst) || !addr_eq(return.fst, NULL); @*/ -/*@ ensures is_null(return.snd) || !addr_eq(return.snd, NULL); @*/ -/*@ ensures {fst: Ys, snd: Zs} == cn_split(Xs); @*/ +struct node_pair split(struct node *xs) +/*@ requires take Xs = List(xs); + ensures take Ys = List(return.fst); + ensures take Zs = List(return.snd); + ensures {fst: Ys, snd: Zs} == cn_split(Xs); @*/ { + /*@ unfold cn_split(Xs); @*/ if (xs == 0) { - /*@ unfold cn_split(Xs); @*/ - struct int_list_pair r = {.fst = 0, .snd = 0}; + struct node_pair r = {.fst = 0, .snd = 0}; return r; } else { - struct int_list *cdr = xs -> tail; + struct node *cdr = xs->next; if (cdr == 0) { - /*@ unfold cn_split(Xs); @*/ - struct int_list_pair r = {.fst = 0, .snd = xs}; + struct node_pair r = {.fst = xs, .snd = 0}; return r; } else { - /*@ unfold cn_split(Xs); @*/ - struct int_list_pair p = split(cdr->tail); - xs->tail = p.fst; - cdr->tail = p.snd; - struct int_list_pair r = {.fst = xs, .snd = cdr}; + struct node_pair p = split(cdr->next); + xs->next = p.fst; + cdr->next = p.snd; + struct node_pair r = {.fst = xs, .snd = cdr}; return r; } } } -struct int_list* merge(struct int_list *xs, struct int_list *ys) -/*@ requires is_null(xs) || !addr_eq(xs, NULL); @*/ -/*@ requires is_null(ys) || !addr_eq(ys, NULL); @*/ -/*@ requires take Xs = IntList(xs); @*/ -/*@ requires take Ys = IntList(ys); @*/ -/*@ ensures is_null(return) || !addr_eq(return, NULL); @*/ -/*@ ensures take Zs = IntList(return); @*/ -/*@ ensures Zs == cn_merge(Xs, Ys); @*/ +struct node *merge(struct node *xs, struct node *ys) +/*@ requires take Xs = List(xs); + requires take Ys = List(ys); + ensures take Zs = List(return); + ensures Zs == cn_merge(Xs, Ys); @*/ { + /*@ unfold cn_merge(Xs, Ys); @*/ if (xs == 0) { - /*@ unfold cn_merge(Xs, Ys); @*/ return ys; + } else if (ys == 0) { + return xs; + } else if (xs->value <= ys->value) { + xs->next = merge(xs->next, ys); + return xs; } else { - /*@ unfold cn_merge(Xs, Ys); @*/ - if (ys == 0) { - /*@ unfold cn_merge(Xs, Ys); @*/ - return xs; - } else { - /*@ unfold cn_merge(Xs, Ys); @*/ - struct int_list *zs = merge(xs->tail, ys->tail); - if (xs->head < ys->head) { - xs->tail = ys; - ys->tail = zs; - return xs; - } else { - ys->tail = xs; - xs->tail = zs; - return ys; - } - } + ys->next = merge(xs, ys->next); + return ys; } } -struct int_list* naive_mergesort(struct int_list *xs) -/*@ requires is_null(xs) || !addr_eq(xs, NULL); @*/ -/*@ requires take Xs = IntList(xs); @*/ -/*@ ensures take Ys = IntList(return); @*/ -/*@ ensures is_null(return) || !addr_eq(return, NULL); @*/ -/*@ ensures Ys == cn_mergesort(Xs); @*/ +struct node *naive_mergesort(struct node *xs) +/*@ requires take Xs = List(xs); + ensures take Ys = List(return); + ensures Ys == cn_mergesort(Xs); @*/ { + /*@ unfold cn_mergesort(Xs); @*/ if (xs == 0) { - /*@ unfold cn_mergesort(Xs); @*/ + return xs; + } else if (xs->next == 0) { return xs; } else { - struct int_list *tail = xs->tail; - if (tail == 0) { - /*@ unfold cn_mergesort(Xs); @*/ - return xs; - } else { - /*@ unfold cn_mergesort(Xs); @*/ - struct int_list_pair p = split(xs); - p.fst = naive_mergesort(p.fst); - p.snd = naive_mergesort(p.snd); - return merge(p.fst, p.snd); - } + struct node_pair p = split(xs); + p.fst = naive_mergesort(p.fst); + p.snd = naive_mergesort(p.snd); + return merge(p.fst, p.snd); } } + + + int main(void) /*@ trusted; @*/ { - struct int_list i3 = {.head = 3, .tail = 0}; - struct int_list i2 = {.head = 4, .tail = &i3}; - struct int_list i1 = {.head = 2, .tail = &i2}; + struct node i3 = {.value = 3, .next = 0}; + struct node i2 = {.value = 4, .next = &i3}; + struct node i1 = {.value = 2, .next = &i2}; - struct int_list *sorted_i1 = naive_mergesort(&i1); + struct node *sorted_i1 = naive_mergesort(&i1); +} + + + + + +void prove_merge_sorted(struct node *p, struct node *q) +/*@ requires take xs_in = List(p); + take ys_in = List(q); + is_sorted(xs_in); + is_sorted(ys_in); + let merged = cn_merge(xs_in, ys_in); + ensures take xs_out = List(p); + take ys_out = List(q); + xs_out == xs_in && ys_out == ys_in; + is_sorted(merged); +@*/ +{ + /* Unfold the definition of `merged`. */ + /*@ unfold cn_merge(xs_in, ys_in); @*/ + + /* If either list is empty, cn_merge just picks the other, which is + sorted by assumption, so nothing left to do. */ + if (p == 0 || q == 0) { + return; + } + /* For non-empty lists, cn_merge picks the smaller head and merges + the rest. */ + else { + /* If `xs_in` has the smaller head, it merges `tl(xs_in)` with + `ys_in`. */ + if (p->value <= q->value) { + /* By induction hypothesis (IH) `cn_merge(tl(xs_in), ys_in))` is + sorted. To "apply" IH, expand the definition of + `is_sorted(xs_in)` to prove `is_sorted(tl(xs_in))`. */ + /*@ unfold is_sorted(xs_in); @*/ + prove_merge_sorted(p->next, q); + /* By definition of `cn_merge(tl(xs_in), ys_in)`, that merged + list starts with the minimum of either head, ... */ + /*@ unfold cn_merge(tl(xs_in), ys_in); @*/ + /* ... so that list with `hd(xs_in)` cons'ed on is also + sorted. @*/ + /*@ unfold is_sorted(merged); @*/ + return; + } + else { + /* This is symmetric to the proof above. */ + /*@ unfold is_sorted(ys_in); @*/ + prove_merge_sorted(p, q->next); + /*@ unfold cn_merge(xs_in, tl(ys_in)); @*/ + /*@ unfold is_sorted(merged); @*/ + return; + } + } } diff --git a/tests/cn/mergesort.c.verify b/tests/cn/mergesort.c.verify new file mode 100644 index 000000000..5278ce591 --- /dev/null +++ b/tests/cn/mergesort.c.verify @@ -0,0 +1,5 @@ +return code: 0 +[1/4]: split -- pass +[2/4]: merge -- pass +[3/4]: naive_mergesort -- pass +[4/4]: prove_merge_sorted -- pass diff --git a/tests/cn/mergesort_alt.c b/tests/cn/mergesort_alt.c new file mode 100644 index 000000000..af2d81537 --- /dev/null +++ b/tests/cn/mergesort_alt.c @@ -0,0 +1,262 @@ +struct node { + int value; + struct node *next; +}; + +typedef struct node * ilist; + +/*@ +datatype list { + Nil {}, + Cons {i32 head, list tail} +} + +predicate (list) List(pointer p) { + if (is_null(p)) { + return Nil {}; + } else { + take node = Owned(p); + take tl = List(node.next); + return (Cons { head: node.value, tail: tl }); + } +} + +predicate (list) ListP(pointer p) { + take l = Owned(p); + take xs = List(l); + return xs; +} +@*/ + +/*@ +function [rec] ({list fst, list snd}) cn_split(list xs) { + match xs { + Nil {} => { + {fst: Nil {}, snd: Nil {}} + } + Cons {head: h1, tail: Nil {}} => { + {fst: xs, snd: Nil {}} + } + Cons {head: h1, tail: Cons {head : h2, tail : tl2 }} => { + let P = cn_split(tl2); + {fst: Cons { head: h1, tail: P.fst}, + snd: Cons { head: h2, tail: P.snd}} + } + } +} + +function [rec] (list) cn_merge(list xs, list ys) { + match xs { + Nil {} => { + ys + } + Cons {head: x, tail: xs_} => { + match ys { + Nil {} => { + xs + } + Cons {head: y, tail: ys_} => { + if (x <= y) { + Cons {head: x, tail: cn_merge(xs_, ys)} + } else { + Cons {head: y, tail: cn_merge(xs, ys_)} + } + } + } + } + } +} + +function [rec] (list) cn_mergesort(list xs) { + match xs { + Nil {} => { + xs + } + Cons {head: x, tail: Nil {}} => { + xs + } + Cons {head: x, tail: Cons {head: y, tail: zs}} => { + let P = cn_split(xs); + let L1 = cn_mergesort(P.fst); + let L2 = cn_mergesort(P.snd); + cn_merge(L1, L2) + } + } +} + +function (boolean) smaller (i32 head, list xs) { + match xs { + Nil {} => { + true + } + Cons {head : x, tail : _} => { + head <= x + } + } +} + +function [rec] (boolean) is_sorted(list xs) { + match xs { + Nil {} => { + true + } + Cons {head: head, tail: tail} => { + smaller (head, tail) && is_sorted(tail) + } + } +} + +function (list) tl (list xs) { + match xs { + Nil {} => { + Nil {} + } + Cons {head : _, tail : tail} => { + tail + } + } +} +@*/ + +ilist split(ilist xs) +/*@ requires take Xs = List(xs); + ensures take Ys = List(xs); + ensures take Zs = List(return); + ensures {fst: Ys, snd: Zs} == cn_split(Xs); +@*/ +{ + /*@ unfold cn_split(Xs); @*/ + if (xs == 0 || xs->next == 0) { + return 0; + } else { + struct node *cdr = xs->next; + ilist ys = split(cdr->next); + xs->next = cdr->next; + cdr->next = ys; + return cdr; + } +} + + +void prove_merge_sorted(struct node *p, struct node *q) +/*@ requires take xs_in = List(p); + take ys_in = List(q); + is_sorted(xs_in); + is_sorted(ys_in); + let merged = cn_merge(xs_in, ys_in); + ensures take xs_out = List(p); + take ys_out = List(q); + xs_out == xs_in && ys_out == ys_in; + is_sorted(merged); +@*/ +{ + /* Unfold the definition of `merged`. */ + /*@ unfold cn_merge(xs_in, ys_in); @*/ + + /* If either list is empty, cn_merge just picks the other, which is + sorted by assumption, so nothing left to do. */ + if (p == 0 || q == 0) { + return; + } + /* For non-empty lists, cn_merge picks the smaller head and merges + the rest. */ + else { + /* If `xs_in` has the smaller head, it merges `tl(xs_in)` with + `ys_in`. */ + if (p->value <= q->value) { + /* By induction hypothesis (IH) `cn_merge(tl(xs_in), ys_in))` is + sorted. To "apply" IH, expand the definition of + `is_sorted(xs_in)` to prove `is_sorted(tl(xs_in))`. */ + /*@ unfold is_sorted(xs_in); @*/ + prove_merge_sorted(p->next, q); + /* By definition of `cn_merge(tl(xs_in), ys_in)`, that merged + list starts with the minimum of either head, ... */ + /*@ unfold cn_merge(tl(xs_in), ys_in); @*/ + /* ... so that list with `hd(xs_in)` cons'ed on is also + sorted. @*/ + /*@ unfold is_sorted(merged); @*/ + return; + } + else { + /* This is symmetric to the proof above. */ + /*@ unfold is_sorted(ys_in); @*/ + prove_merge_sorted(p, q->next); + /*@ unfold cn_merge(xs_in, tl(ys_in)); @*/ + /*@ unfold is_sorted(merged); @*/ + return; + } + } +} + + +struct node *merge(struct node *xs, struct node *ys) +/*@ requires take Xs = List(xs); + requires take Ys = List(ys); + ensures take Zs = List(return); + ensures Zs == cn_merge(Xs, Ys); @*/ +{ + /*@ unfold cn_merge(Xs, Ys); @*/ + if (xs == 0) { + return ys; + } else if (ys == 0) { + return xs; + } else if (xs->value <= ys->value) { + xs->next = merge(xs->next, ys); + return xs; + } else { + ys->next = merge(xs, ys->next); + return ys; + } +} + +void naive_mergesort(ilist *p) +/*@ requires take xs_in = ListP(p); + let sorted = cn_mergesort(xs_in); + ensures take xs_out = ListP(p); + xs_out == sorted; + is_sorted(xs_out); +@*/ +{ + /*@ unfold cn_mergesort(xs_in); @*/ + /*@ unfold is_sorted(sorted); @*/ + /*@ unfold is_sorted(tl(sorted)); @*/ + ilist xs = *p; + if (xs != 0 && xs->next != 0) { + ilist ys = split(xs); + naive_mergesort(&xs); + naive_mergesort(&ys); + /*CN*/ prove_merge_sorted(xs, ys); + *p = merge(xs, ys); + return; + } +} + + + + +int main(void) +/*@ trusted; @*/ +{ + ilist xs; + struct node n1; + struct node n2; + struct node n3; + + n1.value = 1; + n2.value = 4; + n3.value = 3; + + xs = &n1; + n1.next = &n2; + n2.next = &n3; + n3.next = 0; + + naive_mergesort(&xs); +} + + + + + + + diff --git a/tests/cn/mergesort_alt.c.verify b/tests/cn/mergesort_alt.c.verify new file mode 100644 index 000000000..a0551bf04 --- /dev/null +++ b/tests/cn/mergesort_alt.c.verify @@ -0,0 +1,5 @@ +return code: 0 +[1/4]: split -- pass +[2/4]: prove_merge_sorted -- pass +[3/4]: merge -- pass +[4/4]: naive_mergesort -- pass diff --git a/tests/cn/merging_arrays.error.c.verify b/tests/cn/merging_arrays.error.c.verify new file mode 100644 index 000000000..35629d46a --- /dev/null +++ b/tests/cn/merging_arrays.error.c.verify @@ -0,0 +1,11 @@ +return code: 1 +[1/3]: half -- pass +[2/3]: whole -- pass +[3/3]: main -- fail +tests/cn/merging_arrays.error.c:25:5: error: Cannot satisfy request for resource for calling function whole. It requires merging multiple arrays. + whole(a); + ^~~~~~~~ +Resource needed: each(u64 i; 0'u64 <= i && i < 10'u64) +{Owned(&a + i * 4'u64)} + tests/cn/merging_arrays.error.c:14:10: (arg X) +State file: file:///tmp/state__merging_arrays.error.c__main.html diff --git a/tests/cn/missing_resource.error.c.verify b/tests/cn/missing_resource.error.c.verify new file mode 100644 index 000000000..a4434ee71 --- /dev/null +++ b/tests/cn/missing_resource.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/1]: f -- fail +tests/cn/missing_resource.error.c:11:3: error: Missing resource for returning + return x; + ^~~~~~~~~ +Resource needed: Owned(p) + tests/cn/missing_resource.error.c:9:18: (arg Resource_From_Nothing) +State file: file:///tmp/state__missing_resource.error.c__f.html diff --git a/tests/cn/missing_resource_indirect.error.c.verify b/tests/cn/missing_resource_indirect.error.c.verify new file mode 100644 index 000000000..fb819e684 --- /dev/null +++ b/tests/cn/missing_resource_indirect.error.c.verify @@ -0,0 +1,10 @@ +return code: 1 +[1/1]: f -- fail +tests/cn/missing_resource_indirect.error.c:18:3: error: Missing resource for returning + return x; + ^~~~~~~~~ +Resource needed: Owned_Wrapper(p) + tests/cn/missing_resource_indirect.error.c:16:18: (arg Resource_From_Nothing) + which requires: Owned(p) + tests/cn/missing_resource_indirect.error.c:7:8: (arg I) +State file: file:///tmp/state__missing_resource_indirect.error.c__f.html diff --git a/tests/cn/mod.c.verify b/tests/cn/mod.c.verify new file mode 100644 index 000000000..15f36f592 --- /dev/null +++ b/tests/cn/mod.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: mod -- pass diff --git a/tests/cn/mod_by_0.error.c.verify b/tests/cn/mod_by_0.error.c.verify new file mode 100644 index 000000000..015dcad77 --- /dev/null +++ b/tests/cn/mod_by_0.error.c.verify @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: mod -- fail +tests/cn/mod_by_0.error.c:6:12: error: Undefined behaviour + return x % y; + ~~^~~ +the value of the second operand of a '%' operator is zero (§6.5.5#5, sentence 2) +State file: file:///tmp/state__mod_by_0.error.c__mod.html diff --git a/tests/cn/mod_casting.c.verify b/tests/cn/mod_casting.c.verify new file mode 100644 index 000000000..15f36f592 --- /dev/null +++ b/tests/cn/mod_casting.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: mod -- pass diff --git a/tests/cn/mod_precedence.c.verify b/tests/cn/mod_precedence.c.verify new file mode 100644 index 000000000..07368938c --- /dev/null +++ b/tests/cn/mod_precedence.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: mod_no_parenthesis -- pass +[2/3]: multiply_then_mod -- pass +[3/3]: divide_multiply_mod_add_subtract -- pass diff --git a/tests/cn/mod_return_sign.error.c.verify b/tests/cn/mod_return_sign.error.c.verify new file mode 100644 index 000000000..5df0d50f0 --- /dev/null +++ b/tests/cn/mod_return_sign.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/mod_return_sign.error.c:7:27: error: Type error + ensures return == x % y; @*/ + ^ +Expression 'y' has type 'u32'. +I expected it to have type 'i32' because of tests/cn/mod_return_sign.error.c:7:23: + ensures return == x % y; @*/ + ^ diff --git a/tests/cn/mod_return_size.error.c.verify b/tests/cn/mod_return_size.error.c.verify new file mode 100644 index 000000000..f4f9fd2c4 --- /dev/null +++ b/tests/cn/mod_return_size.error.c.verify @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: different_size -- fail +tests/cn/mod_return_size.error.c:9:5: error: Unprovable constraint + return x % y; + ^~~~~~~~~~~~~ +Constraint from tests/cn/mod_return_size.error.c:7:13: + ensures return == x % (i32)y; @*/ + ^~~~~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__mod_return_size.error.c__different_size.html diff --git a/tests/cn/mod_with_constants.c.verify b/tests/cn/mod_with_constants.c.verify new file mode 100644 index 000000000..d1c740f4d --- /dev/null +++ b/tests/cn/mod_with_constants.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: x_mod_three -- pass +[2/3]: x_mod_neg_three -- pass +[3/3]: mod_first_operand_neg -- pass diff --git a/tests/cn/multifile/f.c.verify b/tests/cn/multifile/f.c.verify new file mode 100644 index 000000000..a330c9e78 --- /dev/null +++ b/tests/cn/multifile/f.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: test_c -- pass diff --git a/tests/cn/multifile/g.c.verify b/tests/cn/multifile/g.c.verify new file mode 100644 index 000000000..f5671beb8 --- /dev/null +++ b/tests/cn/multifile/g.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: g -- pass diff --git a/tests/cn/mutual_rec/build.sh b/tests/cn/mutual_rec/build.sh deleted file mode 100644 index c900c3c28..000000000 --- a/tests/cn/mutual_rec/build.sh +++ /dev/null @@ -1,6 +0,0 @@ - -set -ex -cn verify mutual_rec.c -cn verify --lemmata coq_lemmas/theories/Gen_Spec.v mutual_rec.c -make -C coq_lemmas - diff --git a/tests/cn/mutual_rec/coq_lemmas/Makefile b/tests/cn/mutual_rec/coq_lemmas/Makefile index b248d3425..c343861ff 100644 --- a/tests/cn/mutual_rec/coq_lemmas/Makefile +++ b/tests/cn/mutual_rec/coq_lemmas/Makefile @@ -1,8 +1,4 @@ - - - all: coq_makefile -f _CoqProject -o Makefile.coq - cn verify --lemmata theories/Gen_Spec.v ../mutual_rec.c + cn verify ../mutual_rec2.c --lemmata theories/Gen_Spec.v &> /dev/null make -f Makefile.coq - diff --git a/tests/cn/mutual_rec/coq_lemmas/_CoqProject b/tests/cn/mutual_rec/coq_lemmas/_CoqProject index 012738ab4..30ef14952 100644 --- a/tests/cn/mutual_rec/coq_lemmas/_CoqProject +++ b/tests/cn/mutual_rec/coq_lemmas/_CoqProject @@ -1,9 +1,6 @@ - -Q theories CN_Lemmas theories/CN_Lib.v theories/Gen_Spec.v theories/Setup.v theories/Inst_Spec.v - - diff --git a/tests/cn/mutual_rec/mutual_rec1.c.verify b/tests/cn/mutual_rec/mutual_rec1.c.verify new file mode 100644 index 000000000..f4787dbdf --- /dev/null +++ b/tests/cn/mutual_rec/mutual_rec1.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: walk_b_tree -- pass +[2/2]: walk_a_tree -- pass diff --git a/tests/cn/mutual_rec/mutual_rec2.c.verify b/tests/cn/mutual_rec/mutual_rec2.c.verify new file mode 100644 index 000000000..fbe1952af --- /dev/null +++ b/tests/cn/mutual_rec/mutual_rec2.c.verify @@ -0,0 +1,10 @@ +return code: 0 +[1/9]: a_tree_keys_node_lemma -- pass +[2/9]: b_tree_keys_node_lemma -- pass +[3/9]: a_tree_keys_node_concat_inc_lemma -- pass +[4/9]: a_tree_keys_node_concat_cons_inc_lemma -- pass +[5/9]: b_tree_keys_node_merge_inc_lemma -- pass +[6/9]: b_tree_keys_node_merge_flip_lemma -- pass +[7/9]: b_tree_keys_node_inc_inc_double_lemma -- pass +[8/9]: inc_b_tree -- pass +[9/9]: inc_a_tree -- pass diff --git a/tests/cn/mutual_rec/mutual_rec3.c.verify b/tests/cn/mutual_rec/mutual_rec3.c.verify new file mode 100644 index 000000000..a5b15c2d0 --- /dev/null +++ b/tests/cn/mutual_rec/mutual_rec3.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: predef_a_tree -- pass diff --git a/tests/cn/null_to_int.c.verify b/tests/cn/null_to_int.c.verify new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn/null_to_int.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn/offsetof_int_const.c b/tests/cn/offsetof_int_const.c new file mode 100644 index 000000000..24df04c7b --- /dev/null +++ b/tests/cn/offsetof_int_const.c @@ -0,0 +1,5 @@ +typedef struct a { + int b; + int c; +} a; +_Static_assert(offsetof(a, c) == sizeof(int), "no gap"); diff --git a/tests/cn/offsetof_int_const.c.verify b/tests/cn/offsetof_int_const.c.verify new file mode 100644 index 000000000..e1522bb41 --- /dev/null +++ b/tests/cn/offsetof_int_const.c.verify @@ -0,0 +1 @@ +return code: 0 diff --git a/tests/cn/ownership_at_negative_index.c.verify b/tests/cn/ownership_at_negative_index.c.verify new file mode 100644 index 000000000..8096aa2e7 --- /dev/null +++ b/tests/cn/ownership_at_negative_index.c.verify @@ -0,0 +1,11 @@ +return code: 0 +tests/cn/ownership_at_negative_index.c:2:19: warning: 'each' expects a 'u64', but 'i' with type 'i32' was provided. This will become an error in the future. +/*@ requires take vs = each(i32 i; i == -1i32) { Owned(array_shift(p,i)) }; + ^ +tests/cn/ownership_at_negative_index.c:3:18: warning: 'each' expects a 'u64', but 'i' with type 'i32' was provided. This will become an error in the future. + ensures take ws = each(i32 i; i == -1i32) { Owned(array_shift(p,i)) }; + ^ +tests/cn/ownership_at_negative_index.c:6:27: warning: 'extract' expects a 'u64', but '-1'i32' with type 'i32' was provided. This will become an error in the future. + /*@ extract Owned, -1i32; @*/ + ^~~~~ +[1/1]: f -- pass diff --git a/tests/cn/partial_init_bytes.error.c.verify b/tests/cn/partial_init_bytes.error.c.verify new file mode 100644 index 000000000..5a041cf85 --- /dev/null +++ b/tests/cn/partial_init_bytes.error.c.verify @@ -0,0 +1,16 @@ +return code: 1 +tests/cn/partial_init_bytes.error.c:5:9: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*@ to_bytes Block(p); @*/ + ^~~~~~~~ +tests/cn/partial_init_bytes.error.c:9:9: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*@ from_bytes Owned(p); @*/ + ^~~~~~~~~~ +tests/cn/partial_init_bytes.error.c:7:9: warning: extract: index added, no resources (yet) extracted. + /*@ extract Block, 2u64; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~ +[1/1]: main -- fail +tests/cn/partial_init_bytes.error.c:8:5: error: Missing resource for writing + p_char[2] = 0xff; + ~~~~~~~~~~^~~~~~ +Resource needed: Block(&&x[(u64)2'i32]) +State file: file:///tmp/state__partial_init_bytes.error.c__main.html diff --git a/tests/cn/pointer_to_char_cast.c.verify b/tests/cn/pointer_to_char_cast.c.verify new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn/pointer_to_char_cast.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn/pointer_to_char_cast.error.c.verify b/tests/cn/pointer_to_char_cast.error.c.verify new file mode 100644 index 000000000..e685c4f10 --- /dev/null +++ b/tests/cn/pointer_to_char_cast.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn/pointer_to_char_cast.error.c:5:5: error: integer value not representable at type char + (char)&x; + ^~~~~~~~ +Value: &x +State file: file:///tmp/state__pointer_to_char_cast.error.c__f.html diff --git a/tests/cn/pointer_to_int_cast.error.c.verify b/tests/cn/pointer_to_int_cast.error.c.verify new file mode 100644 index 000000000..a6bd3da7a --- /dev/null +++ b/tests/cn/pointer_to_int_cast.error.c.verify @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: f -- fail +tests/cn/pointer_to_int_cast.error.c:3:3: error: integer value not representable at type signed int + (int)&x; + ^~~~~~~ +Value: &x +State file: file:///tmp/state__pointer_to_int_cast.error.c__f.html diff --git a/tests/cn/pointer_to_intptr_t_cast.c.verify b/tests/cn/pointer_to_intptr_t_cast.c.verify new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn/pointer_to_intptr_t_cast.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn/pointer_to_uintptr_t_cast.c.verify b/tests/cn/pointer_to_uintptr_t_cast.c.verify new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn/pointer_to_uintptr_t_cast.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn/pointer_to_unsigned_int_cast.error.c.verify b/tests/cn/pointer_to_unsigned_int_cast.error.c.verify new file mode 100644 index 000000000..e4ba47f4f --- /dev/null +++ b/tests/cn/pointer_to_unsigned_int_cast.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn/pointer_to_unsigned_int_cast.error.c:3:3: error: integer value not representable at type unsigned int + (unsigned int)&x; + ^~~~~~~~~~~~~~~~ +Value: &x +State file: file:///tmp/state__pointer_to_unsigned_int_cast.error.c__f.html diff --git a/tests/cn/pred_def01.c.verify b/tests/cn/pred_def01.c.verify new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn/pred_def01.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn/pred_def02.c.verify b/tests/cn/pred_def02.c.verify new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn/pred_def02.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn/pred_def03.error.c.verify b/tests/cn/pred_def03.error.c.verify new file mode 100644 index 000000000..da77a0059 --- /dev/null +++ b/tests/cn/pred_def03.error.c.verify @@ -0,0 +1,5 @@ +return code: 1 +tests/cn/pred_def03.error.c:14:13: error: Unexpected member wrong + assert( tail.wrong ) ; + ~~~~^~~~~~ +the struct only has members len diff --git a/tests/cn/pred_def04.c.verify b/tests/cn/pred_def04.c.verify new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn/pred_def04.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn/previously_inconsistent_assumptions1.c.verify b/tests/cn/previously_inconsistent_assumptions1.c.verify new file mode 100644 index 000000000..e1522bb41 --- /dev/null +++ b/tests/cn/previously_inconsistent_assumptions1.c.verify @@ -0,0 +1 @@ +return code: 0 diff --git a/tests/cn/previously_inconsistent_assumptions2.c.verify b/tests/cn/previously_inconsistent_assumptions2.c.verify new file mode 100644 index 000000000..6e96ac104 --- /dev/null +++ b/tests/cn/previously_inconsistent_assumptions2.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: a -- pass diff --git a/tests/cn/ptr_diff.c.verify b/tests/cn/ptr_diff.c.verify new file mode 100644 index 000000000..d9cd1b4b3 --- /dev/null +++ b/tests/cn/ptr_diff.c.verify @@ -0,0 +1,6 @@ +return code: 0 +[1/5]: live_owned_footprint -- pass +[2/5]: live_owned_both -- pass +[3/5]: live_owned_one -- pass +[4/5]: live_alloc -- pass +[5/5]: main -- pass diff --git a/tests/cn/ptr_diff.error.c.verify b/tests/cn/ptr_diff.error.c.verify new file mode 100644 index 000000000..258b18d56 --- /dev/null +++ b/tests/cn/ptr_diff.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: live_owned_footprint -- fail +[2/2]: main -- pass +tests/cn/ptr_diff.error.c:13:10: error: Pointer `q` needs to be live for pointer difference + return q - p; + ~~^~~ +Need an Alloc or Owned in context with same allocation id +State file: file:///tmp/state__ptr_diff.error.c__live_owned_footprint.html diff --git a/tests/cn/ptr_diff2.c.verify b/tests/cn/ptr_diff2.c.verify new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn/ptr_diff2.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn/ptr_diff2.error.c.verify b/tests/cn/ptr_diff2.error.c.verify new file mode 100644 index 000000000..3ff6082c7 --- /dev/null +++ b/tests/cn/ptr_diff2.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn/ptr_diff2.error.c:4:10: error: Pointer `p` needs allocation ID + return p - 1; + ~~^~~ +(UB missing short message): UB_CERB004_unspecified__pointer_add +State file: file:///tmp/state__ptr_diff2.error.c__f.html diff --git a/tests/cn/ptr_relop.c.verify b/tests/cn/ptr_relop.c.verify new file mode 100644 index 000000000..d9cd1b4b3 --- /dev/null +++ b/tests/cn/ptr_relop.c.verify @@ -0,0 +1,6 @@ +return code: 0 +[1/5]: live_owned_footprint -- pass +[2/5]: live_owned_both -- pass +[3/5]: live_owned_one -- pass +[4/5]: live_alloc -- pass +[5/5]: main -- pass diff --git a/tests/cn/ptr_relop.error.c.verify b/tests/cn/ptr_relop.error.c.verify new file mode 100644 index 000000000..25a7777a1 --- /dev/null +++ b/tests/cn/ptr_relop.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: live_owned_footprint -- fail +[2/2]: main -- pass +tests/cn/ptr_relop.error.c:13:10: error: Pointer `q` needs to be live for pointer comparison + return q > p; + ~~^~~ +Need an Alloc or Owned in context with same allocation id +State file: file:///tmp/state__ptr_relop.error.c__live_owned_footprint.html diff --git a/tests/cn/record1.c.verify b/tests/cn/record1.c.verify new file mode 100644 index 000000000..3bd78b098 --- /dev/null +++ b/tests/cn/record1.c.verify @@ -0,0 +1,11 @@ +return code: 0 +tests/cn/record1.c:13:18: warning: Treating exponentiation 'power(2'i32 + , 31'i32 /* 0x1f */)' as uninterpreted. +/*@ requires x < power(2i32, 31i32) - 1i32; + ~~~~~^~~~~~~~~~~~~ +tests/cn/record1.c:14:18: warning: Treating exponentiation 'power(2'i32 + , 31'i32 /* 0x1f */)' as uninterpreted. + requires y < power(2i32, 31i32) - 1i32; @*/ + ~~~~~^~~~~~~~~~~~~ +[1/2]: incr_one -- pass +[2/2]: decr_one -- pass diff --git a/tests/cn/redundant_pattern.error.c.verify b/tests/cn/redundant_pattern.error.c.verify new file mode 100644 index 000000000..8ea88e37f --- /dev/null +++ b/tests/cn/redundant_pattern.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/redundant_pattern.error.c:12:9: error: Redundant pattern + Cons { head : head , tail : tail } => { head + sum(tail) } + ~~~~~^~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +covered by previous variable at tests/cn/redundant_pattern.error.c:11:9: + Nil => { 0 } + ^ +If this is meant to be an nullary constructor, write `Nil {}` instead diff --git a/tests/cn/reverse.c.verify b/tests/cn/reverse.c.verify new file mode 100644 index 000000000..57ed23668 --- /dev/null +++ b/tests/cn/reverse.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: reverse -- pass diff --git a/tests/cn/reverse.error.c.verify b/tests/cn/reverse.error.c.verify new file mode 100644 index 000000000..e2950369f --- /dev/null +++ b/tests/cn/reverse.error.c.verify @@ -0,0 +1,17 @@ +return code: 1 +[1/2]: reverse -- fail +[2/2]: main -- fail +tests/cn/reverse.error.c:106:7: error: Unprovable constraint + return cur; + ^~~~~~~~~~~ +Constraint from tests/cn/reverse.error.c:89:14: + L_ == rev(L); + ^~~~~~~~~~~~~ +State file: file:///tmp/state__reverse.error.c__reverse.html +tests/cn/reverse.error.c:124:3: error: Missing resource for de-allocating + return 0; + ^~~~~~~~~ +Resource needed: Block(&n3) + which requires: Block(&&n3->head) + other location (File "backend/cn/lib/resourceInference.ml", line 220, characters 31-38) (arg head) +State file: file:///tmp/state__reverse.error.c__main.html diff --git a/tests/cn/shift_diff_sz.c.verify b/tests/cn/shift_diff_sz.c.verify new file mode 100644 index 000000000..f865bbcda --- /dev/null +++ b/tests/cn/shift_diff_sz.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: test_shift_sizes -- pass +[2/2]: main -- pass diff --git a/tests/cn/simple_loop.c.verify b/tests/cn/simple_loop.c.verify new file mode 100644 index 000000000..f0bb8b696 --- /dev/null +++ b/tests/cn/simple_loop.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: simple_loop -- pass +[2/2]: main -- pass diff --git a/tests/cn/simplify_add_0.c.verify b/tests/cn/simplify_add_0.c.verify new file mode 100644 index 000000000..6288ba5e5 --- /dev/null +++ b/tests/cn/simplify_add_0.c.verify @@ -0,0 +1,4 @@ +return code: 0 +[1/3]: left_zero -- pass +[2/3]: right_zero -- pass +[3/3]: main -- pass diff --git a/tests/cn/simplify_array_shift.c.verify b/tests/cn/simplify_array_shift.c.verify new file mode 100644 index 000000000..07204a9f9 --- /dev/null +++ b/tests/cn/simplify_array_shift.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: IntQueue_pop -- pass diff --git a/tests/cn/solver_crash.error.c.verify b/tests/cn/solver_crash.error.c.verify new file mode 100644 index 000000000..d7e361c26 --- /dev/null +++ b/tests/cn/solver_crash.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn/solver_crash.error.c:13:10: error: Missing resource for reading + .y = str_inst.x + 3, + ~~~~~~~~^~ +Resource needed: Owned(&&str_inst->x) +State file: file:///tmp/state__solver_crash.error.c__f.html diff --git a/tests/cn/spec_after_curly_brace.error.c.verify b/tests/cn/spec_after_curly_brace.error.c.verify new file mode 100644 index 000000000..e0c32af55 --- /dev/null +++ b/tests/cn/spec_after_curly_brace.error.c.verify @@ -0,0 +1,6 @@ +return code: 1 +tests/cn/spec_after_curly_brace.error.c:3:3: error: unexpected token before 'ensures' +You're inside a function - so I'm expecting a CN statement. +Hint: these start with 'extract', 'instantiate', 'split_case', 'assert', 'print', 'apply'. + ensures return == 0i32; @*/ + ^~~~~~~ diff --git a/tests/cn/spec_null_shift.c.verify b/tests/cn/spec_null_shift.c.verify new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn/spec_null_shift.c.verify @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn/spec_null_shift.error.c.verify b/tests/cn/spec_null_shift.error.c.verify new file mode 100644 index 000000000..1e361860d --- /dev/null +++ b/tests/cn/spec_null_shift.error.c.verify @@ -0,0 +1,9 @@ +return code: 1 +[1/1]: f -- fail +tests/cn/spec_null_shift.error.c:5:1: error: Unprovable constraint +void f(int *p, int *q) +~~~~~^~~~~~~~~~~~~~~~~ +Constraint from tests/cn/spec_null_shift.error.c:13:5: + ptr_eq(x, NULL) || ptr_eq(y, NULL) || (u64) x == 1u64 || (u64) y == 2u64; + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__spec_null_shift.error.c__f.html diff --git a/tests/cn/split_case.c.verify b/tests/cn/split_case.c.verify new file mode 100644 index 000000000..bff6a3a20 --- /dev/null +++ b/tests/cn/split_case.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: __list_del -- pass diff --git a/tests/cn/struct_updates.error.c.verify b/tests/cn/struct_updates.error.c.verify new file mode 100644 index 000000000..b7ae30a16 --- /dev/null +++ b/tests/cn/struct_updates.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/struct_updates.error.c:9:11: error: Type error + { x : 0 , y: 0 , ..bar } + ^ +Expression '0' has type 'integer'. +I expected it to have type 'i32' because of tests/cn/struct_updates.error.c:9:24: + { x : 0 , y: 0 , ..bar } + ^ diff --git a/tests/cn/struct_updates2.error.c.verify b/tests/cn/struct_updates2.error.c.verify new file mode 100644 index 000000000..4007fe333 --- /dev/null +++ b/tests/cn/struct_updates2.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/struct_updates2.error.c:12:24: error: Type error + { x : 0 , y: 0 , ..bar } + ^ +Expression 'bar' has type '{integer x,integer y}'. +I expected it to have type 'struct' because of tests/cn/struct_updates2.error.c:12:5: + { x : 0 , y: 0 , ..bar } + ^~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn/swap.c.verify b/tests/cn/swap.c.verify new file mode 100644 index 000000000..ca8d58f18 --- /dev/null +++ b/tests/cn/swap.c.verify @@ -0,0 +1,20 @@ +return code: 0 +tests/cn/swap.c:4:9: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take pairStart = each (i32 j; 0i32 <= j && j < 2i32) {Owned(array_shift(pair, j))}; + ^ +tests/cn/swap.c:6:10: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take pairEnd = each (i32 j; 0i32 <= j && j < 2i32) {Owned(array_shift(pair, j))}; + ^ +tests/cn/swap.c:11:43: warning: 'extract' expects a 'u64', but '0'i32' with type 'i32' was provided. This will become an error in the future. + /*@ extract Owned, 0i32; @*/ + ^ +tests/cn/swap.c:12:43: warning: 'extract' expects a 'u64', but '1'i32' with type 'i32' was provided. This will become an error in the future. + /*@ extract Owned, 1i32; @*/ + ^ +tests/cn/swap.c:13:9: warning: nothing instantiated + /*@ instantiate good, 0i32; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tests/cn/swap.c:14:9: warning: nothing instantiated + /*@ instantiate good, 1i32; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +[1/1]: swap_pair -- pass diff --git a/tests/cn/swap_pair.c.verify b/tests/cn/swap_pair.c.verify new file mode 100644 index 000000000..e906bf33e --- /dev/null +++ b/tests/cn/swap_pair.c.verify @@ -0,0 +1,20 @@ +return code: 0 +tests/cn/swap_pair.c:4:10: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take pairStart = each (i32 j; 0i32 <= j && j < 2i32) {Owned(array_shift(pair_p, j))}; + ^ +tests/cn/swap_pair.c:6:10: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take pairEnd = each (i32 j; 0i32 <= j && j < 2i32) {Owned(array_shift(pair_p, j))}; + ^ +tests/cn/swap_pair.c:11:43: warning: 'extract' expects a 'u64', but '0'i32' with type 'i32' was provided. This will become an error in the future. + /*@ extract Owned, 0i32; @*/ + ^ +tests/cn/swap_pair.c:13:43: warning: 'extract' expects a 'u64', but '1'i32' with type 'i32' was provided. This will become an error in the future. + /*@ extract Owned, 1i32; @*/ + ^ +tests/cn/swap_pair.c:14:9: warning: nothing instantiated + /*@ instantiate good, 0i32; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tests/cn/swap_pair.c:16:9: warning: nothing instantiated + /*@ instantiate good, 1i32; @*/ + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +[1/1]: swap_pair -- pass diff --git a/tests/cn/tag_defs.c.verify b/tests/cn/tag_defs.c.verify new file mode 100644 index 000000000..a17639e1c --- /dev/null +++ b/tests/cn/tag_defs.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: f -- pass diff --git a/tests/cn/to_bytes.error.c.verify b/tests/cn/to_bytes.error.c.verify new file mode 100644 index 000000000..5e1d78e4f --- /dev/null +++ b/tests/cn/to_bytes.error.c.verify @@ -0,0 +1,8 @@ +return code: 1 +tests/cn/to_bytes.error.c:5:9: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*@ to_bytes Alloc(p); @*/ + ^~~~~~~~ +[1/1]: main -- fail +tests/cn/to_bytes.error.c:5:9: error: byte conversion only supports Owned/Block + /*@ to_bytes Alloc(p); @*/ + ^~~~~~~~~~~~~~~~~~ diff --git a/tests/cn/to_from_bytes_block.c.verify b/tests/cn/to_from_bytes_block.c.verify new file mode 100644 index 000000000..35b31a153 --- /dev/null +++ b/tests/cn/to_from_bytes_block.c.verify @@ -0,0 +1,10 @@ +return code: 0 +tests/cn/to_from_bytes_block.c:9:9: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*@ from_bytes Block(p); @*/ + ^~~~~~~~~~ +tests/cn/to_from_bytes_block.c:20:9: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*@ to_bytes Block(p); @*/ + ^~~~~~~~ +[1/3]: from_bytes -- pass +[2/3]: to_bytes -- pass +[3/3]: main -- pass diff --git a/tests/cn/to_from_bytes_owned.c.verify b/tests/cn/to_from_bytes_owned.c.verify new file mode 100644 index 000000000..3e6df251b --- /dev/null +++ b/tests/cn/to_from_bytes_owned.c.verify @@ -0,0 +1,8 @@ +return code: 0 +tests/cn/to_from_bytes_owned.c:5:9: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*@ to_bytes Owned(p); @*/ + ^~~~~~~~ +tests/cn/to_from_bytes_owned.c:9:9: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*@ from_bytes Owned(p); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn/tree16/as_auto_mutual_dt/tree16.error.c.verify b/tests/cn/tree16/as_auto_mutual_dt/tree16.error.c.verify new file mode 100644 index 000000000..321f77e62 --- /dev/null +++ b/tests/cn/tree16/as_auto_mutual_dt/tree16.error.c.verify @@ -0,0 +1,5 @@ +return code: 2 +tests/cn/tree16/as_auto_mutual_dt/tree16.error.c:30:21: error: unexpected token after 'list' and before '<' +Please add error message for state 1012 to parsers/c/c_parser_error.messages + Node {i32 v, list children} + ^ diff --git a/tests/cn/tree16/as_mutual_dt/coq_lemmas/Makefile b/tests/cn/tree16/as_mutual_dt/coq_lemmas/Makefile index 64c061784..cff60588a 100644 --- a/tests/cn/tree16/as_mutual_dt/coq_lemmas/Makefile +++ b/tests/cn/tree16/as_mutual_dt/coq_lemmas/Makefile @@ -1,8 +1,4 @@ - - - all: coq_makefile -f _CoqProject -o Makefile.coq - cn verify --lemmata theories/Gen_Spec.v ../tree16.c + cn verify ../tree16.c --lemmata theories/Gen_Spec.v &> /dev/null make -f Makefile.coq - diff --git a/tests/cn/tree16/as_mutual_dt/coq_lemmas/_CoqProject b/tests/cn/tree16/as_mutual_dt/coq_lemmas/_CoqProject index 012738ab4..30ef14952 100644 --- a/tests/cn/tree16/as_mutual_dt/coq_lemmas/_CoqProject +++ b/tests/cn/tree16/as_mutual_dt/coq_lemmas/_CoqProject @@ -1,9 +1,6 @@ - -Q theories CN_Lemmas theories/CN_Lib.v theories/Gen_Spec.v theories/Setup.v theories/Inst_Spec.v - - diff --git a/tests/cn/tree16/as_mutual_dt/tree16.c.verify b/tests/cn/tree16/as_mutual_dt/tree16.c.verify new file mode 100644 index 000000000..bcb3d7581 --- /dev/null +++ b/tests/cn/tree16/as_mutual_dt/tree16.c.verify @@ -0,0 +1,15 @@ +return code: 0 +tests/cn/tree16/as_mutual_dt/tree16.c:42:10: warning: 'each' expects a 'u64', but 'i' with type 'i32' was provided. This will become an error in the future. + take Ns = each (i32 i; (0i32 <= i) && (i < NUM_NODES)) + ^ +tests/cn/tree16/as_mutual_dt/tree16.c:111:19: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take Xs = each (i32 j; (0i32 <= j) && (j < path_len)) + ^ +tests/cn/tree16/as_mutual_dt/tree16.c:121:18: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take Xs2 = each (i32 j; (0i32 <= j) && (j < path_len)) + ^ +other location (File "backend/cn/lib/compile.ml", line 1593, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&i1' with type 'i32' was provided. This will become an error in the future. + +other location (File "backend/cn/lib/compile.ml", line 1593, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. + +[1/1]: lookup_rec -- pass diff --git a/tests/cn/tree16/as_partial_map/coq_lemmas/Makefile b/tests/cn/tree16/as_partial_map/coq_lemmas/Makefile index f3f0a1b03..cff60588a 100644 --- a/tests/cn/tree16/as_partial_map/coq_lemmas/Makefile +++ b/tests/cn/tree16/as_partial_map/coq_lemmas/Makefile @@ -1,8 +1,4 @@ - - - all: coq_makefile -f _CoqProject -o Makefile.coq - cn verify ../tree16.c --lemmata theories/Gen_Spec.v + cn verify ../tree16.c --lemmata theories/Gen_Spec.v &> /dev/null make -f Makefile.coq - diff --git a/tests/cn/tree16/as_partial_map/coq_lemmas/_CoqProject b/tests/cn/tree16/as_partial_map/coq_lemmas/_CoqProject index 012738ab4..30ef14952 100644 --- a/tests/cn/tree16/as_partial_map/coq_lemmas/_CoqProject +++ b/tests/cn/tree16/as_partial_map/coq_lemmas/_CoqProject @@ -1,9 +1,6 @@ - -Q theories CN_Lemmas theories/CN_Lib.v theories/Gen_Spec.v theories/Setup.v theories/Inst_Spec.v - - diff --git a/tests/cn/tree16/as_partial_map/tree16.c.verify b/tests/cn/tree16/as_partial_map/tree16.c.verify new file mode 100644 index 000000000..80b65218d --- /dev/null +++ b/tests/cn/tree16/as_partial_map/tree16.c.verify @@ -0,0 +1,22 @@ +return code: 0 +tests/cn/tree16/as_partial_map/tree16.c:22:5: warning: experimental keyword 'cn_function' (use of experimental features is discouraged) +/*@ cn_function num_nodes; @*/ + ^~~~~~~~~~~ +tests/cn/tree16/as_partial_map/tree16.c:55:10: warning: 'each' expects a 'u64', but 'i' with type 'i32' was provided. This will become an error in the future. + take Ns = each (i32 i; (0i32 <= i) && (i < (num_nodes ()))) + ^ +tests/cn/tree16/as_partial_map/tree16.c:75:8: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take Xs = each (i32 j; (0i32 <= j) && (j < len)) + ^ +tests/cn/tree16/as_partial_map/tree16.c:137:19: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take Xs = each (i32 j; (0i32 <= j) && (j < path_len)) + ^ +tests/cn/tree16/as_partial_map/tree16.c:146:18: warning: 'each' expects a 'u64', but 'j' with type 'i32' was provided. This will become an error in the future. + take Xs2 = each (i32 j; (0i32 <= j) && (j < path_len)) + ^ +other location (File "backend/cn/lib/compile.ml", line 1593, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&i2' with type 'i32' was provided. This will become an error in the future. + +other location (File "backend/cn/lib/compile.ml", line 1593, characters 38-45) warning: 'extract' expects a 'u64', but 'read_&idx0' with type 'i32' was provided. This will become an error in the future. + +[1/2]: cn_get_num_nodes -- pass +[2/2]: lookup_rec -- pass diff --git a/tests/cn/tree_rev01.c.verify b/tests/cn/tree_rev01.c.verify new file mode 100644 index 000000000..f1d36f13e --- /dev/null +++ b/tests/cn/tree_rev01.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: rev_tree -- pass diff --git a/tests/cn/type_synonym.c.verify b/tests/cn/type_synonym.c.verify new file mode 100644 index 000000000..a17639e1c --- /dev/null +++ b/tests/cn/type_synonym.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: f -- pass diff --git a/tests/cn/unary_negation.c.verify b/tests/cn/unary_negation.c.verify new file mode 100644 index 000000000..75a635a02 --- /dev/null +++ b/tests/cn/unary_negation.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: check_simplify -- pass diff --git a/tests/cn/unary_negation.error.c.verify b/tests/cn/unary_negation.error.c.verify new file mode 100644 index 000000000..802e36890 --- /dev/null +++ b/tests/cn/unary_negation.error.c.verify @@ -0,0 +1,4 @@ +return code: 1 +tests/cn/unary_negation.error.c:3:5: error: Value -129 does not fit i8 + -129i8 + ^~~~~~ diff --git a/tests/cn/unconstrained_ptr_eq.error.c.verify b/tests/cn/unconstrained_ptr_eq.error.c.verify new file mode 100644 index 000000000..320ec8c2f --- /dev/null +++ b/tests/cn/unconstrained_ptr_eq.error.c.verify @@ -0,0 +1,12 @@ +return code: 1 +tests/cn/unconstrained_ptr_eq.error.c:7:12: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + return p == q; + ~~^~~~ +[1/1]: f -- fail +tests/cn/unconstrained_ptr_eq.error.c:7:5: error: Unprovable constraint + return p == q; + ^~~~~~~~~~~~~~ +Constraint from tests/cn/unconstrained_ptr_eq.error.c:4:5: + return == 0i32; + ^~~~~~~~~~~~~~~ +State file: file:///tmp/state__unconstrained_ptr_eq.error.c__f.html diff --git a/tests/cn/unconstrained_ptr_eq2.error.c.verify b/tests/cn/unconstrained_ptr_eq2.error.c.verify new file mode 100644 index 000000000..ab1f62eab --- /dev/null +++ b/tests/cn/unconstrained_ptr_eq2.error.c.verify @@ -0,0 +1,12 @@ +return code: 1 +tests/cn/unconstrained_ptr_eq2.error.c:7:12: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + return p == q; + ~~^~~~ +[1/1]: f -- fail +tests/cn/unconstrained_ptr_eq2.error.c:7:5: error: Unprovable constraint + return p == q; + ^~~~~~~~~~~~~~ +Constraint from tests/cn/unconstrained_ptr_eq2.error.c:4:5: + return == 1i32; + ^~~~~~~~~~~~~~~ +State file: file:///tmp/state__unconstrained_ptr_eq2.error.c__f.html diff --git a/tests/cn/unsupported_flexible_array_member.error.c.verify b/tests/cn/unsupported_flexible_array_member.error.c.verify new file mode 100644 index 000000000..9e9f32485 --- /dev/null +++ b/tests/cn/unsupported_flexible_array_member.error.c.verify @@ -0,0 +1,4 @@ +return code: 2 +tests/cn/unsupported_flexible_array_member.error.c:3:9: error: unsupported flexible array members + int y[]; + ^ diff --git a/tests/cn/unsupported_union.error.c.verify b/tests/cn/unsupported_union.error.c.verify new file mode 100644 index 000000000..06c6db186 --- /dev/null +++ b/tests/cn/unsupported_union.error.c.verify @@ -0,0 +1,4 @@ +return code: 2 +tests/cn/unsupported_union.error.c:1:1: error: unsupported union types +union union_test { +~~~~~~^~~~~~~~~~~~ diff --git a/tests/cn/use_enum.c.verify b/tests/cn/use_enum.c.verify new file mode 100644 index 000000000..bdde7b0a5 --- /dev/null +++ b/tests/cn/use_enum.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: add_x_y -- pass diff --git a/tests/cn/use_typedef.c.verify b/tests/cn/use_typedef.c.verify new file mode 100644 index 000000000..f17d536af --- /dev/null +++ b/tests/cn/use_typedef.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: test -- pass diff --git a/tests/cn/verify.json b/tests/cn/verify.json new file mode 100644 index 000000000..dfab4251f --- /dev/null +++ b/tests/cn/verify.json @@ -0,0 +1,6 @@ +{ + "name": "verify", + "args": ["verify"], + "filter": "^(.*\\.c)$", + "timeout": 60 +} diff --git a/tests/cn/void_star_arg.c.verify b/tests/cn/void_star_arg.c.verify new file mode 100644 index 000000000..a17639e1c --- /dev/null +++ b/tests/cn/void_star_arg.c.verify @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: f -- pass diff --git a/tests/cn_vip_testsuite/README.md b/tests/cn_vip_testsuite/README.md new file mode 100644 index 000000000..48b9fe48a --- /dev/null +++ b/tests/cn_vip_testsuite/README.md @@ -0,0 +1,13 @@ +# PNVI-ae-udi/VIP testsuite adapted for CN +--- +* VIP does not have non-det. pointer equality but CN does +* The addition of ghost parameters to CN may increase the expressiveness of the memory model + +## To do +* Add support round trip casts +* Add support preserving pointer provenance via bytes +* Add support memcpy_proxy +* Add support unions +* Fix peformance bug for pointer\_copy\_user\_ctrflow\_bytewise.c +* `tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.pass.c:1:// NOTE: terminates with cvc5 but not Z3` +* `tests/cn_vip_testsuite/provenance_tag_bits_via_uintptr_t_1.annot.c:1:// NOTE: terminates with cvc5 but not Z3` diff --git a/tests/cn_vip_testsuite/cheri_03_ii.error.c.no_annot b/tests/cn_vip_testsuite/cheri_03_ii.error.c.no_annot new file mode 100644 index 000000000..4246f6e43 --- /dev/null +++ b/tests/cn_vip_testsuite/cheri_03_ii.error.c.no_annot @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: main -- fail +tests/cn_vip_testsuite/cheri_03_ii.error.c:6:12: error: `&&x[(u64)11'i32]` out of bounds + int *q = p + 11; // CN VIP UB + ~~^~~~ +(UB missing short message): UB_CERB004_unspecified__pointer_add +State file: file:///tmp/state__cheri_03_ii.error.c__main.html diff --git a/tests/cn_vip_testsuite/cn_lemmas.h b/tests/cn_vip_testsuite/cn_lemmas.h index 290db965b..2042fec64 100644 --- a/tests/cn_vip_testsuite/cn_lemmas.h +++ b/tests/cn_vip_testsuite/cn_lemmas.h @@ -32,23 +32,6 @@ ensures (return != 0i32 || Src == Dest) && (return == 0i32 || Src != Dest); @*/ -void _memcpy(unsigned char *dest, unsigned char *src, size_t n); -/*@ spec _memcpy(pointer dest, pointer src, u64 n); - -requires - (u64) src + n <= (u64) dest || (u64) dest + n <= (u64) src; - (u64) src <= (u64) src + n; - (u64) dest <= (u64) dest + n; - take Src = each (u64 i; 0u64 <= i && i < n ) { Owned(array_shift(src, i)) }; - take Dest = each (u64 i; 0u64 <= i && i < n ) { Block(array_shift(dest, i)) }; - -ensures - take SrcR = each (u64 i; 0u64 <= i && i < n ) { Owned(array_shift(src, i)) }; - take DestR = each (u64 i; 0u64 <= i && i < n ) { Owned(array_shift(dest, i)) }; - Src == SrcR; - SrcR == DestR; -@*/ - /*@ lemma assert_equal(u64 x, u64 y) requires diff --git a/tests/cn_vip_testsuite/no_annot.json b/tests/cn_vip_testsuite/no_annot.json new file mode 100644 index 000000000..0d3a8bdb1 --- /dev/null +++ b/tests/cn_vip_testsuite/no_annot.json @@ -0,0 +1,6 @@ +{ + "name": "no_annot", + "args": ["verify", "-DVIP", "-DNO_ROUND_TRIP", "--solver-type=cvc5" ], + "filter": "^(.*\\.c)$", + "timeout": 35 +} diff --git a/tests/cn_vip_testsuite/non_det_false.json b/tests/cn_vip_testsuite/non_det_false.json new file mode 100644 index 000000000..6d3745e7c --- /dev/null +++ b/tests/cn_vip_testsuite/non_det_false.json @@ -0,0 +1,6 @@ +{ + "name": "non_det_false", + "args": ["verify", "-DVIP", "-DNO_ROUND_TRIP", "-DNON_DET_FALSE", "--solver-type=cvc5" ], + "filter": "^(.*\\.nondet.c)$", + "timeout": 35 +} diff --git a/tests/cn_vip_testsuite/non_det_true.json b/tests/cn_vip_testsuite/non_det_true.json new file mode 100644 index 000000000..acc45731c --- /dev/null +++ b/tests/cn_vip_testsuite/non_det_true.json @@ -0,0 +1,6 @@ +{ + "name": "non_det_true", + "args": ["verify", "-DVIP", "-DNO_ROUND_TRIP", "-DNON_DET_TRUE", "--solver-type=cvc5" ], + "filter": "^(.*\\.nondet\\.c)$", + "timeout": 35 +} diff --git a/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_2_global.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_2_global.annot.c.no_annot new file mode 100644 index 000000000..c582e6865 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_2_global.annot.c.no_annot @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_arith_algebraic_properties_2_global.annot.c:20:3: error: Missing resource for writing + *p = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_arith_algebraic_properties_2_global.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_2_global.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_2_global.annot.c.with_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_2_global.annot.c.with_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_3_global.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_3_global.annot.c.no_annot new file mode 100644 index 000000000..22bd37b66 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_3_global.annot.c.no_annot @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_arith_algebraic_properties_3_global.annot.c:21:3: error: Missing resource for writing + *p = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_arith_algebraic_properties_3_global.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_3_global.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_3_global.annot.c.with_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_arith_algebraic_properties_3_global.annot.c.with_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_copy_memcpy.c b/tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c similarity index 91% rename from tests/cn_vip_testsuite/pointer_copy_memcpy.c rename to tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c index 970ef81f7..813f148b2 100644 --- a/tests/cn_vip_testsuite/pointer_copy_memcpy.c +++ b/tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c @@ -10,7 +10,7 @@ int main() int *q; /*CN_VIP*//*@ to_bytes Owned(&p); @*/ /*CN_VIP*//*@ to_bytes Block(&q); @*/ - _memcpy ((unsigned char*)&q, (unsigned char*)&p, sizeof p); + memcpy((unsigned char*)&q, (unsigned char*)&p, sizeof p); /*CN_VIP*//*@ from_bytes Owned(&p); @*/ /*CN_VIP*//*@ from_bytes Owned(&q); @*/ #ifdef NO_ROUND_TRIP diff --git a/tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c.no_annot b/tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c.no_annot new file mode 100644 index 000000000..5d721c18c --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c.no_annot @@ -0,0 +1,8 @@ +return code: 0 +tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c:11:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_copy_memcpy.pass.c:14:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bitwise.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bitwise.annot.c.no_annot new file mode 100644 index 000000000..0dcac67f6 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bitwise.annot.c.no_annot @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bitwise.annot.c:41:3: error: Missing resource for writing + *q = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_copy_user_ctrlflow_bitwise.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bitwise.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bitwise.annot.c.with_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bitwise.annot.c.with_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bytewise.unprovable.c b/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bytewise.pass.c similarity index 100% rename from tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bytewise.unprovable.c rename to tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bytewise.pass.c diff --git a/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bytewise.pass.c.no_annot b/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bytewise.pass.c.no_annot new file mode 100644 index 000000000..2c7128919 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_copy_user_ctrlflow_bytewise.pass.c.no_annot @@ -0,0 +1 @@ +TIMEOUT diff --git a/tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.c b/tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c similarity index 100% rename from tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.c rename to tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c diff --git a/tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c.no_annot b/tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c.no_annot new file mode 100644 index 000000000..3318d1b36 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c.no_annot @@ -0,0 +1,12 @@ +return code: 0 +tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c:28:5: warning: CN pointer equality is not the same as C's (will not warn again). Please use `ptr_eq` or `is_null` (maybe `addr_eq`). + src == array_shift(src_start, n_start - n); + ~~~~^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c:48:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_copy_user_dataflow_direct_bytewise.pass.c:52:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ + ^~~~~~~~~~ +[1/2]: user_memcpy -- pass +[2/2]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c new file mode 100644 index 000000000..63abe838e --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c @@ -0,0 +1,34 @@ +#include "refinedc.h" + +//CN_VIP #include +#include +#include +#include +#include "cn_lemmas.h" +int y=2, x=1; +int main() +/*CN_VIP*//*@ accesses y; accesses x; requires x == 1i32; @*/ +{ + int *p = &x+1; + int *q = &y; + uintptr_t i = (uintptr_t)p; + uintptr_t j = (uintptr_t)q; + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + /*CN_VIP*//*@ to_bytes Owned(&q); @*/ + /*CN_VIP*/int result = _memcmp((unsigned char*)&p, (unsigned char*)&q, sizeof(p)); + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + /*CN_VIP*//*@ from_bytes Owned(&q); @*/ +#ifdef NO_ROUND_TRIP + q = copy_alloc_id(j, &y); +#endif + if (result == 0) { +#ifdef ANNOT + int *r = copy_alloc_id(i, q); +#else + int *r = (int *)i; +#endif + *r=11; // is this free of UB? + /*CN_VIP*//*@ assert (x == 1i32 && y == 11i32 && *q == 11i32 && *r == 11i32); @*/ + //CN_VIP printf("x=%d y=%d *q=%d *r=%d\n",x,y,*q,*r); + } +} diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.no_annot new file mode 100644 index 000000000..1f3727260 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.no_annot @@ -0,0 +1,13 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:16:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:19:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:30:5: error: Missing resource for writing + *r=11; // is this free of UB? + ~~^~~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_from_int_disambiguation_1.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.with_annot new file mode 100644 index 000000000..b9ac428bf --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c.with_annot @@ -0,0 +1,8 @@ +return code: 0 +tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:16:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.annot.c:19:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.unprovable.c b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.unprovable.c deleted file mode 100644 index 26476aa21..000000000 --- a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_1.unprovable.c +++ /dev/null @@ -1,22 +0,0 @@ -#include "refinedc.h" - -//CN_VIP #include -#include -#include -#include -int y=2, x=1; -int main() { - int *p = &x+1; - int *q = &y; - uintptr_t i = (uintptr_t)p; - uintptr_t j = (uintptr_t)q; - if (memcmp(&p, &q, sizeof(p)) == 0) { -#if defined(ANNOT) - int *r = copy_alloc_id(i, q); -#else - int *r = (int *)i; -#endif - *r=11; // is this free of UB? - //CN_VIP printf("x=%d y=%d *q=%d *r=%d\n",x,y,*q,*r); - } -} diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.c b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c similarity index 100% rename from tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.c rename to tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c.no_annot b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c.no_annot new file mode 100644 index 000000000..f95afd65a --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c.no_annot @@ -0,0 +1,8 @@ +return code: 0 +tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c:16:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_2.pass.c:19:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.no_annot b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.no_annot new file mode 100644 index 000000000..307b850cb --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.no_annot @@ -0,0 +1,14 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:16:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:19:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:34:5: error: Missing resource for writing + *r=11; // CN VIP UB if ¬ANNOT + ~~^~~ +Resource needed: Block(copy_alloc_id((u64)intToPtr + , copy_alloc_id((u64)value, &x))) +State file: file:///tmp/state__pointer_from_int_disambiguation_3.error.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.with_annot b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.with_annot new file mode 100644 index 000000000..7e92c5252 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c.with_annot @@ -0,0 +1,13 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:16:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:19:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_from_int_disambiguation_3.error.c:35:7: error: `©_alloc_id((u64)&&x[1'u64], copy_alloc_id((u64)value, &y))[(u64)(0'i32 - 1'i32)]` out of bounds + r=r-1; // CN VIP UB if NO_ROUND TRIP && ANNOT + ~^~ +(UB missing short message): UB_CERB004_unspecified__pointer_add +State file: file:///tmp/state__pointer_from_int_disambiguation_3.error.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1i.unprovable.c b/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c similarity index 51% rename from tests/cn_vip_testsuite/pointer_from_integer_1i.unprovable.c rename to tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c index 1c2cf750d..88e1fb1c8 100644 --- a/tests/cn_vip_testsuite/pointer_from_integer_1i.unprovable.c +++ b/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c @@ -3,8 +3,10 @@ //CN_VIP #include #include #include "charon_address_guesses.h" +#include "cn_lemmas.h" void f(uintptr_t i) { int j=5; + /*CN_VIP*//*@ apply assert_equal(i, (u64)&j); @*/ #if defined(ANNOT) int *p = copy_alloc_id(i, &j); #else @@ -18,3 +20,8 @@ int main() { uintptr_t j = ADDRESS_PFI_1I; f(j); } + +// The evaluation table in the appendix of the VIP paper is misleading. +// This file has UB under PNVI-ae-udi without annotations because +// of allocation address non-determinism (demonic). +// I emulate the same behaviour by asserting the addresses are equal. diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c.no_annot new file mode 100644 index 000000000..f0d2bf11d --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c.no_annot @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c:15:3: error: Missing resource for writing + *p=7; + ~~^~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_from_integer_1i.annot.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c.with_annot new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_1i.annot.c.with_annot @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1ie.unprovable.c b/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c similarity index 53% rename from tests/cn_vip_testsuite/pointer_from_integer_1ie.unprovable.c rename to tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c index cd44285c3..0a2208fe1 100644 --- a/tests/cn_vip_testsuite/pointer_from_integer_1ie.unprovable.c +++ b/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c @@ -3,9 +3,11 @@ //CN_VIP #include #include #include "charon_address_guesses.h" +#include "cn_lemmas.h" void f(uintptr_t i) { int j=5; uintptr_t k = (uintptr_t)&j; + /*CN_VIP*//*@ apply assert_equal(i, k); @*/ #if defined(ANNOT) int *p = copy_alloc_id(i, &j); #else @@ -19,3 +21,8 @@ int main() { uintptr_t j = ADDRESS_PFI_1I; f(j); } + +// The evaluation table in the appendix of the VIP paper is misleading. +// This file has UB under PNVI-ae-udi without annotations because +// of allocation address non-determinism (demonic) +// The desired behaviour can be obtained by asserting the addresses are equal. diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c.no_annot new file mode 100644 index 000000000..fd92ee9ff --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c.no_annot @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c:16:3: error: Missing resource for writing + *p=7; + ~~^~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_from_integer_1ie.annot.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c.with_annot new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_1ie.annot.c.with_annot @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c b/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c index f7d60a1a6..6a3eb7622 100644 --- a/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c +++ b/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c @@ -22,3 +22,8 @@ int main() { uintptr_t j = ADDRESS_PFI_1IG; f(j); } + +// The evaluation table in the appendix of the VIP paper is misleading. +// This file has UB under PNVI-ae-udi without annotations because +// of allocation address non-determinism (demonic) +// The desired behaviour can be obtained by asserting the addresses are equal. diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c.no_annot new file mode 100644 index 000000000..39635ab21 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c.no_annot @@ -0,0 +1,11 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c:15:7: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + if (p==&j) { + ~^~~~ +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c:16:5: error: Missing resource for writing + *p=7; // CN VIP UB (no annot) + ~~^~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_from_integer_1ig.annot.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c.with_annot new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_1ig.annot.c.with_annot @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1p.unprovable.c b/tests/cn_vip_testsuite/pointer_from_integer_1p.error.c similarity index 100% rename from tests/cn_vip_testsuite/pointer_from_integer_1p.unprovable.c rename to tests/cn_vip_testsuite/pointer_from_integer_1p.error.c diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1p.error.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_1p.error.c.no_annot new file mode 100644 index 000000000..7818545f5 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_1p.error.c.no_annot @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/pointer_from_integer_1p.error.c:6:3: error: Missing resource for writing + *p=7; + ~~^~ +Resource needed: Block(p) +State file: file:///tmp/state__pointer_from_integer_1p.error.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c b/tests/cn_vip_testsuite/pointer_from_integer_1pg.error.c similarity index 100% rename from tests/cn_vip_testsuite/pointer_from_integer_1pg.unprovable.c rename to tests/cn_vip_testsuite/pointer_from_integer_1pg.error.c diff --git a/tests/cn_vip_testsuite/pointer_from_integer_1pg.error.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_1pg.error.c.no_annot new file mode 100644 index 000000000..7cf81a333 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_1pg.error.c.no_annot @@ -0,0 +1,11 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_from_integer_1pg.error.c:6:7: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + if (p==&j) + ~^~~~ +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/pointer_from_integer_1pg.error.c:7:5: error: Missing resource for writing + *p=7; + ~~^~ +Resource needed: Block(p) +State file: file:///tmp/state__pointer_from_integer_1pg.error.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_2.unprovable.c b/tests/cn_vip_testsuite/pointer_from_integer_2.error.c similarity index 100% rename from tests/cn_vip_testsuite/pointer_from_integer_2.unprovable.c rename to tests/cn_vip_testsuite/pointer_from_integer_2.error.c diff --git a/tests/cn_vip_testsuite/pointer_from_integer_2.error.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_2.error.c.no_annot new file mode 100644 index 000000000..59f26202e --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_2.error.c.no_annot @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/pointer_from_integer_2.error.c:7:3: error: Missing resource for writing + *p=7; + ~~^~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_from_integer_2.error.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_from_integer_2g.unprovable.c b/tests/cn_vip_testsuite/pointer_from_integer_2g.error.c similarity index 100% rename from tests/cn_vip_testsuite/pointer_from_integer_2g.unprovable.c rename to tests/cn_vip_testsuite/pointer_from_integer_2g.error.c diff --git a/tests/cn_vip_testsuite/pointer_from_integer_2g.error.c.no_annot b/tests/cn_vip_testsuite/pointer_from_integer_2g.error.c.no_annot new file mode 100644 index 000000000..98990b55a --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_from_integer_2g.error.c.no_annot @@ -0,0 +1,8 @@ +return code: 1 +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/pointer_from_integer_2g.error.c:7:3: error: Missing resource for writing + *p=7; + ~~^~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_from_integer_2g.error.c__f.html diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.no_annot new file mode 100644 index 000000000..b74bc7642 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.no_annot @@ -0,0 +1,13 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:21:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:24:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:33:5: error: Missing resource for writing + *p = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(value) +State file: file:///tmp/state__pointer_offset_from_int_subtraction_auto_xy.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.with_annot new file mode 100644 index 000000000..01b36b274 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c.with_annot @@ -0,0 +1,8 @@ +return code: 0 +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:21:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_xy.annot.c:24:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.no_annot new file mode 100644 index 000000000..6d353cb30 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.no_annot @@ -0,0 +1,13 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:21:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:24:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:33:5: error: Missing resource for writing + *p = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(value) +State file: file:///tmp/state__pointer_offset_from_int_subtraction_auto_yx.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.with_annot new file mode 100644 index 000000000..f9fccfe70 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c.with_annot @@ -0,0 +1,8 @@ +return code: 0 +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:21:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_auto_yx.annot.c:24:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.no_annot new file mode 100644 index 000000000..1eef026b8 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.no_annot @@ -0,0 +1,13 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:23:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:26:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:35:5: error: Missing resource for writing + *p = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(value) +State file: file:///tmp/state__pointer_offset_from_int_subtraction_global_xy.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.with_annot new file mode 100644 index 000000000..d9eed5cb3 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c.with_annot @@ -0,0 +1,8 @@ +return code: 0 +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:23:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_xy.annot.c:26:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.no_annot new file mode 100644 index 000000000..be53d1282 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.no_annot @@ -0,0 +1,13 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:23:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:26:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:35:5: error: Missing resource for writing + *p = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(value) +State file: file:///tmp/state__pointer_offset_from_int_subtraction_global_yx.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.with_annot new file mode 100644 index 000000000..cb7c78a16 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c.with_annot @@ -0,0 +1,8 @@ +return code: 0 +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:23:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_int_subtraction_global_yx.annot.c:26:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c.no_annot new file mode 100644 index 000000000..d5d92a478 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c.no_annot @@ -0,0 +1,13 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c:12:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&r); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c:15:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&r); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_xy.error.c:10:22: error: Undefined behaviour + ptrdiff_t offset = q - p; // CN VIP UB + ~~^~~ +the subtraction of two pointers must be between pointers that points into, or just beyond, the same array object (§6.5.6#9, sentence 1) +State file: file:///tmp/state__pointer_offset_from_ptr_subtraction_auto_xy.error.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c.no_annot new file mode 100644 index 000000000..be6bfec79 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c.no_annot @@ -0,0 +1,13 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c:12:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&r); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c:15:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&r); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_auto_yx.error.c:10:22: error: Undefined behaviour + ptrdiff_t offset = q - p; // CN VIP UB + ~~^~~ +the subtraction of two pointers must be between pointers that points into, or just beyond, the same array object (§6.5.6#9, sentence 1) +State file: file:///tmp/state__pointer_offset_from_ptr_subtraction_auto_yx.error.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c.no_annot new file mode 100644 index 000000000..2f890559f --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c.no_annot @@ -0,0 +1,13 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c:14:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&r); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c:17:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&r); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_xy.error.c:12:22: error: Undefined behaviour + ptrdiff_t offset = q - p; // CN VIP UB + ~~^~~ +the subtraction of two pointers must be between pointers that points into, or just beyond, the same array object (§6.5.6#9, sentence 1) +State file: file:///tmp/state__pointer_offset_from_ptr_subtraction_global_xy.error.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c.no_annot new file mode 100644 index 000000000..71fe73593 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c.no_annot @@ -0,0 +1,13 @@ +return code: 1 +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c:14:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&r); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c:17:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&r); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_from_ptr_subtraction_global_yx.error.c:12:22: error: Undefined behaviour + ptrdiff_t offset = q - p; // CN VIP UB + ~~^~~ +the subtraction of two pointers must be between pointers that points into, or just beyond, the same array object (§6.5.6#9, sentence 1) +State file: file:///tmp/state__pointer_offset_from_ptr_subtraction_global_yx.error.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_xor_auto.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_xor_auto.annot.c.no_annot new file mode 100644 index 000000000..925eb6baa --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_xor_auto.annot.c.no_annot @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_xor_auto.annot.c:19:3: error: Missing resource for writing + *r = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_offset_xor_auto.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_xor_auto.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_offset_xor_auto.annot.c.with_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_xor_auto.annot.c.with_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/pointer_offset_xor_global.annot.c.no_annot b/tests/cn_vip_testsuite/pointer_offset_xor_global.annot.c.no_annot new file mode 100644 index 000000000..0d74be545 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_xor_global.annot.c.no_annot @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: main -- fail +tests/cn_vip_testsuite/pointer_offset_xor_global.annot.c:22:3: error: Missing resource for writing + *r = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__pointer_offset_xor_global.annot.c__main.html diff --git a/tests/cn_vip_testsuite/pointer_offset_xor_global.annot.c.with_annot b/tests/cn_vip_testsuite/pointer_offset_xor_global.annot.c.with_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/pointer_offset_xor_global.annot.c.with_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c.no_annot b/tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c.no_annot new file mode 100644 index 000000000..a61e8f86b --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c.no_annot @@ -0,0 +1,13 @@ +return code: 1 +tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c:10:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c:13:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_basic_auto_yx.error.c:19:5: error: Missing resource for writing + *p = 11; // CN VIP UB + ~~~^~~~ +Resource needed: Block(copy_alloc_id((u64)value, &x)) +State file: file:///tmp/state__provenance_basic_auto_yx.error.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_basic_global_yx.error.c.no_annot b/tests/cn_vip_testsuite/provenance_basic_global_yx.error.c.no_annot new file mode 100644 index 000000000..432786655 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_basic_global_yx.error.c.no_annot @@ -0,0 +1,13 @@ +return code: 1 +tests/cn_vip_testsuite/provenance_basic_global_yx.error.c:12:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_global_yx.error.c:15:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_basic_global_yx.error.c:21:5: error: Missing resource for writing + *p = 11; // CN_VIP UB + ~~~^~~~ +Resource needed: Block(copy_alloc_id((u64)value, &x)) +State file: file:///tmp/state__provenance_basic_global_yx.error.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c index 367d9aa76..1a0f644f5 100644 --- a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c +++ b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c @@ -39,3 +39,8 @@ int main() { /*CN_VIP*//*@ assert(x == 1i32 && y == 11i32 && *p == 11i32 && *q == 11i32); @*/ } } + +// The evaluation table in the appendix of the VIP paper is misleading. +// This file has UB under PNVI-ae-udi without annotations because +// of allocation address non-determinism (demonic) +// The desired behaviour can be obtained by asserting the addresses are adjacent. diff --git a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.no_annot b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.no_annot new file mode 100644 index 000000000..d7febc047 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.no_annot @@ -0,0 +1,13 @@ +return code: 1 +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:25:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:28:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:37:5: error: Missing resource for writing + *p = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(value) +State file: file:///tmp/state__provenance_basic_using_uintptr_t_auto_yx.annot.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.with_annot b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.with_annot new file mode 100644 index 000000000..0b7385b05 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c.with_annot @@ -0,0 +1,8 @@ +return code: 0 +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:25:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_auto_yx.annot.c:28:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c index 2323bb81b..a303f414b 100644 --- a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c +++ b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c @@ -39,3 +39,8 @@ int main() /*CN_VIP*//*@ assert(x == 1i32 && y == 11i32 && *p == 11i32 && *q == 11i32); @*/ } } + +// The evaluation table in the appendix of the VIP paper is misleading. +// This file has UB under PNVI-ae-udi without annotations because +// of allocation address non-determinism (demonic) +// The desired behaviour can be obtained by asserting the addresses are adjacent. diff --git a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.no_annot b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.no_annot new file mode 100644 index 000000000..38bfded08 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.no_annot @@ -0,0 +1,13 @@ +return code: 1 +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:25:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:28:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:37:5: error: Missing resource for writing + *p = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(value) +State file: file:///tmp/state__provenance_basic_using_uintptr_t_global_yx.annot.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.with_annot b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.with_annot new file mode 100644 index 000000000..e58d8f578 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c.with_annot @@ -0,0 +1,8 @@ +return code: 0 +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:25:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_basic_using_uintptr_t_global_yx.annot.c:28:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_equality_auto_yx.c b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c similarity index 86% rename from tests/cn_vip_testsuite/provenance_equality_auto_yx.c rename to tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c index af233ac8a..9b6ece157 100644 --- a/tests/cn_vip_testsuite/provenance_equality_auto_yx.c +++ b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c @@ -1,7 +1,9 @@ //CN_VIP #include //CN_VIP #include +#include "cn_lemmas.h" int main() { int y=2, x=1; + /*CN_VIP*//*@ apply assert_equal((u64)&y, (u64)&x + sizeof); @*/ int *p = &x + 1; int *q = &y; //CN_VIP printf("Addresses: p=%p q=%p\n",(void*)p,(void*)q); diff --git a/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.no_annot b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.no_annot new file mode 100644 index 000000000..91eceb35e --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.no_annot @@ -0,0 +1,5 @@ +return code: 0 +tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:10:13: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + _Bool b = (p==q); + ^~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_false b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_false new file mode 100644 index 000000000..7f4a120bc --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_false @@ -0,0 +1,12 @@ +return code: 1 +tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:10:13: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + _Bool b = (p==q); + ^~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:15:17: error: Unprovable constraint + /*CN_VIP*//*@ assert (b == 0u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +Constraint from tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:15:17: + /*CN_VIP*//*@ assert (b == 0u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__provenance_equality_auto_yx.nondet.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_true b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_true new file mode 100644 index 000000000..5de47f548 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c.non_det_true @@ -0,0 +1,12 @@ +return code: 1 +tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:10:13: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + _Bool b = (p==q); + ^~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:13:17: error: Unprovable constraint + /*CN_VIP*//*@ assert (b == 1u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +Constraint from tests/cn_vip_testsuite/provenance_equality_auto_yx.nondet.c:13:17: + /*CN_VIP*//*@ assert (b == 1u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__provenance_equality_auto_yx.nondet.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_equality_auto_yx.pass.c.no_annot b/tests/cn_vip_testsuite/provenance_equality_auto_yx.pass.c.no_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_auto_yx.pass.c.no_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.c b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c similarity index 80% rename from tests/cn_vip_testsuite/provenance_equality_global_fn_yx.c rename to tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c index 27f652d89..612f4c288 100644 --- a/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.c +++ b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c @@ -1,7 +1,9 @@ //CN_VIP #include #include int y=2, x=1; -void f(int* p, int* q) { +void f(int* p, int* q) +/*CN_VIP*//*@ requires (u64)p == (u64)q; @*/ +{ _Bool b = (p==q); // can this be false even with identical addresses? //CN_VIP printf("(p==q) = %s\n", b?"true":"false"); @@ -14,7 +16,9 @@ void f(int* p, int* q) { #endif return; } -int main() { +int main() +/*CN_VIP*//*@ accesses x; requires (u64)&y == (u64)&x + sizeof; @*/ +{ int *p = &x + 1; int *q = &y; //CN_VIP printf("Addresses: p=%p q=%p\n",(void*)p,(void*)q); diff --git a/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.no_annot b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.no_annot new file mode 100644 index 000000000..ec6e63b46 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.no_annot @@ -0,0 +1,6 @@ +return code: 0 +tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:7:13: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + _Bool b = (p==q); + ^~~~~~ +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_false b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_false new file mode 100644 index 000000000..a2c6a3cbd --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_false @@ -0,0 +1,13 @@ +return code: 1 +tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:7:13: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + _Bool b = (p==q); + ^~~~~~ +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:13:17: error: Unprovable constraint + /*CN_VIP*//*@ assert (b == 0u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +Constraint from tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:13:17: + /*CN_VIP*//*@ assert (b == 0u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__provenance_equality_global_fn_yx.nondet.c__f.html diff --git a/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_true b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_true new file mode 100644 index 000000000..accb43ccd --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c.non_det_true @@ -0,0 +1,13 @@ +return code: 1 +tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:7:13: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + _Bool b = (p==q); + ^~~~~~ +[1/2]: f -- fail +[2/2]: main -- pass +tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:11:17: error: Unprovable constraint + /*CN_VIP*//*@ assert (b == 1u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +Constraint from tests/cn_vip_testsuite/provenance_equality_global_fn_yx.nondet.c:11:17: + /*CN_VIP*//*@ assert (b == 1u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__provenance_equality_global_fn_yx.nondet.c__f.html diff --git a/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.pass.c.no_annot b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.pass.c.no_annot new file mode 100644 index 000000000..3e567df0b --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_global_fn_yx.pass.c.no_annot @@ -0,0 +1,3 @@ +return code: 0 +[1/2]: f -- pass +[2/2]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_equality_global_yx.c b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c similarity index 87% rename from tests/cn_vip_testsuite/provenance_equality_global_yx.c rename to tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c index 41144f560..7a5453ece 100644 --- a/tests/cn_vip_testsuite/provenance_equality_global_yx.c +++ b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c @@ -1,7 +1,9 @@ //CN_VIP #include #include int y=2, x=1; -int main() { +int main() +/*CN_VIP*//*@ accesses x; requires (u64)&y == (u64)&x + sizeof; @*/ +{ int *p = &x + 1; int *q = &y; //CN_VIP printf("Addresses: p=%p q=%p\n",(void*)p,(void*)q); diff --git a/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.no_annot b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.no_annot new file mode 100644 index 000000000..2c6a629eb --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.no_annot @@ -0,0 +1,5 @@ +return code: 0 +tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:10:13: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + _Bool b = (p==q); + ^~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_false b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_false new file mode 100644 index 000000000..479583e3a --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_false @@ -0,0 +1,12 @@ +return code: 1 +tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:10:13: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + _Bool b = (p==q); + ^~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:16:17: error: Unprovable constraint + /*CN_VIP*//*@ assert (b == 0u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +Constraint from tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:16:17: + /*CN_VIP*//*@ assert (b == 0u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__provenance_equality_global_yx.nondet.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_true b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_true new file mode 100644 index 000000000..3cfb2aa15 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c.non_det_true @@ -0,0 +1,12 @@ +return code: 1 +tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:10:13: warning: Cannot rule out ambiguous pointer equality case (addresses equal, but provenances differ) + _Bool b = (p==q); + ^~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:14:17: error: Unprovable constraint + /*CN_VIP*//*@ assert (b == 1u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +Constraint from tests/cn_vip_testsuite/provenance_equality_global_yx.nondet.c:14:17: + /*CN_VIP*//*@ assert (b == 1u8); @*/ // non-det in PNVI-ae-udi; true in VIP + ^~~~~~~~~~~~~~~~~~ +State file: file:///tmp/state__provenance_equality_global_yx.nondet.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_equality_global_yx.pass.c.no_annot b/tests/cn_vip_testsuite/provenance_equality_global_yx.pass.c.no_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_global_yx.pass.c.no_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.c b/tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.pass.c similarity index 65% rename from tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.c rename to tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.pass.c index 3f9b7f91f..817a07f95 100644 --- a/tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.c +++ b/tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.pass.c @@ -13,3 +13,8 @@ int main() { /*CN_VIP*//*@ assert (b == 1u8); @*/ return 0; } + +// The evaluation table in the appendix of the VIP paper is misleading. +// This file has UB under PNVI-ae-udi without annotations because +// of allocation address non-determinism (demonic) +// The desired behaviour can be obtained by asserting the addresses are adjacent. diff --git a/tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.pass.c.no_annot b/tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.pass.c.no_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_uintptr_t_auto_yx.pass.c.no_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.c b/tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.pass.c similarity index 64% rename from tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.c rename to tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.pass.c index ca27e4105..4fdf1b27d 100644 --- a/tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.c +++ b/tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.pass.c @@ -13,3 +13,8 @@ int main() { /*CN_VIP*//*@ assert (b == 1u8); @*/ return 0; } + +// The evaluation table in the appendix of the VIP paper is misleading. +// This file has UB under PNVI-ae-udi without annotations because +// of allocation address non-determinism (demonic) +// The desired behaviour can be obtained by asserting the addresses are adjacent. diff --git a/tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.pass.c.no_annot b/tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.pass.c.no_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_equality_uintptr_t_global_yx.pass.c.no_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c b/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c index e2c3f3731..5641b3951 100644 --- a/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c +++ b/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c @@ -32,3 +32,8 @@ int main() /*CN_VIP*//*@ assert(x == 11i32 && *p == 11i32 && *q == 11i32); @*/ } } + +// The evaluation table in the appendix of the VIP paper is misleading. +// This file has UB under PNVI-ae-udi without annotations because +// of allocation address non-determinism (demonic) +// The desired behaviour can be obtained by asserting the addresses are equal. diff --git a/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.no_annot b/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.no_annot new file mode 100644 index 000000000..8af82288f --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.no_annot @@ -0,0 +1,13 @@ +return code: 1 +tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:24:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&i1); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:27:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&i1); @*/ + ^~~~~~~~~~ +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:30:5: error: Missing resource for writing + *q = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__provenance_lost_escape_1.annot.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.with_annot b/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.with_annot new file mode 100644 index 000000000..5ef6dc102 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c.with_annot @@ -0,0 +1,8 @@ +return code: 0 +tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:24:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&i1); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_lost_escape_1.annot.c:27:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&i1); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t.c b/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t.pass.c similarity index 100% rename from tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t.c rename to tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t.pass.c diff --git a/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t.pass.c.no_annot b/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t.pass.c.no_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t.pass.c.no_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t_onepast.c b/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t_onepast.pass.c similarity index 100% rename from tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t_onepast.c rename to tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t_onepast.pass.c diff --git a/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t_onepast.pass.c.no_annot b/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t_onepast.pass.c.no_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_roundtrip_via_intptr_t_onepast.pass.c.no_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.c b/tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.pass.c similarity index 100% rename from tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.c rename to tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.pass.c diff --git a/tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.pass.c.no_annot b/tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.pass.c.no_annot new file mode 100644 index 000000000..81ab6b5c7 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.pass.c.no_annot @@ -0,0 +1,8 @@ +return code: 0 +tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.pass.c:17:17: warning: experimental keyword 'to_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ to_bytes Owned(&p); @*/ + ^~~~~~~~ +tests/cn_vip_testsuite/provenance_tag_bits_via_repr_byte_1.pass.c:32:17: warning: experimental keyword 'from_bytes' (use of experimental features is discouraged) + /*CN_VIP*//*@ from_bytes Owned(&p); @*/ + ^~~~~~~~~~ +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_tag_bits_via_uintptr_t_1.annot.c.no_annot b/tests/cn_vip_testsuite/provenance_tag_bits_via_uintptr_t_1.annot.c.no_annot new file mode 100644 index 000000000..f7ad2aa88 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_tag_bits_via_uintptr_t_1.annot.c.no_annot @@ -0,0 +1,7 @@ +return code: 1 +[1/1]: main -- fail +tests/cn_vip_testsuite/provenance_tag_bits_via_uintptr_t_1.annot.c:34:3: error: Missing resource for writing + *r = 11; // CN VIP UB (no annot) + ~~~^~~~ +Resource needed: Block(intToPtr) +State file: file:///tmp/state__provenance_tag_bits_via_uintptr_t_1.annot.c__main.html diff --git a/tests/cn_vip_testsuite/provenance_tag_bits_via_uintptr_t_1.annot.c.with_annot b/tests/cn_vip_testsuite/provenance_tag_bits_via_uintptr_t_1.annot.c.with_annot new file mode 100644 index 000000000..363cf45d8 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_tag_bits_via_uintptr_t_1.annot.c.with_annot @@ -0,0 +1,2 @@ +return code: 0 +[1/1]: main -- pass diff --git a/tests/cn_vip_testsuite/provenance_union_punning_2_auto_yx.error.c.no_annot b/tests/cn_vip_testsuite/provenance_union_punning_2_auto_yx.error.c.no_annot new file mode 100644 index 000000000..d40bd5b50 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_union_punning_2_auto_yx.error.c.no_annot @@ -0,0 +1,4 @@ +return code: 2 +tests/cn_vip_testsuite/provenance_union_punning_2_auto_yx.error.c:4:9: error: unsupported union types +typedef union { uintptr_t ui; int *p; } un; + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn_vip_testsuite/provenance_union_punning_2_global_yx.error.c.no_annot b/tests/cn_vip_testsuite/provenance_union_punning_2_global_yx.error.c.no_annot new file mode 100644 index 000000000..231e6daa4 --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_union_punning_2_global_yx.error.c.no_annot @@ -0,0 +1,4 @@ +return code: 2 +tests/cn_vip_testsuite/provenance_union_punning_2_global_yx.error.c:5:9: error: unsupported union types +typedef union { uintptr_t ui; int *p; } un; + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn_vip_testsuite/provenance_union_punning_3_global.c b/tests/cn_vip_testsuite/provenance_union_punning_3_global.pass.c similarity index 100% rename from tests/cn_vip_testsuite/provenance_union_punning_3_global.c rename to tests/cn_vip_testsuite/provenance_union_punning_3_global.pass.c diff --git a/tests/cn_vip_testsuite/provenance_union_punning_3_global.pass.c.no_annot b/tests/cn_vip_testsuite/provenance_union_punning_3_global.pass.c.no_annot new file mode 100644 index 000000000..b9ed6d88c --- /dev/null +++ b/tests/cn_vip_testsuite/provenance_union_punning_3_global.pass.c.no_annot @@ -0,0 +1,4 @@ +return code: 2 +tests/cn_vip_testsuite/provenance_union_punning_3_global.pass.c:5:9: error: unsupported union types +typedef union { uintptr_t ui; int *up; } un; + ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ diff --git a/tests/cn_vip_testsuite/with_annot.json b/tests/cn_vip_testsuite/with_annot.json new file mode 100644 index 000000000..24e73d01c --- /dev/null +++ b/tests/cn_vip_testsuite/with_annot.json @@ -0,0 +1,6 @@ +{ + "name": "with_annot", + "args": ["verify", "-DVIP", "-DANNOT", "-DNO_ROUND_TRIP", "--solver-type=cvc5" ], + "filter": "^((pointer_from_int_disambiguation_3\\.error\\.c)|(.*\\.annot\\.c))$", + "timeout": 35 +} diff --git a/tests/diff-prog.py b/tests/diff-prog.py new file mode 100755 index 000000000..744f22a61 --- /dev/null +++ b/tests/diff-prog.py @@ -0,0 +1,126 @@ +#!/usr/bin/env python3 + +import os, sys, re, subprocess, json, difflib, argparse, concurrent.futures, math + +def eprint(*args, then_exit=True, **kwargs): + print('Error:', *args, file=sys.stderr, **kwargs) + if then_exit: + exit(1) + +def time_cmd(cmd): + return ["/usr/bin/time", "--quiet", "--format", "%e"] + cmd + +class Prog: + + def __init__(self, opts, config): + self.prog = opts.prog + self.args = config['args'] + self.print_cmd = opts.dry_run or opts.verbose + self.run_cmd = not opts.dry_run + self.timeout = config['timeout'] + self.name = config['name'] + + def run(self, test_rel_path): + cmd = time_cmd([self.prog] + self.args + [test_rel_path]) + if self.print_cmd: + print(' '.join(cmd)) + if self.run_cmd: + return subprocess.run(cmd, stdout=subprocess.PIPE, stderr=subprocess.STDOUT, text=True, timeout=self.timeout) + else: + return None + + def output(self, test_rel_path): + try: + completed = self.run(test_rel_path); + lines = completed.stdout.splitlines(True) + time = float(lines[-1]) + return { 'time': time, 'lines' : [("return code: %d\n" % completed.returncode)] + lines[:-1] } + except subprocess.TimeoutExpired: + return { 'time': float(self.timeout), 'lines': ["TIMEOUT\n"] } + + def get_diff(self, test_rel_path): + expect_path = test_rel_path + '.' + self.name + if not os.path.isfile(expect_path): + open(expect_path, 'w') + with open(expect_path, 'r') as expect: + try: + output = self.output(test_rel_path) + diff = list(difflib.unified_diff(expect.readlines(), output['lines'], expect_path, expect_path)) + time = output['time'] + return { 'diff': diff, 'time': time } + except AttributeError: # dry run + return { 'diff': False, 'time': .0 } + +def test_files(test_dir, matcher): + if not os.path.isdir(test_dir): + eprint(f"'{test_dir}' not a directory") + for root, _, files in os.walk(test_dir): + for filename in files: + if matcher.match(filename) is not None: + yield os.path.join(root, filename) + +def filter_tests(test_dir, suffix, matcher): + inputs = test_files(test_dir, matcher) + if suffix is not None: + inputs = list(filter(lambda x : x.endswith(suffix), inputs)) + inputs_len = len(inputs) + if inputs_len > 1: + eprint(f'more than one file matching *{suffix} found in {test_dir}', then_exit=False) + eprint(inputs) + elif inputs_len == 0: + eprint(f'*{suffix} not found in {test_dir}') + return inputs + +def format_timing(name, value): + return { 'name': name, 'unit': 'Seconds', 'value': value } + +def run_tests(prog, test_rel_paths, quiet, max_workers): + test_rel_paths = list(test_rel_paths) + with concurrent.futures.ProcessPoolExecutor(max_workers=max_workers) as executor: + failed_tests = 0 + timings = [] + for test_rel_path, outcome in zip(test_rel_paths, executor.map(prog.get_diff, test_rel_paths), strict=True): + time = outcome['time'] + diff = outcome['diff'] + timings.append(format_timing(test_rel_path, time)) + if not prog.run_cmd: + continue + pass_fail = '\033[32m[ PASSED ]\033[m' + if diff: + failed_tests += 1 + sys.stderr.writelines(diff) + pass_fail = '\033[31m[ FAILED ]\033[m' + if not quiet: + print('%s %s' % (pass_fail, test_rel_path)) + return { 'code': min(failed_tests, 1), 'timings': timings } + +def output_bench(name, timings): + total = { 'name': 'Total benchmark time', 'unit': 'Seconds', 'value': math.fsum(timing['value'] for timing in timings) } + with open(('benchmark-data-%s.json' % name), 'w') as f: + json.dump([total] + timings, f, indent=2) + +def main(opts): + with open(opts.config) as config_file: + config = json.load(config_file) + prog = Prog(opts, config) + files = filter_tests(test_dir=os.path.dirname(opts.config), suffix=opts.suffix, matcher=re.compile(config['filter'])) + result = run_tests(prog, test_rel_paths=files, quiet=opts.quiet, max_workers=(1 if opts.bench else None)) + if opts.bench: + output_bench(config['name'], result['timings']) + return result['code'] + +# top level +parser = argparse.ArgumentParser(description="Script for running an executable and diffing the output.") +parser.set_defaults(func=(lambda _: parser.parse_args(['-h']))) +parser.add_argument('prog') +parser.add_argument('config', help='Path to JSON config file: { "name": string; "args": string list; "filter": python regexp; "timeout": seconds }.') +parser.add_argument('-v', '--verbose', help='Print commands used.', action='store_true') +parser.add_argument('--dry-run', help='Print but do not run commands.', action='store_true') +parser.add_argument('--suffix', help='Uniquely identifying suffix of a file in the test directory.') +parser.add_argument('--quiet', help='Don\'t show tests completed so far on std out.', action='store_true') +parser.add_argument('--bench', help='Output a JSON file with benchmarks, including total time.', action='store_true') +parser.set_defaults(func=main) + +# parse args and call func (as set using set_defaults) +opts = parser.parse_args() +exit(opts.func(opts)) diff --git a/tests/run-cn-exec.sh b/tests/run-cn-exec.sh index 9952f0781..1f7319fd6 100755 --- a/tests/run-cn-exec.sh +++ b/tests/run-cn-exec.sh @@ -17,7 +17,7 @@ CHECK_SCRIPT="${RUNTIME_PREFIX}/libexec/cn-runtime-single-file.sh" [ -f "${CHECK_SCRIPT}" ] || echo_and_err "Could not find single file helper script: ${CHECK_SCRIPT}" -SCRIPT_OPT="-oq" +SCRIPT_OPT="-q" function exits_with_code() { local file=$1 @@ -102,7 +102,7 @@ SUCCESS=$(find cn -name '*.c' \ ! -name "int_to_ptr.c" \ ! -name "int_to_ptr.error.c" \ ! -name "create_rdonly.c" \ - ! -name "to_from_bytes_block.c" \ + ! -name "offsetof_int_const.c" \ ) # Include files which cause error for proof but not testing @@ -169,7 +169,7 @@ BUGGY="cn/division_casting.c \ cn/int_to_ptr.c \ cn/int_to_ptr.error.c \ cn/create_rdonly.c \ - cn/to_from_bytes_block.c \ + cn/offsetof_int_const.c \ " # Exclude files which cause error for proof but not testing diff --git a/tests/run-cn-lemmas.sh b/tests/run-cn-lemmas.sh new file mode 100755 index 000000000..7fe3a4ab1 --- /dev/null +++ b/tests/run-cn-lemmas.sh @@ -0,0 +1,42 @@ +#!/usr/bin/env bash +set -euo pipefail -o noclobber + +function exits_with_code() { + local action=$1 + local file=$2 + local -a expected_exit_codes=$3 + + printf "[$file]...\n" + timeout 60 ${action} "$file" + local result=$? + + for code in "${expected_exit_codes[@]}"; do + if [ $result -eq $code ]; then + printf "\033[32mPASS\033[0m\n" + return 0 + fi + done + + printf "\033[31mFAIL\033[0m (Unexpected return code: %d)\n" "$result" + return 1 +} + +DIRNAME=$(dirname "$0") + +FAILED="" + +COQ_LEMMAS=$(find "${DIRNAME}"/cn -type d -name 'coq_lemmas') + +for TEST in ${COQ_LEMMAS}; do + if ! exits_with_code "make -C" "${TEST}" 0; then + FAILED+=" ${TEST}" + fi +done + +if [ -z "${FAILED}" ]; then + exit 0 +else + printf "\033[31mFAILED: %s\033[0m\n" "${FAILED}" + exit 1 +fi + diff --git a/tests/run-cn-test-gen.sh b/tests/run-cn-test-gen.sh index 2ecfc72da..bfb477a1e 100755 --- a/tests/run-cn-test-gen.sh +++ b/tests/run-cn-test-gen.sh @@ -27,45 +27,56 @@ function separator() { printf '\n\n' } -# Test each `*.c` file -for TEST in $FILES; do - CLEANUP="rm -rf test/* run_tests.sh;separator" +CONFIGS=("--coverage" "--with-static-hack --coverage" "--sized-null" "--random-size-splits" "--random-size-splits --allowed-size-split-backtracks=10") - # Run passing tests - if [[ $TEST == *.pass.c ]]; then - $CN test "$TEST" --output-dir="test" --with-ownership-checking - RET=$? - if [[ "$RET" != 0 ]]; then - echo - echo "$TEST -- Tests failed unexpectedly" - NUM_FAILED=$(($NUM_FAILED + 1)) - FAILED="$FAILED $TEST" - eval "$CLEANUP" - continue - else - echo - echo "$TEST -- Tests passed successfully" +# For each configuration +for CONFIG in "${CONFIGS[@]}"; do + separator + echo "Running CI with CLI config \"$CONFIG\"" + separator + + FULL_CONFIG="$CONFIG --input-timeout=1000 --progress-level=1" + + # Test each `*.c` file + for TEST in $FILES; do + CLEANUP="rm -rf test/* run_tests.sh;separator" + + # Run passing tests + if [[ $TEST == *.pass.c ]]; then + $CN test "$TEST" --output-dir="test" $FULL_CONFIG + RET=$? + if [[ "$RET" != 0 ]]; then + echo + echo "$TEST -- Tests failed unexpectedly" + NUM_FAILED=$(($NUM_FAILED + 1)) + FAILED="$FAILED $TEST($CONFIG)" + eval "$CLEANUP" + continue + else + echo + echo "$TEST -- Tests passed successfully" + fi fi - fi - # Run failing tests - if [[ $TEST == *.fail.c ]]; then - $CN test "$TEST" --output-dir="test" --with-ownership-checking - RET=$? - if [[ "$RET" = 0 ]]; then - echo - echo "$TEST -- Tests passed unexpectedly" - NUM_FAILED=$(($NUM_FAILED + 1)) - FAILED="$FAILED $TEST" - eval "$CLEANUP" - continue - else - echo - echo "$TEST -- Tests failed successfully" + # Run failing tests + if [[ $TEST == *.fail.c ]]; then + $CN test "$TEST" --output-dir="test" $FULL_CONFIG + RET=$? + if [[ "$RET" = 0 ]]; then + echo + echo "$TEST -- Tests passed unexpectedly" + NUM_FAILED=$(($NUM_FAILED + 1)) + FAILED="$FAILED $TEST($CONFIG)" + eval "$CLEANUP" + continue + else + echo + echo "$TEST -- Tests failed successfully" + fi fi - fi - eval "$CLEANUP" + eval "$CLEANUP" + done done echo 'Done running tests.' diff --git a/tests/run-cn-tutorial-ci.sh b/tests/run-cn-tutorial-ci.sh index 753086dd7..da33d5add 100755 --- a/tests/run-cn-tutorial-ci.sh +++ b/tests/run-cn-tutorial-ci.sh @@ -10,9 +10,6 @@ else exit 1 fi -# copying from run-ci.sh -export DYLD_LIBRARY_PATH=$DYLD_LIBRARY_PATH:`ocamlfind query z3` -export LD_LIBRARY_PATH=$LD_LIBRARY_PATH:`ocamlfind query z3` CN=$OPAM_SWITCH_PREFIX/bin/cn HERE=$(pwd) diff --git a/tests/run-cn-vip.sh b/tests/run-cn-vip.sh index b6640b154..57db20ac4 100755 --- a/tests/run-cn-vip.sh +++ b/tests/run-cn-vip.sh @@ -1,103 +1,7 @@ #!/usr/bin/env bash set -euo pipefail -o noclobber -# copying from run-ci.sh -# Z3=$(ocamlfind query z3) -# export DYLD_LIBRARY_PATH="${DYLD_LIBRARY_PATH:-}:${Z3}" -# export LD_LIBRARY_PATH="${LD_LIBRARY_PATH:-}:${Z3}" - -USAGE="USAGE: $0 [-h]" - -function echo_and_err() { - printf "%s\n" "$1" - exit 1 -} - -LEMMATA=0 - -while getopts "h" flag; do - case "$flag" in - h) - printf "%s\n" "${USAGE}" - exit 0 - ;; - \?) - echo_and_err "${USAGE}" - ;; - esac -done - -function exits_with_code() { - local action=$1 - local file=$2 - local -a expected_exit_codes=$3 - - printf "[$file]...\n" - timeout 35 ${action} "$file" &> /dev/null - local result=$? - - for code in "${expected_exit_codes[@]}"; do - if [ $result -eq $code ]; then - printf "\033[32mPASS\033[0m\n" - return 0 - fi - done - - printf "\033[31mFAIL\033[0m (Unexpected return code: %d)\n" "$result" - return 1 -} - -DIRNAME=$(dirname "$0") - -SUCC=$( - find $DIRNAME/cn_vip_testsuite -name '*.c' \ - \! -name '*union*.c' \ - \! -name '*.unprovable.c' \ - \! -name '*.annot.c' \ - \! -name '*.error.c' \ -) -UNION=$(find $DIRNAME/cn_vip_testsuite -name '*union*.c') -UNPROV=$(find $DIRNAME/cn_vip_testsuite -name '*.unprovable.c' \ - \! -name 'pointer_copy_user_ctrlflow_bytewise.unprovable.c') - # this test hits a CN performance bug -FAIL=$(find $DIRNAME/cn_vip_testsuite -name '*.error.c' \! -name '*union*.c') -ANNOT=$(find $DIRNAME/cn_vip_testsuite -name '*.annot.c') - -FAILED='' - -for TEST in ${SUCC} ${ANNOT}; do - if ! exits_with_code "cn verify -DVIP -DANNOT -DNO_ROUND_TRIP --solver-type=cvc5" "${TEST}" 0; then - FAILED+=" ${TEST}" - fi -done - -for TEST in $FAIL $ANNOT $UNPROV; do - if ! exits_with_code "cn verify -DVIP -DNO_ROUND_TRIP --solver-type=cvc5" "${TEST}" 1; then - FAILED+=" ${TEST}" - fi -done - - -NON_DET=( - $DIRNAME/provenance_equality_auto_yx.c \ - $DIRNAME/provenance_equality_global_fn_yx.c \ - $DIRNAME/provenance_equality_global_yx.c \ -) - -for TEST in $NON_DET; do - if ! exits_with_code "cn verify -DVIP -DNO_ROUND_TRIP -DNON_DET_TRUE --solver-type=cvc5" "${TEST}" 1; then - FAILED+=" ${TEST} (nd. true)" - fi - if ! exits_with_code "cn verify -DVIP -DNO_ROUND_TRIP -DNON_DET_FALSE --solver-type=cvc5" "${TEST}" 1; then - FAILED+=" ${TEST} (nd. false)" - fi -done - -if [ -z "${FAILED}" ]; then - exit 0 -else - printf "\033[31mFAILED: %s\033[0m\n" "${FAILED}" - exit 1 -fi - - +for file in "$(dirname $0)"/cn_vip_testsuite/*.json +do + ./tests/diff-prog.py cn "$file" 2> "${file%.json}.patch" || (cat "${file%.json}.patch"; exit 1) +done || exit 1 diff --git a/tests/run-cn.sh b/tests/run-cn.sh index 610597c01..848d445b3 100755 --- a/tests/run-cn.sh +++ b/tests/run-cn.sh @@ -13,6 +13,8 @@ function echo_and_err() { exit 1 } +printf "\033[31mDEPRECATED\033[0m please use diff-prog.py (see ci-cn.yml)\n" + LEMMATA=0 while getopts "hl" flag; do diff --git a/util/cerb_colour.ml b/util/cerb_colour.ml index 00985d86e..020746f6b 100644 --- a/util/cerb_colour.ml +++ b/util/cerb_colour.ml @@ -34,6 +34,13 @@ let int_fg = function let do_colour = ref (Unix.isatty Unix.stdout) +let with_colour f x = + let col = ! do_colour in + do_colour := true; + let r = f x in + do_colour := col; + r + let without_colour f x = let col = ! do_colour in do_colour := false; diff --git a/util/cerb_colour.mli b/util/cerb_colour.mli index 39b2449ef..8264cba5d 100644 --- a/util/cerb_colour.mli +++ b/util/cerb_colour.mli @@ -16,6 +16,7 @@ type ansi_style = type ansi_format = ansi_style list val do_colour: bool ref +val with_colour: ('a -> 'b) -> 'a -> 'b val without_colour: ('a -> 'b) -> 'a -> 'b val ansi_format: ?err:bool -> ansi_format -> string -> string val pp_ansi_format: ?err:bool -> ansi_format -> (unit -> PPrint.document) -> PPrint.document