diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 0d8424690..2fbb6dd54 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -29,7 +29,7 @@ jobs: - uses: actions/setup-python@v4 with: python-version: "3.10" - - uses: ocaml/setup-ocaml@v2 + - uses: ocaml/setup-ocaml@v3 with: ocaml-compiler: "ocaml-variants.5.2.0+options" - name: Installing Python prerequisites @@ -38,7 +38,7 @@ jobs: id: restore-cache uses: actions/cache@v3 env: - cache-name: cache-ocaml + cache-name: cache-ocaml with: path: _opam key: ${{ runner.os }}-${{ env.cache-name}}-ocaml-5.2.0-${{ hashFiles('**/*.opam') }} @@ -47,10 +47,15 @@ jobs: - name: Install dependencies run: make init-ci + - name: Install ubuntu dependencies + run: sudo apt-get install libgmp-dev pkg-config libsqlite3-dev python3 z3 -y + if: runner.os == 'Linux' - name: Build Gillian run: opam exec -- dune build @all - name: Basic tests run: opam exec -- dune test + - name: Gillian-LLVM Tests + run: opam exec -- dune exec gillian-llvm -- bulk-wpst Gillian-LLVM/examples/wpst - name: Wisl checks run: "opam exec -- dune exec -- bash ./wisl/scripts/quicktests.sh" - name: Format checking @@ -69,12 +74,12 @@ jobs: - name: Building docs run: make docs if: runner.os == 'Linux' - - name: Sending docs artifact - uses: actions/upload-artifact@v4 - with: - name: ${{ runner.os }}-docs - path: _docs - if: runner.os == 'Linux' + # - name: Sending docs artifact + # uses: actions/upload-artifact@v4 + # with: + # name: ${{ runner.os }}-docs + # path: _docs + # if: runner.os == 'Linux' - name: Setting dependency cache run: opam clean if: steps.restore-cache.outputs.cache-hit != 'true' @@ -265,7 +270,7 @@ jobs: # if: ( github.event_name == 'pull_request') && ( github.base_ref == 'master') # strategy: # matrix: - # operating-system: [macos-latest] + # operating-system: [ubuntu-latest] # runs-on: ${{ matrix.operating-system }} # needs: build # steps: @@ -284,14 +289,159 @@ jobs: # - name: Download release # uses: actions/download-artifact@v4 # with: - # name: ${{ runner.os }}-opam - # path: opam + # name: ${{ runner.os }}-opam + # path: opam + # - name: Extract release + # run: | + # tar xzf opam/opam.tar.gz + # rm opam -rf + # - name: init env + # run: "Gillian-JS/scripts/setup_environment.sh" + # working-directory: "Gillian" + # - name: Test JaVerT + # run: "./testJaVerT.sh" + # working-directory: "Gillian/Gillian-JS/environment/" + # # - name: Test Amazon + # # run: "make" + # # working-directory: "Gillian/Gillian-JS/Examples/Amazon/" + + # kanillian_c_tests: + # strategy: + # matrix: + # operating-system: [ubuntu-latest] + # runs-on: ${{ matrix.operating-system }} + # needs: build + # steps: + # - name: Setup Z3 + # id: z3 + # uses: cda-tum/setup-z3@v1 + # env: + # GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + # - uses: ocaml/setup-ocaml@v2 + # with: + # ocaml-compiler: "ocaml-variants.5.2.0+options" + # - name: install CBMC + # run: sudo apt install cbmc -y + # - name: Checkout project + # uses: actions/checkout@v3 + # with: + # path: Gillian + # - name: Download release + # uses: actions/download-artifact@v4 + # with: + # name: ${{ runner.os }}-opam + # path: opam + # - name: Extract release + # run: | + # tar xzf opam/opam.tar.gz + # rm -rf opam + # - name: init env + # run: "kanillian/scripts/setup_environment.sh" + # working-directory: "Gillian" + # - name: Test All + # run: "opam exec -- bash ./testAll.sh" + # working-directory: "Gillian/kanillian/environment/" + + # test262: + # if: ( github.event_name == 'pull_request') && ( github.base_ref == 'master') + # strategy: + # matrix: + # operating-system: [ubuntu-latest] + # runs-on: ${{ matrix.operating-system }} + # needs: build + # steps: + # - name: Setup Z3 + # id: z3 + # uses: cda-tum/setup-z3@v1 + # env: + # GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + # - uses: ocaml/setup-ocaml@v2 + # with: + # ocaml-compiler: "ocaml-variants.5.2.0+options" + # - name: Checkout project + # uses: actions/checkout@v3 + # with: + # repository: GillianPlatform/javert-test262 + # path: test262 + # ref: 93e0d0b04093cabc3234a776eec5cc3e165f3b1a + # - name: Download release + # uses: actions/download-artifact@v4 + # with: + # name: ${{ runner.os }}-opam + # path: opam # - name: Extract release # run: | # tar xzf opam/opam.tar.gz # rm -rf opam - # - name: Symbolic Testing Buckets.js - # run: "opam exec -- gillian-js cosette-bulk Gillian/Gillian-JS/Examples/Cosette/Buckets --ci" + # - name: Test262 + # run: "opam exec -- gillian-js test262 test262/test --ci" + + # collections-c: + # if: ( github.event_name == 'pull_request') && ( github.base_ref == 'master') + # strategy: + # matrix: + # operating-system: [ubuntu-latest] + # runs-on: ${{ matrix.operating-system }} + # needs: build + # steps: + # - name: Setup Z3 + # id: z3 + # uses: cda-tum/setup-z3@v1 + # env: + # GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + # - uses: ocaml/setup-ocaml@v2 + # with: + # ocaml-compiler: "ocaml-variants.5.2.0+options" + # - name: checkout project + # uses: actions/checkout@v3 + # with: + # repository: GillianPlatform/collections-c-for-gillian + # path: collections-c + # ref: ffa76e788a1fbdb67910bb7b794214ebc22c1b8c + # - name: Download release + # uses: actions/download-artifact@v4 + # with: + # name: ${{ runner.os }}-opam + # path: opam + # - name: Extract release + # run: | + # tar xzf opam/opam.tar.gz + # rm -rf opam + # - name: Symbolic Testing Collections-C + # run: "opam exec -- bash ./scripts/gillian-compcert/runTests.sh" + # working-directory: collections-c + + # # test-Buckets: + # # if: ( github.event_name == 'pull_request') && ( github.base_ref == 'master') + # # strategy: + # # matrix: + # # operating-system: [macos-latest] + # # runs-on: ${{ matrix.operating-system }} + # # needs: build + # # steps: + # # - name: Setup Z3 + # # id: z3 + # # uses: cda-tum/setup-z3@v1 + # # env: + # # GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + # # - uses: ocaml/setup-ocaml@v2 + # # with: + # # ocaml-compiler: "ocaml-variants.5.2.0+options" + # # - name: Checkout project + # # uses: actions/checkout@v3 + # # with: + # # path: Gillian + # # - name: Download release + # # uses: actions/download-artifact@v4 + # # with: + # # name: ${{ runner.os }}-opam + # # path: opam + # # - name: Extract release + # # run: | + # # tar xzf opam/opam.tar.gz + # # rm -rf opam + # # - name: Symbolic Testing Buckets.js + # # run: "opam exec -- gillian-js cosette-bulk Gillian/Gillian-JS/Examples/Cosette/Buckets --ci" build-docker: runs-on: ubuntu-latest @@ -306,7 +456,7 @@ jobs: id: restore-cache uses: actions/cache@v3 env: - cache-name: cache-ocaml + cache-name: cache-ocaml with: path: .docker_opam_cache key: docker-${{ env.cache-name }}-ocaml-5.2.0-${{ hashFiles('**/*.opam') }} @@ -329,28 +479,28 @@ jobs: docker cp deps:/home/opam/.opam/5.2 ./.docker_opam_cache docker rm deps - deploy-docs: - if: github.ref == 'refs/heads/master' - runs-on: ubuntu-latest - needs: [build] - strategy: - fail-fast: false - matrix: - operating-system: [ubuntu-latest] - steps: - - name: Download built docs - uses: actions/download-artifact@v4 - with: - name: ${{ runner.os }}-docs - path: docs - - name: Deploy docs - run: | - git config --global user.email "<>" - git config --global user.name "GitHub Actions" - git clone https://${{ secrets.DOCS_USER }}:${{ secrets.DOCS_TOKEN }}@github.com/GillianPlatform/GillianPlatform.github.io.git docs-repo --branch master - cd docs-repo - rm * -rf - cp -r ../docs/* . - git add -A - git commit --allow-empty -m "Deployment from $GITHUB_REPOSITORY@$GITHUB_SHA" - git push --force + # deploy-docs: + # if: github.ref == 'refs/heads/master' + # runs-on: ubuntu-latest + # needs: [build] + # strategy: + # fail-fast: false + # matrix: + # operating-system: [ubuntu-latest] + # steps: + # - name: Download built docs + # uses: actions/download-artifact@v4 + # with: + # name: ${{ runner.os }}-docs + # path: docs + # - name: Deploy docs + # run: | + # git config --global user.email "<>" + # git config --global user.name "GitHub Actions" + # git clone https://${{ secrets.DOCS_USER }}:${{ secrets.DOCS_TOKEN }}@github.com/GillianPlatform/GillianPlatform.github.io.git docs-repo --branch master + # cd docs-repo + # rm * -rf + # cp -r ../docs/* . + # git add -A + # git commit --allow-empty -m "Deployment from $GITHUB_REPOSITORY@$GITHUB_SHA" + # git push --force diff --git a/.vscode/settings.json b/.vscode/settings.json index 2e60c7517..ba336e845 100644 --- a/.vscode/settings.json +++ b/.vscode/settings.json @@ -20,7 +20,7 @@ "python.pythonPath": "/usr/bin/python3", "ocaml.sandbox": { "kind": "opam", - "switch": "${workspaceFolder:Gillian}" + "switch": "ocaml-variants.5.2.0+options" }, // Turn off tsc task auto detection since we have the necessary tasks as npm scripts "typescript.tsc.autoDetect": "off" diff --git a/Gillian-Alcotest-Runner/alcotestCheckers.ml b/Gillian-Alcotest-Runner/alcotestCheckers.ml index 828908bf7..1a95837ab 100644 --- a/Gillian-Alcotest-Runner/alcotestCheckers.ml +++ b/Gillian-Alcotest-Runner/alcotestCheckers.ml @@ -6,6 +6,7 @@ module Make (Outcome : Bulk.Outcome.S) = struct (Outcome.ParserAndCompiler.err -> bool) -> Outcome.t -> unit; + finish_in_fail : Outcome.t -> unit; fail_at_exec : Outcome.t -> unit; finish_in_error_mode : BranchReasoning.branches -> Outcome.t -> unit; finish_in_error_mode_with : diff --git a/Gillian-Alcotest-Runner/alcotestFramework.ml b/Gillian-Alcotest-Runner/alcotestFramework.ml index 556f0efa3..0a3b9b46d 100644 --- a/Gillian-Alcotest-Runner/alcotestFramework.ml +++ b/Gillian-Alcotest-Runner/alcotestFramework.ml @@ -56,6 +56,13 @@ module Make (Outcome : Outcome.S) = struct let finish_in_error_mode = make_check_finish_in_mode ~flag:Flag.Error ~expected:None + let finish_in_fail test = + match test with + | Outcome.FinishedExec [ RFail _ ] -> () + | _ -> + Alcotest.failf "Expected the test to end with fail \nBut the test %a" + Outcome.pp_what_test_did test + let finish_in_error_mode_with branches ~constraint_name constr = make_check_finish_in_mode ~flag:Flag.Error ~expected:(Some (constraint_name, constr)) @@ -78,5 +85,6 @@ module Make (Outcome : Outcome.S) = struct finish_in_error_mode_with; finish_in_normal_mode; finish_in_normal_mode_with; + finish_in_fail; } end diff --git a/Gillian-LLVM/bin/dune b/Gillian-LLVM/bin/dune new file mode 100644 index 000000000..8bafa11c4 --- /dev/null +++ b/Gillian-LLVM/bin/dune @@ -0,0 +1,5 @@ +(executable + (name gillian_llvm) + (public_name gillian-llvm) + (libraries gillian_llvm_lib gillian llvm_memory_model lifter) + (package gillian-llvm)) diff --git a/Gillian-LLVM/bin/gillian_llvm.ml b/Gillian-LLVM/bin/gillian_llvm.ml new file mode 100644 index 000000000..6a18148d4 --- /dev/null +++ b/Gillian-LLVM/bin/gillian_llvm.ml @@ -0,0 +1,99 @@ +open Llvm_memory_model +module SMemory = Memories.SMemory +module Init_data = Gillian.General.Init_data.Dummy +module DummyParserAndCompiler = ParserAndCompiler.Dummy + +module DummyLifter (V : Gillian.Abstraction.Verifier.S) : + Debugger_lifter.S + with type memory = SMemory.t + and type memory_error = SMemory.err_t + and type tl_ast = DummyParserAndCompiler.tl_ast + and type cmd_report = V.SAInterpreter.Logging.ConfigReport.t + and type annot = DummyParserAndCompiler.Annot.t + and type init_data = DummyParserAndCompiler.init_data + and type pc_err = DummyParserAndCompiler.err = struct + type pc_err = DummyParserAndCompiler.err + type init_data = unit + type t = unit + type memory = SMemory.t + type memory_error = SMemory.err_t + type tl_ast = DummyParserAndCompiler.tl_ast + type cmd_report = V.SAInterpreter.Logging.ConfigReport.t + type annot = DummyParserAndCompiler.Annot.t + + type exec_args = + Logging.Report_id.t option + * Gil_syntax.Branch_case.t option + * Gil_syntax.Branch_case.path + + type _ Effect.t += + | Step : + exec_args + -> cmd_report Gillian.Debugger.Lifter.executed_cmd_data Effect.t + + let init + ~proc_name:_ + ~all_procs:_ + (_st : tl_ast option) + (_prg : (annot, int) Gil_syntax.Prog.t) = + raise (Failure "unsupported") + + (** Exception-raising version of {!init}. *) + let init_exn + ~proc_name:_ + ~all_procs:_ + (_st : tl_ast option) + (_p : (annot, int) Gil_syntax.Prog.t) = + raise (Failure "unsupported") + + (** Gives a JSON representation of the lifter's state. + + Used for debugging problems with the lifter.*) + let dump (_st : t) = raise (Failure "unsupported") + + let step_over (_ : t) (_ : Logging.Report_id.t) = + raise (Failure "unsupported") + + let step_in _ _ = raise (Failure "unsupported") + let step_out _ _ = raise (Failure "unsupported") + let step_back _ _ = raise (Failure "unsupported") + let step_branch _ _ _ = raise (Failure "unsupported") + let continue _ _ = raise (Failure "unsupported") + let continue_back _ _ = raise (Failure "unsupported") + + (** Gets the non-lifted execution map of GIL commands. + + In most cases, it's recommended to use a {!Gil_fallback_lifter}, and just + defer this call to the GIL lifter. *) + let get_gil_map _ = raise (Failure "unsupported") + + (** Gets the lifted execution map. + + Returns [None] if lifting is not supported. *) + let get_lifted_map _ = raise (Failure "unsupported") + + (** Exception-raising version of {!get_lifted_map}. *) + let get_lifted_map_exn _ = raise (Failure "unsupported") + + (** Gives a list of matches that occurred at the specified command. *) + let get_matches_at_id _ _ = raise (Failure "unsupported") + + let memory_error_to_exception_info _ = raise (Failure "unsupported") + + let add_variables ~store:_ ~memory:_ ~is_gil_file:_ ~get_new_scope_id:_ _ = + raise (Failure "unsupported") + + let parse_and_compile_files ~entrypoint:_ fls = raise (Failure "unsupported") +end + +module CLI = + Gillian.Command_line.Make (Init_data) (States.Cmemory.Make(Init_data)) (SMemory) + (DummyParserAndCompiler) + (LLVM.ExternalSemantics) + (struct + let runners : Gillian.Bulk.Runner.t list = + [ (module Gillian_llvm_lib.SRunner) ] + end) + (DummyLifter) + +let () = CLI.main () diff --git a/Gillian-LLVM/examples/.gitignore b/Gillian-LLVM/examples/.gitignore new file mode 100644 index 000000000..737b7a752 --- /dev/null +++ b/Gillian-LLVM/examples/.gitignore @@ -0,0 +1,2 @@ +*.symtab.json +!*.gil \ No newline at end of file diff --git a/Gillian-LLVM/examples/act/ptr_abduction_test.gil b/Gillian-LLVM/examples/act/ptr_abduction_test.gil new file mode 100644 index 000000000..91f75a280 --- /dev/null +++ b/Gillian-LLVM/examples/act/ptr_abduction_test.gil @@ -0,0 +1,17 @@ + +bispec load_a_ptr(x) : [[types(x : List); ((l-len x) == 2i)]] +proc load_a_ptr(x) { + ptr_offset := l-nth(x, 1i); + ptr_label := l-nth(x, 0i); + + ptr_l := [load]("i-or-ptr", ptr_label, ptr_offset); + ptr2_l := l-nth(ptr_l, 0i); + + ptr2_label := l-nth(ptr2_l, 0i); + ptr2_offset := l-nth(ptr2_l, 1i); + + loaded_integer := [load]("i-or-ptr", ptr2_label, ptr2_offset); + ret := l-nth(loaded_integer, 0i); + + return +}; diff --git a/Gillian-LLVM/examples/act/spec_test.gil b/Gillian-LLVM/examples/act/spec_test.gil new file mode 100644 index 000000000..fb27a78ba --- /dev/null +++ b/Gillian-LLVM/examples/act/spec_test.gil @@ -0,0 +1,23 @@ + +axiomatic spec foo(x) [[((typeOf(x) == Bitvector(64i) /\ (x==0x1v64)))]] [[emp]] bug + +bispec foo(x) : [[((typeOf(x) == Bitvector(64i) /\ (x==0x2v64)))]] +proc foo(x) { + ret := 1i; + return +}; + + +bispec load_a_ptr(x) : [[types(x : List) * ((l-len x) == 2i)]] +proc load_a_ptr(x) { + ptr_offset := l-nth(x, 1i); + ptr_label := l-nth(x, 0i); + + ptr_l := [load]("i-or-ptr", ptr_label, ptr_offset); + ivalue := l-nth(ptr_l, 0i); + assert(((l-nth(ivalue, 0i) == "int-64" /\ typeOf(l-nth(ivalue, 1i)) == Bitvector(64i)) + \/ (l-nth(ivalue, 0i) == "ptr" /\ typeOf(l-nth(ivalue, 1i)) == List))); + i := l-nth(ivalue, 1i); + ret := "foo"(i); + return +}; diff --git a/Gillian-LLVM/examples/act/type_regression_test.gil b/Gillian-LLVM/examples/act/type_regression_test.gil new file mode 100644 index 000000000..62af78315 --- /dev/null +++ b/Gillian-LLVM/examples/act/type_regression_test.gil @@ -0,0 +1,17 @@ + + + + +bispec load_a_ptr(x) : [[types(x : List) * ((l-len x) == 2i)]] +proc load_a_ptr(x) { + ptr_offset := l-nth(x, 1i); + ptr_label := l-nth(x, 0i); + + ptr_l := [load]("i-or-ptr", ptr_label, ptr_offset); + ivalue := l-nth(ptr_l, 0i); + assert(((l-nth(ivalue, 0i) == "int-64" /\ typeOf(l-nth(ivalue, 1i)) == Bitvector(64i)) + \/ (l-nth(ivalue, 0i) == "ptr" /\ typeOf(l-nth(ivalue, 1i)) == List))); + i := l-nth(ivalue, 0i); + ret := 1i; + return +}; diff --git a/Gillian-LLVM/examples/wpst/fail/ptr_overflow_test.gil b/Gillian-LLVM/examples/wpst/fail/ptr_overflow_test.gil new file mode 100644 index 000000000..741a2da89 --- /dev/null +++ b/Gillian-LLVM/examples/wpst/fail/ptr_overflow_test.gil @@ -0,0 +1,12 @@ +proc main() { + x := fresh_svar(); + assume_type(x, Bitvector(64i)); + xval := {{ "int-64", x}}; + ptr_l := [alloc](0i, 4i); + ptr_label := l-nth(ptr_l, 0i); + a := [store]("i-64", ptr_label, 0i, xval); + b := [load]("i-64", ptr_label, 0i); + value := l-nth(b, 0i); + ret := l-nth(value, 1i); + return +}; \ No newline at end of file diff --git a/Gillian-LLVM/examples/wpst/succeed/mem_test.gil b/Gillian-LLVM/examples/wpst/succeed/mem_test.gil new file mode 100644 index 000000000..de6a36409 --- /dev/null +++ b/Gillian-LLVM/examples/wpst/succeed/mem_test.gil @@ -0,0 +1,43 @@ + +proc split_vector(x) { + xtopslice := extract(31i, 16i, Bitvector(x, 32i): 16i); + xbotslice := extract(15i, 0i, Bitvector(x, 32i): 16i); + ret := {{ xtopslice, xbotslice }}; + return +}; + +proc main() { + x := fresh_svar(); + y := fresh_svar(); + splitx := "split_vector"(x); + splity := "split_vector"(y); + xtopslice := l-nth(splitx,0i); + xbotslice := l-nth(splitx,1i); + ytopslice := l-nth(splity,0i); + ybotslice := l-nth(splity,1i); + + newx := concat(Bitvector(xtopslice, 16i), Bitvector(ybotslice, 16i) : 32i); + newy := concat(Bitvector(ytopslice, 16i), Bitvector(xbotslice, 16i) : 32i); + + sum0 := bvadd(Bitvector(x,32i), Bitvector(y,32i): 32i); + sum1 := bvadd(Bitvector(newx,32i), Bitvector(newy,32i): 32i); + ptrptr_l := [alloc](0i, 8i); + ptrptr := l-nth(ptrptr_l, 0i); + xptr_l := [alloc](0i, 32i); + xptr := l-nth(xptr_l, 0i); + xptr_with_offset := {{"ptr", {{ xptr, 0i }}}}; + b := [store]("i-or-ptr", ptrptr, 0i, xptr_with_offset); + a := [store]("i-32", xptr, 0i, {{"int-32", sum0}}); + xptr2_l := [load]("i-or-ptr", ptrptr, 0i); + typed_xptr2_l := l-nth(xptr2_l, 0i); + xptr2_with_offset := l-nth(typed_xptr2_l, 1i); + xptr2 := l-nth(xptr2_with_offset, 0i); + xptr2_offset := l-nth(xptr2_with_offset, 1i); + rtt_l_typed_l := [load]("i-32", xptr2, xptr2_offset); + rtt_typed := l-nth(rtt_l_typed_l, 0i); + rtt := l-nth(rtt_typed, 1i); + assert((!(bvult(Bitvector(sum1, 32i), Bitvector(sum0, 32i):)))); + assert((rtt == sum1)); + ret := x; + return +}; diff --git a/Gillian-LLVM/examples/wpst/succeed/repro_gil_c.gil b/Gillian-LLVM/examples/wpst/succeed/repro_gil_c.gil new file mode 100644 index 000000000..7dc9f3274 --- /dev/null +++ b/Gillian-LLVM/examples/wpst/succeed/repro_gil_c.gil @@ -0,0 +1,31 @@ +proc main() { + x := fresh_svar(); + assume((x == 0i)); + goto [ x = 1i ] true_case false_case; + true_case: + y := fresh_svar(); + assume_type(y, Bitvector(32i)); + z := {{ "int-32", y}}; + tyy := typeOf y; + assert((tyy == Bitvector(32i))); + goto end; + false_case: + y := fresh_svar(); + assume_type(y, Num); + tyy := typeOf y; + assert((tyy == Num)); + assume((y == 1.0)); + z := {{ "float", y}}; + + + end: + ptr_l := [alloc](0i, 4i); + ptr := l-nth(ptr_l, 0i); + a := [store]("i-32", ptr, 0i, z); + b := [load]("i-32", ptr, 0i); + end_val := l-nth(b, 0i); + value := l-nth(end_val, 1i); + assert((true)); + ret := end_val; + return +}; diff --git a/Gillian-LLVM/lib/NoopParser.ml b/Gillian-LLVM/lib/NoopParser.ml new file mode 100644 index 000000000..f075febdc --- /dev/null +++ b/Gillian-LLVM/lib/NoopParser.ml @@ -0,0 +1,47 @@ +open Gillian +module Gil_parser = Gil_parsing.Make (Gil_syntax.Annot.Basic) + +module TargetLangOptions = struct + type t = unit + + let term = Cmdliner.Term.(const ()) + let apply () = () +end + +type init_data = unit +type tl_ast = unit + +module Annot = Gil_syntax.Annot.Basic + +type err = unit + +let pp_err _ _ = + failwith + "Please implement the compiling interface to use with the '-compile' flag \ + or test suites" + +let parse_and_compile_files files : + ( ( Gil_parser.annot, + init_data, + tl_ast ) + Gillian.Command_line.ParserAndCompiler.compiled_progs, + unit ) + result = + let eprogs = + List.map + (fun fl -> + let eprog = Gil_parser.parse_eprog_from_file fl in + (fl, eprog.labeled_prog)) + files + in + Ok + { + gil_progs = eprogs; + source_files = Gillian.IncrementalAnalysis.SourceFiles.make (); + tl_ast = (); + init_data = (); + } + +let other_imports = [] +let default_import_paths = None +let initialize _ = () diff --git a/Gillian-LLVM/lib/dune b/Gillian-LLVM/lib/dune new file mode 100644 index 000000000..460cbdab2 --- /dev/null +++ b/Gillian-LLVM/lib/dune @@ -0,0 +1,14 @@ +(library + (name gillian_llvm_lib) + (libraries + gillian + gillian.parserAndCompiler + llvm_memory_model + yojson + irep_lib + dune-site + gillian.alcotest-runner)) + +(generate_sites_module + (module runtime_sites) + (sites gillian-llvm)) diff --git a/Gillian-LLVM/lib/llvm_memory_model/BlockTree.ml b/Gillian-LLVM/lib/llvm_memory_model/BlockTree.ml new file mode 100644 index 000000000..99bb993c6 --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/BlockTree.ml @@ -0,0 +1,295 @@ +open SHeapTree +open Gillian +open Gil_syntax +open Gillian.Monadic +module DR = Delayed_result +open SVal +module Subst = Gillian.Symbolic.Subst +open States + +module M = struct + open LActions + + type err_t = err [@@deriving show, yojson] + type t = SHeapTree.t [@@deriving show, yojson] + type action = ac + type pred = ga + + let action_to_str = str_ac + let action_from_str s = try Some (ac_from_str s) with _ -> None + let pred_to_str = str_ga + let pred_from_str s = try Some (ga_from_str s) with _ -> None + + let list_actions _ = + [ + (DropPerm, [ "?" ], [ "?" ]); + (GetCurPerm, [ "?" ], [ "?" ]); + (WeakValidPointer, [ "?" ], [ "?" ]); + (Store, [ "?" ], [ "?" ]); + (Load, [ "?" ], [ "?" ]); + ] + + let list_preds _ = + [ + (LActions.Single, [ "?" ], [ "?" ]); + (LActions.Array, [ "?" ], [ "?" ]); + (LActions.Hole, [ "?" ], [ "?" ]); + (LActions.Zeros, [ "?" ], [ "?" ]); + (LActions.Bounds, [ "?" ], [ "?" ]); + ] + + let pp_params fmt params = + let rec aux fmtp = function + | [] -> () + | [ a ] -> Format.fprintf fmt "%a" Expr.pp a + | a :: r -> + Format.fprintf fmt "%a, " Expr.pp a; + aux fmtp r + in + Format.fprintf fmt "[%a]" aux params + + let fail_ungracefully act_name params = + failwith + (Format.asprintf "Invalid call to %s : %a" act_name pp_params params) + + (** Execute an action *) + let execute_action (act : action) (s : t) (ins : Expr.t list) : + (t * Expr.t list, err_t) result Delayed.t = + let open Delayed.Syntax in + let open DR.Syntax in + match (act, ins) with + | GetCurPerm, [ ofs ] -> + let** perm = get_perm_at s ofs in + let perm_string = Expr.Lit (String (Perm.opt_to_string perm)) in + DR.ok (s, [ perm_string ]) + | WeakValidPointer, [ ofs ] -> + let** bool = weak_valid_pointer s ofs in + let res = Expr.bool bool in + DR.ok (s, [ res ]) + | DropPerm, [ low; high; Expr.Lit (String perm_string) ] -> + let perm = Perm.of_string perm_string in + let++ s' = drop_perm s low high perm in + (s', []) + | Store, [ Expr.Lit (String chunk_name); ofs; value ] -> + let chunk = Chunk.of_string chunk_name in + (* TODO(Ian): This is unsound we are making an SVal with an arbitrary chunk*) + let* sval = SVal.create_sval value in + let++ s' = store s chunk ofs sval in + (s', []) + | Load, [ Expr.Lit (String chunk_name); ofs ] -> + let chunk = Chunk.of_string chunk_name in + Logging.tmi (fun m -> m "Loading"); + let** value, s' = load s chunk ofs in + let+ gil_value = SVal.to_gil_expr ~chunk value in + Ok (s', [ gil_value ]) + | _, _ -> fail_ungracefully (action_to_str act) ins + + (** Consume a predicate with the given ins *) + let consume (pred : pred) (s : t) (ins : Expr.t list) : + (t * Expr.t list, err_t) result Delayed.t = + let open Delayed.Syntax in + let open DR.Syntax in + match (pred, ins) with + | Single, [ ofs; Expr.Lit (String chunk_string) ] -> + let chunk = Chunk.of_string chunk_string in + let** sval, perm, s' = cons_single s ofs chunk in + let+ sval_e = SVal.to_gil_expr ~chunk sval in + let perm_string = Perm.opt_to_string perm in + Ok (s', [ sval_e; Expr.Lit (String perm_string) ]) + | Array, [ ofs; size; Expr.Lit (String chunk_string) ] -> + let chunk = Chunk.of_string chunk_string in + let** array, perm, s' = cons_array s ofs size chunk in + let array_e = SVArray.to_gil_expr ~size ~chunk array in + let perm_string = Perm.opt_to_string perm in + DR.ok (s', [ array_e; Expr.Lit (String perm_string) ]) + | Hole, [ low; high ] -> + let** s', perm = cons_hole s low high in + let perm_e = Expr.Lit (String (Perm.opt_to_string perm)) in + DR.ok (s', [ perm_e ]) + | Zeros, [ low; high ] -> + let** s', perm = cons_zeros s low high in + let perm_e = Expr.Lit (String (Perm.opt_to_string perm)) in + DR.ok (s', [ perm_e ]) + | Bounds, [] -> + let++ bounds, s' = cons_bounds s |> DR.of_result in + let bounds_e = + match bounds with + | None -> Expr.Lit Null + | Some (low, high) -> Expr.EList [ low; high ] + in + (s', [ bounds_e ]) + | _, _ -> failwith "Invalid consume call" + + (** Produce a predicate with the given ins and outs *) + let produce (pred : pred) (s : t) (insouts : Expr.t list) : t Delayed.t = + let open Delayed.Syntax in + let open DR.Syntax in + let open Delayed.Syntax in + let filter_errors dr = + Delayed.bind dr (fun res -> + match res with + | Ok res -> Delayed.return res + | Error err -> + Logging.tmi (fun m -> m "Filtering error branch: %a" pp_err err); + Delayed.vanish ()) + in + match (pred, insouts) with + | ( Single, + [ + ofs; + Expr.Lit (String chunk_string); + sval_e; + Expr.Lit (String perm_string); + ] ) -> + let perm = Perm.of_string perm_string in + let chunk = Chunk.of_string chunk_string in + let sval = SVal.make ~chunk ~value:sval_e in + prod_single s ofs chunk sval perm |> filter_errors + | ( Array, + [ + ofs; + size; + Expr.Lit (String chunk_string); + arr_e; + Expr.Lit (String perm_string); + ] ) -> + let perm = Perm.of_string perm_string in + let chunk = Chunk.of_string chunk_string in + let arr = SVArray.make ~chunk ~values:arr_e in + prod_array s ofs size chunk arr perm |> filter_errors + | Hole, [ low; high; Expr.Lit (String perm_string) ] -> + let perm = Perm.of_string perm_string in + prod_hole s low high perm |> filter_errors + | Zeros, [ low; high; Expr.Lit (String perm_string) ] -> + let perm = Perm.of_string perm_string in + prod_zeros s low high perm |> filter_errors + | Bounds, [ bounds_e ] -> + let bounds = + match bounds_e with + | Expr.EList [ low; high ] -> (low, high) + | Lit (LList [ low; high ]) -> (Lit low, Lit high) + | _ -> failwith "set_bounds wrong param" + in + prod_bounds s bounds |> DR.of_result |> filter_errors + | _, _ -> failwith "Invalid produce call" + + (** Compose two states together *) + let compose s1 s2 = + let open Delayed.Syntax in + let* res = merge ~old_tree:s1 ~new_tree:s2 in + match res with + | Ok s' -> Delayed.return s' + | Error e -> + Logging.verbose (fun fmt -> + fmt "Vanishing on compose error: %a" pp_err_t e); + Delayed.vanish () + + (** For Freeable: if a state can be freed. Must only be true if no non-empty state can + be composed with the state. The Expr list is irrelevant; it's required because of Gillian-C. *) + let is_exclusively_owned tree e = + let open Delayed.Syntax in + match e with + | [ low; high ] -> SHeapTree.is_exclusively_owned tree low high + | _ -> Delayed.return false + + let empty _ = SHeapTree.empty + + (** If this state is observably empty. *) + let is_empty = SHeapTree.is_empty + + (** If this state is entirely made up of concrete expressions. *) + let is_concrete = SHeapTree.is_concrete + + (** Instantiates this state with a list of arguments. This is used by PMap, either in + static mode with the 'instantiate' action, or in dynamic mode when accessing + a missing index. *) + let instantiate = function + | [ low; high ] -> + let tree = SHeapTree.instantiate low high in + (tree, []) + | _ -> failwith "BlockTree: Invalid instantiate arguments" + + (** The list of core predicates corresponding to the state. *) + let assertions tree = SHeapTree.assertions tree + + (** The list of assertions that aren't core predicates corresponding to the state. *) + let assertions_others tree : Asrt.atom list = SHeapTree.assertions_others tree + + (** If the error can be fixed *) + let can_fix (e : err_t) = + match e with + | MissingResource _ -> true + | _ -> false + + (** Get the fixes for an error, as a list of fixes -- a fix is a list of core predicates + to produce onto the state. *) + let get_fixes e = + Logging.tmi (fun m -> m "Getting fixes for %a" pp_err e); + match e with + | MissingResource (Fixable { is_store; low = ofs; chunk }) -> + Logging.tmi (fun m -> m "Fixable"); + let freeable_perm = Perm.to_string Perm.Freeable |> Expr.string in + let chunk_as_expr = Chunk.to_string chunk |> Expr.string in + let possible_fix_types = SVal.any_of_chunk_reified chunk in + let make_branch (expr, learned_types) = + [ + MyAsrt.CorePred + (Single, [ ofs; chunk_as_expr ], [ expr; freeable_perm ]); + MyAsrt.Types + (List.map (fun (v, t) -> (Expr.LVar v, t)) learned_types); + ] + in + + List.map make_branch possible_fix_types + | _ -> [] + + (** The recovery tactic to attempt to resolve an error, by eg. unfolding predicates *) + let get_recovery_tactic _ = Gillian.General.Recovery_tactic.none + + (** The set of logical variables in the state *) + let lvars tree = SHeapTree.lvars tree + + (** The set of abstract locations in the state *) + let alocs tree = SHeapTree.alocs tree + + (** Applies a substitution to the state. This can branch, eg. when attempting to resolve + equality of expressions. *) + let substitution_in_place subst tree = + let le_subst = Subst.subst_in_expr subst ~partial:true in + let sval_subst = SVal.substitution ~le_subst in + let svarr_subst = SVArray.subst ~le_subst in + substitution ~le_subst ~sval_subst ~svarr_subst tree |> Delayed.return + + let move + (dst_tree : t) + (dst_ofs : Expr.t) + (src_tree : t) + (src_ofs : Expr.t) + (size : Expr.t) = + SHeapTree.move dst_tree dst_ofs src_tree src_ofs size + + (** Pretty print the state *) + let pp fmt tree = SHeapTree.pp_full fmt tree + + (* Debug *) + + (** (Debug only) Return all available (action * arguments * outputs) *) + let list_actions _ = + [ + (DropPerm, [ "?" ], [ "?" ]); + (GetCurPerm, [ "?" ], [ "?" ]); + (WeakValidPointer, [ "?" ], [ "?" ]); + (Store, [ "?" ], [ "?" ]); + (Load, [ "?" ], [ "?" ]); + ] + + (** (Debug only) Return all available (predicates * ins * outs) *) + let list_preds _ = + [ + (Single, [ "?" ], [ "?" ]); + (Array, [ "?" ], [ "?" ]); + (Hole, [ "?" ], [ "?" ]); + (Zeros, [ "?" ], [ "?" ]); + (Bounds, [ "?" ], [ "?" ]); + ] +end diff --git a/Gillian-LLVM/lib/llvm_memory_model/CGEnv.ml b/Gillian-LLVM/lib/llvm_memory_model/CGEnv.ml new file mode 100644 index 000000000..aada201fa --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/CGEnv.ml @@ -0,0 +1,63 @@ +(* +open Gil_syntax +open Gillian.Monadic +module DR = Delayed_result + +let init_data = ref Global_env.empty +let set_init_data d = init_data := d + +module M : States.MyMonadicSMemory.S with type t = Global_env.t = struct + type t = Global_env.t [@@deriving yojson] + type err_t = unit [@@deriving show, yojson] + type action = GetDef + type pred = unit + + let pp = Global_env.pp + + let action_from_str = function + | "getdef" -> Some GetDef + | _ -> None + + let action_to_str GetDef = "getdef" + let pred_from_str _ = None + let pred_to_str () = failwith "No pred in GEnv" + let empty () = !init_data + + (* Execute action *) + let execute_action GetDef s args = + match args with + | [ (Expr.Lit (Loc loc) | Expr.ALoc loc | Expr.LVar loc) ] -> ( + match Global_env.find_def_opt s loc with + | Some def -> + let v = Global_env.serialize_def def in + DR.ok (s, [ Expr.Lit (Loc loc); Expr.Lit v ]) + | None -> + (* If we can't find a function, in UX mode we give up, while in OX mode we + signal. *) + if !Gillian.Utils.Config.under_approximation then Delayed.vanish () + else + Fmt.failwith "execute_genvgetdef: couldn't find %s\nGENV:\n%a" loc + Global_env.pp s) + | _ -> failwith "Invalid arguments for GetDef" + + let consume () _ _ = failwith "Invalid C GEnv consume" + let produce () _ _ = failwith "Invalid C GEnv produce" + let compose _ _ = Delayed.vanish () (* TODO *) + let is_exclusively_owned _ _ = Delayed.return false + let is_empty _ = false + let is_concrete _ = false + let instantiate _ = (Global_env.empty, []) + + (* Core predicates: pred * ins * outs, converted to Asrt.CorePred *) + let assertions _ = [] + let assertions_others _ = [] + let can_fix () = false + let get_fixes () = [] + let lvars _ = Gillian.Utils.Containers.SS.empty + let alocs _ = Gillian.Utils.Containers.SS.empty + let substitution_in_place _ s = Delayed.return s + let get_recovery_tactic _ = Gillian.General.Recovery_tactic.none + let list_actions () = [ (GetDef, [], []) ] + let list_preds () = [] +end +*) \ No newline at end of file diff --git a/Gillian-LLVM/lib/llvm_memory_model/CMemory.ml b/Gillian-LLVM/lib/llvm_memory_model/CMemory.ml new file mode 100644 index 000000000..619da82b5 --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/CMemory.ml @@ -0,0 +1,14 @@ +open Gillian.Concrete + +type init_data = unit +type vt = Values.t +type st = Subst.t +type err_t = unit [@@deriving yojson, show] +type t = unit +type action_ret = (t * vt list, err_t) result + +let init () = () +let execute_action _ _ _ = failwith "c_memory not implemented in Gillian-C2" +let copy () = () +let pp _ () = () +let pp_err _ () = () diff --git a/Gillian-LLVM/lib/llvm_memory_model/Chunk.ml b/Gillian-LLVM/lib/llvm_memory_model/Chunk.ml new file mode 100644 index 000000000..9fabff8dd --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/Chunk.ml @@ -0,0 +1,66 @@ +open Gillian.Gil_syntax + +type t = IntegerOrPtrChunk | IntegerChunk of int | F32 | F64 +[@@deriving show, eq, yojson] + +type components = + | Float of { bit_width : int } + | Int of { bit_width : int } + | Ptr + +let to_string = function + | IntegerChunk i -> "i-" ^ Int.to_string i + | IntegerOrPtrChunk -> "i-or-ptr" + | F32 -> "f32" + | F64 -> "f64" + +let of_string = function + | "i-or-ptr" -> IntegerOrPtrChunk + | "f32" -> F32 + | "f64" -> F64 + | x -> + let lst = String.split_on_char '-' x in + if List.length lst = 2 && String.equal (List.hd lst) "i" then + let st = List.nth lst 1 in + IntegerChunk (int_of_string st) + else failwith ("invalid chunk " ^ x) + +let size = function + | IntegerChunk i -> i / 8 + | IntegerOrPtrChunk -> Llvmconfig.ptr_width () / 8 + | F32 -> 4 + | F64 -> 8 + +let align = function + | IntegerChunk i -> i / 8 + | IntegerOrPtrChunk -> Llvmconfig.ptr_width () / 8 + | F32 -> 4 + | F64 -> 8 + +let to_components chunk = + match chunk with + | IntegerChunk w -> Int { bit_width = w } + | IntegerOrPtrChunk -> Ptr + | F32 -> Float { bit_width = 32 } + | F64 -> Float { bit_width = 64 } + +let is_int = function + | IntegerChunk _ | IntegerOrPtrChunk -> true + | F32 | F64 -> false + +let i8 = IntegerChunk 8 + +(* TODO(Ian): should we somehow know if this is a pointer chunk? *) +let type_of curr_chunk = + Logging.tmi (fun m -> m "type_of: %s" (to_string curr_chunk)); + let res = + match curr_chunk with + | IntegerChunk i -> Some [ Type.BvType i ] + | IntegerOrPtrChunk -> + Some [ Type.BvType (Llvmconfig.ptr_width ()); Type.ListType ] + | F32 -> Some [ Type.NumberType ] + | F64 -> Some [ Type.NumberType ] + in + Logging.tmi (fun m -> + m "type_of: %a" (Fmt.option (Fmt.list ~sep:Fmt.comma Type.pp)) res); + res diff --git a/Gillian-LLVM/lib/llvm_memory_model/Constr.ml b/Gillian-LLVM/lib/llvm_memory_model/Constr.ml new file mode 100644 index 000000000..dd4714b8b --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/Constr.ml @@ -0,0 +1,31 @@ +open Gil_syntax + +(* Redefine Constr, to remove the loc parameter (since that is handled by the PMap), and have + core predicates be a simpler tuple *) +module Core = struct + open LActions + + let pred ga ins outs = (ga, ins, outs) + + let single ~ofs ~chunk ~sval ~perm = + let chunk = Expr.Lit (String (Chunk.to_string chunk)) in + let perm = Expr.Lit (String (Perm.opt_to_string perm)) in + pred Single [ ofs; chunk ] [ sval; perm ] + + let array ~ofs ~chunk ~size ~sval_arr ~perm = + let chunk = Expr.Lit (String (Chunk.to_string chunk)) in + let perm = Expr.Lit (String (Perm.opt_to_string perm)) in + pred Array [ ofs; size; chunk ] [ sval_arr; perm ] + + let hole ~low ~high ~perm = + let perm = Expr.Lit (String (Perm.opt_to_string perm)) in + pred Hole [ low; high ] [ perm ] + + let zeros ~low ~high ~perm = + let perm = Expr.Lit (String (Perm.opt_to_string perm)) in + pred Zeros [ low; high ] [ perm ] + + let bounds ~low ~high = + let bounds = Expr.EList [ low; high ] in + pred Bounds [] [ bounds ] +end diff --git a/Gillian-LLVM/lib/llvm_memory_model/External.ml b/Gillian-LLVM/lib/llvm_memory_model/External.ml new file mode 100644 index 000000000..f39d9018b --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/External.ml @@ -0,0 +1,49 @@ +open Gillian.Gil_syntax +open Gillian.General + +(** JSIL external procedure calls *) +module M + (Val : Val.S) + (ESubst : ESubst.S with type vt = Val.t and type t = Val.et) + (Store : Store.S with type vt = Val.t) + (State : State.S + with type vt = Val.t + and type st = ESubst.t + and type store_t = Store.t) + (Call_stack : Call_stack.S with type vt = Val.t and type store_t = Store.t) = +struct + let execute_printf _prog state cs i x v_args _j = + let store = State.get_store state in + let _ = Store.put store x (Val.from_literal Null) in + let end_state = State.set_store state store in + let () = + Gillian.Logging.verbose (fun m -> + m "C PRINTF WITH: %a" (Fmt.Dump.list Val.full_pp) v_args) + in + [ (end_state, cs, i, i + 1) ] + + (** + General External Procedure Treatment + @param prog GIL program + @param state Current state + @param cs Current call stack + @param i Current index + @param x Variable that stores the result + @param pid Procedure identifier + @param v_args Parameters + @param j Optional error index + @return Resulting configuration + *) + let execute + (prog : ('a, int) Prog.t) + (state : State.t) + (cs : Call_stack.t) + (i : int) + (x : string) + (pid : string) + (v_args : Val.t list) + (j : int option) = + match pid with + | "EXTERN_printf" -> execute_printf prog state cs i x v_args j + | _ -> raise (Failure ("Unsupported external procedure call: " ^ pid)) +end diff --git a/Gillian-LLVM/lib/llvm_memory_model/GEnv.ml b/Gillian-LLVM/lib/llvm_memory_model/GEnv.ml new file mode 100644 index 000000000..edf117d5d --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/GEnv.ml @@ -0,0 +1,302 @@ +(*type err_t = Symbol_not_found of string [@@deriving show, yojson] + + module StringMap = Map.Make (String) + + module Make (Def_value : sig + type t + type vt + type lt + + val pp : Format.formatter -> t -> unit + val to_expr : t -> Gil_syntax.Expr.t + val of_expr : Gil_syntax.Expr.t -> t + val expr_to_vt : Gil_syntax.Expr.t -> vt + val vt_to_expr : vt -> Gil_syntax.Expr.t + val of_lt : lt -> t + end) (Delayed_hack : sig + type 'a t + + val ( #== ) : Def_value.t -> Def_value.t -> Gil_syntax.Expr.t list + + val return : + ?learned:Gil_syntax.Expr.t list -> + ?learned_types:(string * Gil_syntax.Type.t) list -> + 'a -> + 'a t + + val resolve_or_create_lt : Def_value.lt -> string t + val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t + end) = + struct + module GUtils = Gillian.Utils + + type nonrec err_t = err_t + + let pp_err_t = pp_err_t + let show_err_t = show_err_t + let err_t_of_yojson = err_t_of_yojson + let err_t_to_yojson = err_t_to_yojson + + type def = FunDef of Def_value.t | GlobVar of Def_value.t + + type t = { + symb : string StringMap.t; (** maps symbols to loc names *) + defs : def StringMap.t; (** maps loc names to definitions *) + } + + let find_opt x s = try Some (StringMap.find x s) with Not_found -> None + + let find_symbol genv sym = + try Ok (StringMap.find sym genv.symb) + with Not_found -> Error (Symbol_not_found sym) + + let set_symbol genv sym block = + let open Delayed_hack in + try + let cur_symb = StringMap.find sym genv.symb in + let cur_symb_e = Gil_syntax.Expr.loc_from_loc_name cur_symb in + let learned = + (Def_value.of_lt block) #== (Def_value.of_expr cur_symb_e) + in + return ~learned genv + with Not_found -> + let+ block = Delayed_hack.resolve_or_create_lt block in + let symb = StringMap.add sym block genv.symb in + { genv with symb } + + let find_def genv block = StringMap.find block genv.defs + + let set_def genv block def = + try + let cur_def = StringMap.find block genv.defs in + match (def, cur_def) with + | GlobVar a, GlobVar b | FunDef a, FunDef b -> + let open Delayed_hack in + return ~learned:a #== b genv + | _ -> + failwith + "Equality between a global variable and a function definition" + with Not_found -> + let defs = StringMap.add block def genv.defs in + Delayed_hack.return { genv with defs } + + let empty = { symb = StringMap.empty; defs = StringMap.empty } + + (** Serialization of definitions *) + let serialize_def def = + let open Gil_syntax in + let expr = + match def with + | FunDef fname -> + Expr.EList [ Lit (String "function"); Def_value.to_expr fname ] + | GlobVar vname -> + EList [ Lit (String "variable"); Def_value.to_expr vname ] + in + Def_value.expr_to_vt expr + + let deserialize_def sdef = + let open Gillian.Gil_syntax.Literal in + let sdef_expr = Def_value.vt_to_expr sdef in + match sdef_expr with + | EList [ Lit (String "function"); fname ] -> + FunDef (Def_value.of_expr fname) + | EList [ Lit (String "variable"); vname ] -> + GlobVar (Def_value.of_expr vname) + | _ -> + failwith + (Format.asprintf "Invalid global definition : %a" + Gil_syntax.Expr.full_pp sdef_expr) + + (* Pretty printing *) + + let pp_def fmt def = + match def with + | FunDef f -> Format.fprintf fmt "(Function %a)" Def_value.pp f + | GlobVar v -> Format.fprintf fmt "(Variable %a)" Def_value.pp v + + let pp fmt genv = + let not_printed = ref 0 in + let pp_one ft s l = + try + let d = find_def genv l in + Format.fprintf ft "'%s' -> %s -> %a@\n" s l pp_def d + with Not_found -> Format.fprintf ft "'%s' -> %s -> UNKNOWN@\n" s l + in + if !Llvmconfig.hide_genv then Format.fprintf fmt "{@[@\nHIDDEN@]@\n}" + else + let () = Format.fprintf fmt "{@[@\n" in + StringMap.iter (fun s l -> pp_one fmt s l) genv.symb; + Format.fprintf fmt "There are %i unimplemented external functions@]@\n" + !not_printed; + Format.fprintf fmt "}" + + let substitution subst genv = + let open Gillian.Gil_syntax in + let open Gillian.Symbolic in + let substitute_in_def def = + match def with + | FunDef f -> + let f_e = Def_value.to_expr f in + let substituted = Subst.subst_in_expr subst ~partial:true f_e in + let substituted = Def_value.of_expr substituted in + FunDef substituted + | GlobVar f -> + let f_e = Def_value.to_expr f in + let substituted = Subst.subst_in_expr subst ~partial:true f_e in + let substituted = Def_value.of_expr substituted in + GlobVar substituted + in + let with_substituted_defs = + { genv with defs = StringMap.map substitute_in_def genv.defs } + in + let aloc_subst = + Subst.filter subst (fun var _ -> + match var with + | ALoc _ -> true + | _ -> false) + in + let rename_val old_loc new_loc map = + StringMap.map (fun k -> if String.equal old_loc k then new_loc else k) map + in + let rename_key old_loc new_loc map = + match find_opt old_loc map with + | None -> map + | Some d -> StringMap.add new_loc d (StringMap.remove old_loc map) + in + (* Then we substitute the locations *) + Subst.fold aloc_subst + (fun old_loc new_loc cgenv -> + let old_loc = + match old_loc with + | ALoc loc -> loc + | _ -> raise (Failure "Impossible by construction") + in + let new_loc = + match new_loc with + | Lit (Loc loc) | ALoc loc -> loc + | _ -> + failwith + (Format.asprintf "Heap substitution failed for loc : %a" Expr.pp + new_loc) + in + { + symb = rename_val old_loc new_loc cgenv.symb; + defs = rename_key old_loc new_loc cgenv.defs; + }) + with_substituted_defs + + (** This function returns the assertions as well as a list of + locations corresponding to functions declaration, so that memory knows not + to duplicate that ressource. *) + let assertions genv = + let build_asrt s loc def = + match def with + | FunDef fname -> + let f_ser = Def_value.to_expr fname in + (true, Predicates.Others.glob_fun ~symb:s ~fname:f_ser) + | GlobVar vname -> + let v_ser = Def_value.to_expr vname in + let loc = Gil_syntax.Expr.loc_from_loc_name loc in + ( false, + Predicates.Others.glob_var_unallocated_loc ~symb:s ~loc ~vname:v_ser + ) + in + let assert_symb symb loc = + let def = find_def genv loc in + build_asrt symb loc def + in + StringMap.fold + (fun sym loc (locs, asrts) -> + let is_fun, asrt = assert_symb sym loc in + let new_locs = if is_fun then loc :: locs else locs in + (new_locs, asrt :: asrts)) + genv.symb ([], []) + end + + module Concrete = + Make + (struct + open Gil_syntax + + type t = string + type vt = Literal.t + type lt = string + + let pp = Fmt.string + let to_expr s = Expr.Lit (String s) + + let of_expr = function + | Expr.Lit (String s) -> s + | e -> Fmt.failwith "Invalid function name: %a" Expr.pp e + + let rec expr_to_vt = function + | Expr.EList l -> Literal.LList (List.map expr_to_vt l) + | Lit l -> l + | e -> Fmt.failwith "The following should be concrete : %a" Expr.pp e + + let rec vt_to_expr = function + | Literal.LList ll -> Expr.EList (List.map vt_to_expr ll) + | l -> Lit l + + let of_lt x = x + end) + (struct + type 'a t = 'a + + let ( let+ ) a f = f a + let resolve_or_create_lt x = x + let return ?learned:_ ?learned_types:_ x = x + let ( #== ) _ _ = [] + end) + + module Symbolic = + Make + (struct + open Gil_syntax + + type t = Expr.t + type vt = Expr.t + type lt = Expr.t + + let pp = Expr.pp + let to_expr e = e + let of_expr e = e + let expr_to_vt e = e + + let vt_to_expr = + let rec lift_lit = function + | Literal.LList ll -> Expr.EList (List.map lift_lit ll) + | l -> Lit l + in + function + | Expr.Lit l -> lift_lit l + | e -> e + + let of_lt x = x + end) + (struct + include Gillian.Monadic.Delayed + + let ( let+ ) = map + + let ( #== ) a b = + let open Gil_syntax.Expr.Infix in + [ a == b ] + + let resolve_or_create_lt lvar_loc : string t = + let open Syntax in + let* loc_name = resolve_loc lvar_loc in + match loc_name with + | None -> + let new_loc_name = Gil_syntax.ALoc.alloc () in + let learned = lvar_loc #== (ALoc new_loc_name) in + Logging.verbose (fun fmt -> + fmt "Couldn't resolve loc %a, created %s" Gil_syntax.Expr.pp + lvar_loc new_loc_name); + return ~learned new_loc_name + | Some l -> + Logging.verbose (fun fmt -> + fmt "Resolved %a as %s" Gil_syntax.Expr.pp lvar_loc l); + return l + end) +*) diff --git a/Gillian-LLVM/lib/llvm_memory_model/GEnv.mli b/Gillian-LLVM/lib/llvm_memory_model/GEnv.mli new file mode 100644 index 000000000..bab8e225e --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/GEnv.mli @@ -0,0 +1,84 @@ +(*type err_t = Symbol_not_found of string [@@deriving show, yojson] + + module StringMap : Map.S with type key = string + + module Concrete : sig + open Gil_syntax + + type nonrec err_t = err_t [@@deriving show] + type def = FunDef of string | GlobVar of string + + val serialize_def : def -> Literal.t + val deserialize_def : Literal.t -> def + + type t = { + symb : string StringMap.t; (** maps symbols to loc names *) + defs : def StringMap.t; (** maps loc names to definitions *) + } + + (** Finds a location name given symbol in the global environment *) + val find_symbol : t -> string -> (string, err_t) result + + (** Finds a definition given its location name in the global environment *) + val find_def : t -> string -> def + + (** [set_symbol genv symbol locname ] + Returns a new global environment where the symbol [symbol] is associated with the location [locname] *) + val set_symbol : t -> string -> string -> t + + (** [set_def genv locname def ] + Returns a new global environment where the block [locname] is associated with the global definition [def] *) + val set_def : t -> string -> def -> t + + (** Empty global environment *) + val empty : t + + (** Pretty printer for the global environment *) + val pp : Format.formatter -> t -> unit + + (** {3 Symbolic things} *) + + val substitution : Gillian.Symbolic.Subst.t -> t -> t + val assertions : t -> string list * Gillian.Gil_syntax.Asrt.t + end + + module Symbolic : sig + open Gil_syntax + + type nonrec err_t = err_t [@@deriving show, yojson] + type def = FunDef of Expr.t | GlobVar of Expr.t + + val serialize_def : def -> Expr.t + val deserialize_def : Expr.t -> def + + type t = { + symb : string StringMap.t; (** maps symbols to loc names *) + defs : def StringMap.t; (** maps loc names to definitions *) + } + + (** Finds a location name given symbol in the global environment *) + val find_symbol : t -> string -> (string, err_t) result + + (** Finds a definition given its location name in the global environment *) + val find_def : t -> string -> def + + (** [set_symbol genv symbol locname ] + Returns a new global environment where the symbol [symbol] is associated with the location [locname] *) + val set_symbol : t -> string -> Gil_syntax.Expr.t -> t Monadic.Delayed.t + + (** [set_def genv locname def ] + Returns a new global environment where the block [locname] is associated with the global definition [def] *) + val set_def : t -> string -> def -> t Monadic.Delayed.t + + (** Empty global environment *) + val empty : t + + (** Pretty printer for the global environment *) + val pp : Format.formatter -> t -> unit + + (** {3 Symbolic things} *) + + val substitution : Gillian.Symbolic.Subst.t -> t -> t + val assertions : t -> string list * Gillian.Gil_syntax.Asrt.t + end +*) diff --git a/Gillian-LLVM/lib/llvm_memory_model/LActions.ml b/Gillian-LLVM/lib/llvm_memory_model/LActions.ml new file mode 100644 index 000000000..1cb77ed5e --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/LActions.ml @@ -0,0 +1,32 @@ +type ac = DropPerm | GetCurPerm | WeakValidPointer | Store | Load +type ga = Single | Array | Hole | Zeros | Bounds + +let str_ac = function + | DropPerm -> "dropperm" + | WeakValidPointer -> "weakvalidpointer" + | GetCurPerm -> "getcurperm" + | Store -> "store" + | Load -> "load" + +let ac_from_str = function + | "dropperm" -> DropPerm + | "weakvalidpointer" -> WeakValidPointer + | "getcurperm" -> GetCurPerm + | "store" -> Store + | "load" -> Load + | _ -> failwith "Unrecognized action" + +let str_ga = function + | Single -> "single" + | Array -> "array" + | Hole -> "hole" + | Zeros -> "zeros" + | Bounds -> "bounds" + +let ga_from_str = function + | "single" -> Single + | "array" -> Array + | "bounds" -> Bounds + | "zeros" -> Zeros + | "hole" -> Hole + | _ -> failwith "Unrecognized predicate" diff --git a/Gillian-LLVM/lib/llvm_memory_model/LLVM.ml b/Gillian-LLVM/lib/llvm_memory_model/LLVM.ml new file mode 100644 index 000000000..2b2b3b491 --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/LLVM.ml @@ -0,0 +1,144 @@ +open Utils +open Gil_syntax +module Delayed = Gillian.Monadic.Delayed +module DR = Gillian.Monadic.Delayed_result + +(* Import C-specific constructs *) +module BlockTree = BlockTree.M + +(* Base memories *) +module BaseBlock = Freeable (BlockTree) + +module type C_PMapType = OpenPMapType with type entry = BaseBlock.t + +module BaseMemory : C_PMapType = OpenPMap (LocationIndex) (BaseBlock) +module SplitMemory : C_PMapType = OpenSplitPMap (LocationIndex) (BaseBlock) +module ALocMemory : C_PMapType = OpenALocPMap (BaseBlock) + +(* Add move action implementation *) +module ExtendMemory (S : C_PMapType) = struct + module Addition : ActionAddition with type t = S.t = struct + type t = S.t + type action = Move | SetZeros + + type err_t = + | BaseError of S.err_t + | BlockTreeErr of (Expr.t * Expr.t * BlockTree.err_t) + | MoveOnMissing + | MoveOnFreed + [@@deriving show, yojson] + + let ( let**^ ) x f = + Delayed.bind x (function + | Ok x -> f x + | Error e -> Delayed.return (Error (BaseError e))) + + let list_actions () = + [ (Move, [ "?" ], [ "?" ]); (SetZeros, [ "?" ], [ "?" ]) ] + + let action_from_str = function + | "move" -> Some Move + | "setZeros" -> Some SetZeros + | _ -> None + + let action_to_str = function + | Move -> "move" + | SetZeros -> "setZeros" + + let exec_move s args = + match args with + | [ dst_loc; dst_ofs; src_loc; src_ofs; size ] -> ( + let open DR.Syntax in + let open Expr.Infix in + if%sat size == Expr.zero_i then DR.ok (s, []) + else + let**^ s, _, src = S.get s src_loc in + let**^ s, dst_loc', dest = S.get s dst_loc in + match (src, dest) with + | States.Freeable.None, _ | _, States.Freeable.None -> + DR.error MoveOnMissing + | States.Freeable.Freed, _ | _, States.Freeable.Freed -> + DR.error MoveOnFreed + | States.Freeable.SubState src, States.Freeable.SubState dest -> + let** dest = + DR.map_error (BlockTree.move dest dst_ofs src src_ofs size) + (fun e -> BlockTreeErr (src_loc, dst_loc, e)) + in + let s' = + S.set ~idx:dst_loc ~idx':dst_loc' + (States.Freeable.SubState dest) s + in + DR.ok (s', [])) + | _ -> failwith "Invalid arguments for mem_move" + + let pred_zero = S.pred_from_str "zeros" |> Option.get + + let exec_set_zeros s args = + let s' = S.produce pred_zero s args in + Delayed.map s' (fun s' -> Ok (s', [])) + + let execute_action = function + | Move -> exec_move + | SetZeros -> exec_set_zeros + + let can_fix = function + | BaseError e -> S.can_fix e + | BlockTreeErr (_, _, e) -> BlockTree.can_fix e + | _ -> false + + let map_fixes mapper = + States.MyUtils.deep_map + (States.MyAsrt.map_cp (fun (p, i, o) -> (mapper p, i, o))) + + let get_fixes = function + | BaseError e -> S.get_fixes e |> map_fixes S.pred_to_str + | BlockTreeErr (_, _, e) -> + BlockTree.get_fixes e |> map_fixes BlockTree.pred_to_str + | _ -> [] + + let get_recovery_tactic = function + | BaseError e -> S.get_recovery_tactic e + | BlockTreeErr (dest_idx, src_idx, _) -> + Gillian.General.Recovery_tactic.try_unfold [ dest_idx; src_idx ] + | _ -> Gillian.General.Recovery_tactic.none + end + + include ActionAdder (Addition) (S) + + let execute_action a s args = + let open Delayed.Syntax in + let action = action_to_str a in + let args = + (* Move index to be the first argument *) + match (action, args) with + | "load", c :: loc :: rest | "store", c :: loc :: rest -> loc :: c :: rest + | _ -> args + in + let+ r = execute_action a s args in + match (action, r) with + (* remove returned index (not needed in C) *) + | "alloc", r -> r + | _, Ok (s', _ :: rest) -> Ok (s', rest) + | _, r -> r +end + +module Wrap (S : C_PMapType) = struct + module CMapMemory = ExtendMemory (S) + include CMapMemory + + let pp f s1 = CMapMemory.pp f s1 +end + +module MonadicSMemory_Base = Wrap (BaseMemory) +module MonadicSMemory_ALoc = Wrap (ALocMemory) +module MonadicSMemory_Split = Wrap (SplitMemory) +module ParserAndCompiler = ParserAndCompiler.Dummy + +module ExternalSemantics = + Gillian.General.External.Dummy (ParserAndCompiler.Annot) + +module MyInitData = struct + type t = unit + + let init _ = () +end diff --git a/Gillian-LLVM/lib/llvm_memory_model/LLVMRuntimeTypes.ml b/Gillian-LLVM/lib/llvm_memory_model/LLVMRuntimeTypes.ml new file mode 100644 index 000000000..8830c35da --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/LLVMRuntimeTypes.ml @@ -0,0 +1,82 @@ +open Gil_syntax +open Monadic +module DO = Delayed_option +module DR = Delayed_result + +type t = Int of int | F32 | F64 | Ptr + +let type_to_chunk = function + | Int w -> Chunk.IntegerChunk w + | F32 -> Chunk.F32 + | F64 -> Chunk.F64 + | Ptr -> Chunk.IntegerOrPtrChunk + +let chunk_to_type = function + | Chunk.IntegerChunk w -> [ Int w ] + | Chunk.F32 -> [ F32 ] + | Chunk.F64 -> [ F64 ] + | Chunk.IntegerOrPtrChunk -> [ Ptr; Int (Llvmconfig.ptr_width ()) ] + +let type_to_string = function + | Int w -> "int-" ^ string_of_int w + | F32 -> "float" + | F64 -> "double" + | Ptr -> "ptr" + +let string_to_type = function + | "float" -> F32 + | "double" -> F64 + | "ptr" -> Ptr + | st -> + let sp = String.split_on_char '-' st in + if List.length sp = 2 && List.hd sp = "int" then + Int (int_of_string (List.nth sp 1)) + else failwith ("Invalid runtime type: " ^ st) + +let make_expr_of_type_unsafe (expr : Expr.t) (typ : t) : Expr.t = + Expr.list [ Expr.string (type_to_string typ); expr ] + +let rtype_to_gil_type = function + | Int w -> Type.BvType w + | F32 -> Type.NumberType + | F64 -> Type.NumberType + | Ptr -> Type.ListType + +let make_type_check_expr (expr : Expr.t) (typ : t) : Expr.t = + let open Expr.Infix in + Expr.list_nth expr 0 == Expr.string (type_to_string typ) + && Expr.typeof (Expr.list_nth expr 1) == Expr.type_ (rtype_to_gil_type typ) + +let ptr_pat expr = make_type_check_expr expr Ptr +let float_pat expr = make_type_check_expr expr F32 +let double_pat expr = make_type_check_expr expr F64 + +(* TODO(Ian): This is hack and potentially incomplete i think + to do this appropriately we would need to either: solve for the string + or a-priori know all available integer types and branch on each *) +let get_integer_type (expr : Expr.t) : t DO.t = + match expr with + | Expr.EList [ Expr.Lit (Literal.String w); _ ] -> + let open DO.Syntax in + let split = String.split_on_char '-' w in + let width = + if List.length split = 2 && List.hd split = "int" then + int_of_string_opt (List.nth split 1) + else None + in + DO.map (DO.of_option width) (fun w -> Int w) + | _ -> DO.none () + +(* Determines the type of an expression within a context *) +let type_of_expr (expr : Expr.t) : t DO.t = + let open Delayed.Syntax in + let* reduced = Delayed.reduce expr in + let* ity = get_integer_type reduced in + match ity with + | Some ity -> Delayed.return (Some ity) + | None -> ( + match%sat reduced with + | ptr_pat -> DO.some Ptr + | float_pat -> DO.some F32 + | double_pat -> DO.some F64 + | _ -> DO.none ()) diff --git a/Gillian-LLVM/lib/llvm_memory_model/SHeapTree.ml b/Gillian-LLVM/lib/llvm_memory_model/SHeapTree.ml new file mode 100644 index 000000000..85762bfdb --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/SHeapTree.ml @@ -0,0 +1,1601 @@ +open Gil_syntax +open Monadic +module DR = Delayed_result +module DO = Delayed_option +module SS = Gillian.Utils.Containers.SS +module SVArr = SVal.SVArray +module Preds = Constr +open SVal + +let log_string s = Logging.verbose (fun fmt -> fmt "SHEAPTREE CHECKING: %s" s) + +type missingResourceType = + | Unfixable + | Fixable of { is_store : bool; low : Expr.t; chunk : Chunk.t } +[@@deriving show, yojson] + +type err = + | UseAfterFree + | BufferOverrun + | InsufficientPermission of { required : Perm.t; actual : Perm.t } + | InvalidAlignment of { alignment : int; offset : Expr.t } + | MissingResource of missingResourceType + | Unhandled of string + | WrongMemVal + | MemoryNotFreed + | LoadingPoison +[@@deriving yojson] + +exception FatalErr of err + +let pp_err fmt = function + | UseAfterFree -> Fmt.pf fmt "Use After Free" + | BufferOverrun -> Fmt.pf fmt "Buffer Overrun" + | InsufficientPermission { required; actual } -> + Fmt.pf fmt "Insufficient Permision: Got %s but required %s" + (Perm.to_string required) (Perm.to_string actual) + | InvalidAlignment { alignment; offset } -> + Fmt.pf fmt "Invalid alignment: %d should divide %a" alignment Expr.pp + offset + | MissingResource ty -> + Fmt.pf fmt "MissingResource %s" (show_missingResourceType ty) + | Unhandled e -> Fmt.pf fmt "Unhandled error with message : %s" e + | WrongMemVal -> Fmt.pf fmt "WrongMemVal" + | MemoryNotFreed -> Fmt.pf fmt "MemoryNotFreed" + | LoadingPoison -> Fmt.pf fmt "LoadingPoison" + +let err_equal a b = + match (a, b) with + | MissingResource ty1, MissingResource ty2 -> failwith "Not implemented" + | UseAfterFree, UseAfterFree -> true + | BufferOverrun, BufferOverrun -> true + | ( InsufficientPermission { required = ra; actual = aa }, + InsufficientPermission { required = rb; actual = ab } ) -> + let open Perm.Infix in + ra =% rb && aa =% ab + | Unhandled a, Unhandled b -> String.equal a b + | _ -> false + +type 'a or_error = ('a, err) Result.t +type 'a d_or_error = ('a, err) DR.t + +module PathTaken = struct + (** Going through a tree can become quite expensive. + Remover is always called right after the getter, so we take note of the last path taken and on remove we just go for it directly. *) + + type t = Left | Right | Here [@@deriving yojson] +end + +module Range = struct + type t = Expr.t * Expr.t [@@deriving yojson] + + let is_concrete (a, b) = Expr.is_concrete a && Expr.is_concrete b + let pp fmt (a, b) = Fmt.pf fmt "@[[%a; %a[@]" Expr.pp a Expr.pp b + let make low high = (low, high) + + module Lift = struct + open Gillian.Debugger.Utils + + let as_variables + ~(make_node : + name:string -> + value:string -> + ?children:Variable.t list -> + unit -> + Variable.t) + (low, high) = + let str = Fmt.to_to_string (Fmt.hbox Expr.pp) in + let from = make_node ~name:"From" ~value:(str low) () in + let to_ = make_node ~name:"To" ~value:(str high) () in + [ from; to_ ] + end + + let of_low_and_size low size = + let open Expr.Infix in + (low, low + size) + + let of_low_and_chunk low chunk = + let open Expr.Infix in + let len = Expr.int (Chunk.size chunk) in + (low, low + len) + + let of_low_chunk_and_size low chunk size = + let open Expr.Infix in + let sz_chunk = Expr.int (Chunk.size chunk) in + (low, low + (sz_chunk * size)) + + let is_equal (la, ha) (lb, hb) = + let open Expr.Infix in + la == lb && ha == hb + + let is_inside (la, ha) (lb, hb) = + let open Expr.Infix in + lb <= la && ha <= hb + + let size (a, b) = Expr.Infix.( - ) b a + + let point_strictly_inside x (l, h) = + let open Expr.Infix in + l < x && x < h + + let split_at (l, h) x = ((l, x), (x, h)) + let lvars (a, b) = SS.union (Expr.lvars a) (Expr.lvars b) + let alocs (a, b) = SS.union (Expr.alocs a) (Expr.alocs b) + let substitution ~le_subst (a, b) = (le_subst a, le_subst b) +end + +module Node = struct + type qty = Totally | Partially [@@deriving yojson] + + let str_qty = function + | Totally -> "TOTALLY" + | Partially -> "PARTIALLY" + + type mem_val = + | Zeros + | Poisoned of qty + | Single of SVal.t + | Array of SVArr.t + | LazyValue + [@@deriving yojson] + + type t = + | NotOwned of qty + | MemVal of { + min_perm : Perm.t; + exact_perm : Perm.t option; + mem_val : mem_val; + } + [@@deriving yojson] + + let is_concrete = function + | NotOwned _ -> true + | MemVal { mem_val; _ } -> ( + match mem_val with + | Zeros -> true + | Poisoned _ -> true + | Single sval -> SVal.is_concrete sval + | Array svarr -> SVArr.is_concrete svarr + (* TODO(Ian): errr not sure about this one?*) + | LazyValue -> false) + + let make_owned ~mem_val ~perm = + MemVal { mem_val; min_perm = perm; exact_perm = Some perm } + + let drop_perm_exn ~perm = function + | NotOwned _ -> + raise (FatalErr (Unhandled "Inconsistent permissions in the tree")) + | MemVal { mem_val; _ } -> + MemVal { min_perm = perm; exact_perm = Some perm; mem_val } + + let update_parent_perm t ~left ~right = + match (t, left, right) with + | ( MemVal { mem_val; _ }, + MemVal { exact_perm = epl; min_perm = mpl; _ }, + MemVal { exact_perm = epr; min_perm = mpr; _ } ) -> + let exact_perm = + match (epr, epl) with + | Some r, Some l when r == l -> Some r + | _ -> None + in + let min_perm = Perm.min mpl mpr in + MemVal { mem_val; exact_perm; min_perm } + | _ -> t + + let poisoned ~perm = make_owned ~perm ~mem_val:(Poisoned Totally) + let not_owned = NotOwned Totally + + let pp fmt = function + | NotOwned qty -> Fmt.pf fmt "%s NOT OWNED" (str_qty qty) + | MemVal { exact_perm; mem_val; _ } -> ( + match mem_val with + | Zeros -> Fmt.pf fmt "ZEROS (%a)" (Fmt.Dump.option Perm.pp) exact_perm + | Poisoned qty -> + Fmt.pf fmt "%s POISONED (%a)" (str_qty qty) + (Fmt.Dump.option Perm.pp) exact_perm + | Single sval -> + Fmt.pf fmt "%a (%a)" SVal.pp sval (Fmt.Dump.option Perm.pp) + exact_perm + | Array svarr -> + Fmt.pf fmt "%a (%a)" SVArr.pp svarr (Fmt.Dump.option Perm.pp) + exact_perm + | LazyValue -> Fmt.pf fmt "NOT EVALUATED YET") + + let check_perm required node = + match required with + | None -> Ok () + | Some required -> ( + match node with + | NotOwned _ -> Error (MissingResource Unfixable) + | MemVal { min_perm = actual; _ } -> + let open Perm.Infix in + if actual >=% required then Ok () + else Error (InsufficientPermission { actual; required })) + + let exact_perm = function + | NotOwned Partially -> `KeepLooking + | NotOwned Totally -> `StopLooking (Error (MissingResource Unfixable)) + | MemVal { exact_perm = None; _ } -> `KeepLooking + | MemVal { exact_perm = Some x; _ } -> `StopLooking (Ok x) + + let split ~span:(low, high) ~at node = + Logging.tmi (fun m -> + m "ABOUT TO SPLIT NODE THAT HAS SPAN %a AT %a" Range.pp (low, high) + Expr.pp at); + let open Delayed.Syntax in + match node with + | NotOwned Totally -> Delayed.return (NotOwned Totally, NotOwned Totally) + | NotOwned Partially -> failwith "Should never split a partially owned node" + | MemVal { exact_perm; min_perm; mem_val } -> ( + let mk mem_val = MemVal { min_perm; exact_perm; mem_val } in + let make_pair left right = Delayed.return (mk left, mk right) in + match mem_val with + | Zeros -> make_pair Zeros Zeros + | Poisoned Totally -> make_pair (Poisoned Totally) (Poisoned Totally) + | Single sval -> + (* The sound approach right now is to transform the value into an array + of byte and then split that in two *) + let* svarr = SVArr.byte_array_of_sval sval in + let at = Expr.Infix.(at - low) in + let left, right = SVArr.split_at_offset ~at svarr in + make_pair (Array left) (Array right) + | Array arr -> + let at = Expr.Infix.(at - low) in + let* left, right = SVArr.split_at_byte ~at arr in + make_pair (Array left) (Array right) + | Poisoned Partially | LazyValue -> + failwith "Intermediate node, should never be split") + + let rec merge ~left ~right = + let ret = Delayed.return in + let open Delayed.Syntax in + let a, size_left = left in + let b, size_right = right in + match (a, b) with + | NotOwned Totally, NotOwned Totally -> ret (NotOwned Totally) + | NotOwned _, _ | _, NotOwned _ -> ret (NotOwned Partially) + | ( MemVal { exact_perm = ex_perma; min_perm = min_perma; mem_val = vala }, + MemVal { exact_perm = ex_permb; min_perm = min_permb; mem_val = valb } ) + -> ( + let min_perm = Perm.min min_perma min_permb in + let exact_perm = + match (ex_perma, ex_permb) with + | Some pa, Some pb when pa == pb -> Some pa + | _, _ -> None + in + let mk mem_val = MemVal { min_perm; mem_val; exact_perm } in + let array arr = ret (mk (Array arr)) in + let lazy_value = ret (mk LazyValue) in + let zeros = ret (mk Zeros) in + match (vala, valb) with + | Zeros, Zeros -> zeros + | Poisoned Totally, Poisoned Totally -> ret (mk (Poisoned Totally)) + | Poisoned _, _ | _, Poisoned _ -> ret (mk (Poisoned Partially)) + | Single sv, Zeros -> + if SVal.sure_is_zero sv then zeros + else + let chunk = SVal.leak_chunk sv in + let chunk_size = Expr.int (Chunk.size chunk) in + let zeros_can_be_converted_to_same_chunk = + let open Expr.Infix in + Expr.imod size_right chunk_size == Expr.zero_i + in + if%ent zeros_can_be_converted_to_same_chunk then + let+ zero_array = + SVArr.make_zeros + ~size:Expr.Infix.(size_right / chunk_size) + ~chunk + in + let result = + SVArr.cons_same_chunk sv zero_array |> Option.get + (* Option.get is always safe here *) + in + mk (Array result) + else + let* byte_zeros = + SVArr.make_zeros ~size:size_left ~chunk:Chunk.i8 + in + let+ byte_sv = SVArr.byte_array_of_sval sv in + let result = + SVArr.concat_same_chunk byte_sv byte_zeros |> Option.get + (* Option.get is always safe here *) + in + mk (Array result) + | Zeros, Single sv -> + if SVal.sure_is_zero sv then zeros + else + let chunk = SVal.leak_chunk sv in + let chunk_size = Expr.int (Chunk.size chunk) in + let zeros_can_be_converted_to_same_chunk = + let open Expr.Infix in + Expr.imod size_left chunk_size == Expr.zero_i + in + if%ent zeros_can_be_converted_to_same_chunk then + let+ zero_array = + SVArr.make_zeros + ~size:Expr.Infix.(size_left / chunk_size) + ~chunk + in + let result = + SVArr.append_same_chunk zero_array sv |> Option.get + in + (* Garanteed to work *) + mk (Array result) + else + let* byte_zeros = + SVArr.make_zeros ~size:size_left ~chunk:Chunk.i8 + in + let+ byte_sv = SVArr.byte_array_of_sval sv in + let result = + SVArr.concat_same_chunk byte_zeros byte_sv |> Option.get + in + (* Garanteed to work *) + mk (Array result) + | (Array arr, Zeros | Zeros, Array arr) when SVArr.sure_is_all_zeros arr + -> zeros + | Zeros, Array arr -> + if SVArr.sure_is_all_zeros arr then zeros + else + let chunk = SVArr.leak_chunk arr in + let chunk_size = Expr.int (Chunk.size chunk) in + let zeros_can_be_converted_to_same_chunk = + let open Expr.Infix in + Expr.imod size_left chunk_size == Expr.zero_i + in + if%ent zeros_can_be_converted_to_same_chunk then + let+ zero_array = + SVArr.make_zeros + ~size:Expr.Infix.(size_left / chunk_size) + ~chunk + in + let result = + SVArr.concat_same_chunk zero_array arr |> Option.get + in + (* Garanteed to work *) + mk (Array result) + else ret (mk LazyValue) + | Array arr, Zeros -> + if SVArr.sure_is_all_zeros arr then zeros + else + let chunk = SVArr.leak_chunk arr in + let chunk_size = Expr.int (Chunk.size chunk) in + let zeros_can_be_converted_to_same_chunk = + let open Expr.Infix in + Expr.imod size_right chunk_size == Expr.zero_i + in + if%ent zeros_can_be_converted_to_same_chunk then + let+ zero_array = + SVArr.make_zeros + ~size:Expr.Infix.(size_right / chunk_size) + ~chunk + in + let result = + SVArr.concat_same_chunk arr zero_array |> Option.get + in + (* Garanteed to work *) + mk (Array result) + else ret (mk LazyValue) + | LazyValue, _ | _, LazyValue -> lazy_value + | Single sva, Single svb -> ( + match SVArr.of_two_svals_same_chunk sva svb with + | Some arr -> array arr + | None -> lazy_value) + | Single sv, Array arr -> ( + match SVArr.cons_same_chunk sv arr with + | Some arr -> array arr + | None -> lazy_value) + | Array arr, Single sv -> ( + match SVArr.append_same_chunk arr sv with + | Some arr -> array arr + | None -> lazy_value) + | Array arra, Array arrb -> ( + match SVArr.concat_same_chunk arra arrb with + | Some arr -> array arr + | None -> lazy_value)) + + let decode ~low ~chunk t = + let open Delayed.Syntax in + let open DR.Syntax in + match t with + | NotOwned Partially -> DR.error (MissingResource Unfixable) + | NotOwned Totally -> + DR.error (MissingResource (Fixable { is_store = false; low; chunk })) + | MemVal { mem_val = Poisoned _; exact_perm; _ } -> DR.error LoadingPoison + | MemVal { mem_val = Zeros; exact_perm; _ } -> + DR.ok (SVal.zero_of_chunk chunk, exact_perm) + | MemVal { mem_val = Single sval; exact_perm; _ } -> + let+ sval = SVal.reencode ~chunk sval in + Ok (sval, exact_perm) + | MemVal { mem_val = Array arr; exact_perm; _ } -> + let+ sval = SVArr.decode_as_sval ~chunk arr in + Ok (sval, exact_perm) + | MemVal { mem_val = LazyValue; exact_perm; _ } -> + failwith "unimplmented: decoding lazy value" + + let decode_array ~size ~chunk t = + let open Delayed.Syntax in + let open DR.Syntax in + match t with + | NotOwned _ -> DR.error (MissingResource Unfixable) + | MemVal { mem_val = Poisoned _; exact_perm; _ } -> DR.error LoadingPoison + | MemVal { mem_val = Zeros; exact_perm; _ } -> + let+ arr = SVArr.make_zeros ~chunk ~size in + Ok (arr, exact_perm) + | MemVal { mem_val = Single sval; exact_perm; _ } -> + let+ arr = SVArr.decode_sval_into ~chunk sval in + Ok (arr, exact_perm) + | MemVal { mem_val = Array svarr; exact_perm; _ } -> + let+ arr = SVArr.reencode ~chunk svarr in + Ok (arr, exact_perm) + | MemVal { mem_val = LazyValue; _ } -> + failwith "unimplmented: decoding lazy value" + + let single ~(perm : Perm.t) ~chunk (sval : SVal.t) : t Delayed.t = + let open Delayed.Syntax in + let* encoded_sval = SVal.reencode ~chunk sval in + let mem_val = Single encoded_sval in + Delayed.return (MemVal { exact_perm = Some perm; min_perm = perm; mem_val }) + + let array ~(perm : Perm.t) ~(chunk : Chunk.t) (sarr : SVArr.t) = + let mem_val = Array sarr in + MemVal { exact_perm = Some perm; min_perm = perm; mem_val } + + let lvars = function + | MemVal { mem_val = Single sval; _ } -> SVal.lvars sval + | MemVal { mem_val = Array sarr; _ } -> SVArr.lvars sarr + | _ -> SS.empty + + let alocs = function + | MemVal { mem_val = Single sval; _ } -> SVal.alocs sval + | MemVal { mem_val = Array svarr; _ } -> SVArr.alocs svarr + | _ -> SS.empty + + let substitution ~sval_subst ~svarr_subst n = + let smv = function + | Single s -> Single (sval_subst s) + | Array a -> Array (svarr_subst a) + | u -> u + in + match n with + | MemVal mv -> MemVal { mv with mem_val = smv mv.mem_val } + | no -> no +end + +module Tree = struct + type t = { node : Node.t; span : Range.t; children : (t * t) option } + [@@deriving yojson] + + module Lift = struct + open Gillian.Debugger.Utils + + let rec as_variable + ~(make_node : + name:string -> + value:string -> + ?children:Variable.t list -> + unit -> + Variable.t) + (tree : t) : Variable.t = + let as_variable = as_variable ~make_node in + let str pp = Fmt.to_to_string (Fmt.hbox pp) in + let name = (str Range.pp) tree.span in + let value = (str Node.pp) tree.node in + let children = + Option.map + (fun (a, b) -> [ as_variable a; as_variable b ]) + tree.children + in + make_node ~name ~value ?children () + end + + let box_range_and_node span node = + let open PrintBox in + frame + @@ hlist + [ + hpad 2 @@ text (Fmt.to_to_string Range.pp @@ span); + hpad 1 @@ text (Fmt.to_to_string Node.pp @@ node); + ] + + let box_full t = + let open PrintBox in + let make { node; span; children; _ } = + let node = box_range_and_node span node in + let children = + match children with + | None -> [] + | Some (a, b) -> [ a; b ] + in + (node, children) + in + mk_tree make t + + let pp_full fmt t = PrintBox_text.pp fmt (box_full t) + + let is_empty { node; _ } = + match node with + | NotOwned Totally -> true + | _ -> false + + let rec is_concrete { node; span; children } = + Node.is_concrete node && Range.is_concrete span + && Option.fold ~none:true + ~some:(fun (a, b) -> is_concrete a && is_concrete b) + children + + let make ~node ~span ?children () = { node; span; children } + + let instantiate (low : Expr.t) (high : Expr.t) = + let span = (low, high) in + make + ~node:(Node.make_owned ~mem_val:(Poisoned Totally) ~perm:Perm.Freeable) + ~span () + + let remove_node x = DR.ok (make ~node:(NotOwned Totally) ~span:x.span ()) + + (* Used to change the position of a tree. The start of the tree is going to be [start], but the spans don't change. *) + let rec realign t start = + let open Expr.Infix in + let reduce e = Engine.Reduction.reduce_lexpr e in + let l, h = t.span in + let span = (start, reduce (start + h - l)) in + let children = + Option.map + (fun (left, right) -> + let left = realign left start in + let _, m = left.span in + let right = realign right m in + (left, right)) + t.children + in + make ~node:t.node ~span ?children () + + let with_children t ~left ~right = + Delayed.return { t with children = Some (left, right) } + + let of_children_s ~left ~right = + let open Delayed.Syntax in + let span = (fst left.span, snd right.span) in + let+ node = + Node.merge + ~left:(left.node, Range.size left.span) + ~right:(right.node, Range.size right.span) + in + let children = + match node with + | Node.NotOwned Totally + | MemVal { exact_perm = Some _; mem_val = Zeros | Poisoned Totally; _ } -> + None + | _ -> Some (left, right) + in + { span; children; node } + + let of_children _ ~left ~right = of_children_s ~left ~right + + let update_parent_perm t ~left ~right = + let { node; span; _ } = t in + let new_node = + Node.update_parent_perm node ~left:left.node ~right:right.node + in + Delayed.return { node = new_node; span; children = Some (left, right) } + + let sval_leaf ~low ~perm ~value ~chunk = + let open Delayed.Syntax in + let* node = Node.single ~perm ~chunk value in + let span = Range.of_low_and_chunk low chunk in + Delayed.return (make ~node ~span ()) + + let sarr_leaf ~low ~perm ~size ~array ~chunk = + let node = Node.array ~perm ~chunk array in + let span = Range.of_low_chunk_and_size low chunk size in + make ~node ~span () + + let poisoned ?(perm = Perm.Freeable) span = + make ~node:(Node.poisoned ~perm) ~span () + + let zeros ?(perm = Perm.Freeable) span = + make ~node:(Node.make_owned ~mem_val:Zeros ~perm) ~span () + + let create_root range = + { children = None; span = range; node = NotOwned Totally } + + let rec split ~range t : (Node.t * t * t) Delayed.t = + (* this function splits a tree and returns the node in the given range *) + (* We're assuming that range is inside old_span *) + let open Expr.Infix in + let open Delayed.Syntax in + let old_span = t.span in + let ol, oh = old_span in + let nl, nh = range in + if%sat + log_string "ol #== nl"; + ol == nl + then + let at = nh in + let+ left_node, right_node = Node.split ~span:old_span ~at t.node in + let left_span, right_span = Range.split_at old_span at in + let left = make ~node:left_node ~span:left_span () in + let right = make ~node:right_node ~span:right_span () in + (left_node, left, right) + else + if%sat + log_string "oh #== nh"; + oh == nh + then + let at = nl in + let+ left_node, right_node = Node.split ~span:old_span ~at t.node in + let left_span, right_span = Range.split_at old_span nl in + let left = make ~node:left_node ~span:left_span () in + let right = make ~node:right_node ~span:right_span () in + (right_node, left, right) + else + (* We're first splitting on the left then splitting again on the right *) + let* left_node, right_node = Node.split ~span:old_span ~at:nl t.node in + let left_span, right_span = Range.split_at old_span nl in + let left = make ~node:left_node ~span:left_span () in + let full_right = make ~node:right_node ~span:right_span () in + let* node, right_left, right_right = split ~range full_right in + let+ right = + with_children full_right ~left:right_left ~right:right_right + in + (node, left, right) + + let extend_if_needed t range = + let open Expr.Infix in + let open Delayed.Syntax in + let rl, rh = range in + let sl, sh = t.span in + let* t_with_left = + if%sat rl < sl then + let new_left_tree = make ~node:(NotOwned Totally) ~span:(rl, sl) () in + let children = (new_left_tree, t) in + Delayed.return + (make ~node:(NotOwned Partially) ~span:(rl, sh) ~children ()) + else Delayed.return t + in + let sl, _ = t_with_left.span in + let* result = + if%sat rh > sh then + let new_right_tree = make ~node:(NotOwned Totally) ~span:(sh, rh) () in + let children = (t_with_left, new_right_tree) in + Delayed.return + (make ~node:(NotOwned Partially) ~span:(sl, rh) ~children ()) + else Delayed.return t_with_left + in + Delayed.return result + + let frame_range + (t : t) + ~(replace_node : t -> (t, err) DR.t) + ~rebuild_parent + (range : Range.t) : (t * t, err) DR.t = + let open DR.Syntax in + let open Delayed.Syntax in + let rec extract (t : t) (range : Range.t) : (t * t option) Delayed.t = + (* First result is the extracted tree, second is the remain *) + let open Delayed in + let open Syntax in + if%sat + log_string "EXTRACT range is equal span"; + Range.is_equal range t.span + then return (t, None) + else + let left, right = Option.get t.children in + if%sat + log_string "EXTRACT range inside left"; + Range.is_inside range left.span + then + let* extracted, new_left = extract left range in + let+ new_self = + match new_left with + | Some left -> of_children_s ~right ~left + | None -> Delayed.return right + in + (extracted, Some new_self) + else + let* extracted, new_right = extract right range in + let+ new_self = + match new_right with + | Some right -> of_children_s ~right ~left + | None -> Delayed.return left + in + (extracted, Some new_self) + in + let rec add_to_the_right t addition : t Delayed.t = + match t.children with + | None -> of_children_s ~left:t ~right:addition + | Some (left, right) -> + let* new_right = add_to_the_right right addition in + of_children_s ~left ~right:new_right + in + let rec add_to_the_left t addition : t Delayed.t = + match t.children with + | None -> of_children_s ~left:addition ~right:t + | Some (left, right) -> + let* new_left = add_to_the_left left addition in + of_children_s ~left:new_left ~right + in + let rec frame_inside + ~(replace_node : t -> (t, err) DR.t) + ~rebuild_parent + (t : t) + (range : Range.t) = + Logging.verbose (fun fmt -> + fmt "STARTING FRAME INSIDE WITH: %a" pp_full t); + if%sat + log_string "range equals span"; + Range.is_equal range t.span + then ( + log_string "Range does equal span, replacing."; + let++ new_tree = replace_node t in + log_string "Range does equal span, replacing done."; + (t, new_tree)) + else + match t.children with + | Some (left, right) -> + let _, mid = left.span in + if%sat + log_string + (Fmt.str "mid strictly in range: %a in %a" Expr.pp mid Range.pp + range); + Range.point_strictly_inside mid range + then + let l, h = range in + let upper_range = (mid, h) in + let dont_replace_node t = DR.ok t in + if%sat + (* High-range already good *) + Range.is_equal upper_range right.span + then + (* Rearrange left*) + let lower_range = (l, mid) in + let** _, left = + frame_inside ~replace_node:dont_replace_node + ~rebuild_parent:with_children left lower_range + in + let* extracted, left_opt = extract left lower_range in + let* right = add_to_the_left right extracted in + let* new_self = + of_children_s ~left:(Option.get left_opt) ~right + in + (* match left_opt with + | Some left -> of_children_s ~left ~right + | None -> Delayed.return right + in *) + frame_inside ~replace_node ~rebuild_parent new_self range + else + let** _, right = + frame_inside ~replace_node:dont_replace_node + ~rebuild_parent:with_children right upper_range + in + let* extracted, right_opt = extract right upper_range in + let* left = add_to_the_right left extracted in + let* new_self = + of_children_s ~left ~right:(Option.get right_opt) + in + (* match right_opt with + | Some right -> of_children_s ~left ~right + | None -> Delayed.return left + in *) + frame_inside ~replace_node ~rebuild_parent new_self range + else + if%sat + log_string "range inside left"; + Range.is_inside range left.span + then + let** node, left = + frame_inside ~replace_node ~rebuild_parent left range + in + let+ new_parent = rebuild_parent t ~left ~right in + Ok (node, new_parent) + else + if%sat + log_string "range inside right"; + Range.is_inside range right.span + then + let** node, right = + frame_inside ~replace_node ~rebuild_parent right range + in + let+ new_parent = rebuild_parent t ~left ~right in + Ok (node, new_parent) + else ( + Logging.verbose (fun fmt -> + fmt + "ABOUT TO SAY PRECUT:\nLEFT: %a\nRIGHT: %a\n RANGE: %a" + Range.pp left.span Range.pp right.span Range.pp range); + DR.error (Unhandled "wrong pre-cut")) + | None -> + let open Delayed.Syntax in + let* _, left, right = split ~range t in + let* new_self = with_children t ~left ~right in + Logging.verbose (fun fmt -> + fmt "AFTER SPLITTING FOR %a: %a" Range.pp range pp_full new_self); + frame_inside ~replace_node ~rebuild_parent new_self range + in + let open Delayed.Syntax in + let* root = extend_if_needed t range in + frame_inside ~replace_node ~rebuild_parent root range + + let cons_node (t : t) range : (Node.t * t, err) DR.t = + let open DR.Syntax in + let replace_node x = remove_node x in + let rebuild_parent = of_children in + let++ framed, rest = frame_range t ~replace_node ~rebuild_parent range in + (framed.node, rest) + + let prod_node (t : t) range node : (t, err) DR.t = + let open DR.Syntax in + let replace_node _ = DR.ok (make ~node ~span:range ()) in + let rebuild_parent = of_children in + let++ _, t = frame_range t ~replace_node ~rebuild_parent range in + t + + let get_array (t : t) (low : Expr.t) (chunk : Chunk.t) (size : Expr.t) : + (SVArr.t * Perm.t option * t, err) DR.t = + let open DR.Syntax in + let open Delayed.Syntax in + let* size = Delayed.reduce size in + let replace_node x = DR.ok x in + let rebuild_parent = with_children in + let range = Range.of_low_chunk_and_size low chunk size in + let** framed, tree = frame_range t ~replace_node ~rebuild_parent range in + let+* arr, perm = Node.decode_array ~size ~chunk framed.node in + Ok (arr, perm, tree) + + let cons_array (t : t) (low : Expr.t) (chunk : Chunk.t) (size : Expr.t) : + (SVArr.t * Perm.t option * t, err) DR.t = + let open DR.Syntax in + let open Delayed.Syntax in + let* size = Delayed.reduce size in + let replace_node = remove_node in + let rebuild_parent = of_children in + let range = Range.of_low_chunk_and_size low chunk size in + let** framed, tree = frame_range t ~replace_node ~rebuild_parent range in + let+* arr, perm = Node.decode_array ~size ~chunk framed.node in + Ok (arr, perm, tree) + + let prod_array + (t : t) + (low : Expr.t) + (size : Expr.t) + (chunk : Chunk.t) + (array : SVArr.t) + (perm : Perm.t) : (t, err) DR.t = + let open DR.Syntax in + let open Delayed.Syntax in + let replace_node _ = DR.ok (sarr_leaf ~low ~chunk ~array ~size ~perm) in + let rebuild_parent = of_children in + let range = Range.of_low_chunk_and_size low chunk size in + let++ _, t = frame_range t ~replace_node ~rebuild_parent range in + (* let+ () = SVArr.learn_chunk ~chunk ~size array in *) + t + + let get_single (t : t) (low : Expr.t) (chunk : Chunk.t) : + (SVal.t * Perm.t option * t, err) DR.t = + let open DR.Syntax in + let replace_node x = DR.ok x in + let rebuild_parent = with_children in + let range = Range.of_low_and_chunk low chunk in + let** framed, tree = frame_range t ~replace_node ~rebuild_parent range in + let node = framed.node in + Logging.tmi (fun m -> + m "GET_SINGLE GOT THE FOLLOWING NODE: %a" Node.pp node); + let++ sval, perm = Node.decode ~low ~chunk node in + (sval, perm, tree) + + let prod_single + (t : t) + (low : Expr.t) + (chunk : Chunk.t) + (sval : SVal.t) + (perm : Perm.t) : (t, err) DR.t = + let open DR.Syntax in + let open Delayed.Syntax in + Logging.tmi (fun m -> m "PROD_SINGLE"); + let replace_node _ = + let* leaf = sval_leaf ~low ~chunk ~value:sval ~perm in + DR.ok leaf + in + let rebuild_parent = of_children in + let range = Range.of_low_and_chunk low chunk in + let++ _, t = frame_range t ~replace_node ~rebuild_parent range in + Logging.tmi (fun m -> m "DONE_PROD_SINGLE"); + t + + let load (t : t) (low : Expr.t) (chunk : Chunk.t) : (SVal.t * t, err) DR.t = + Logging.tmi (fun m -> m "LOADING"); + let open DR.Syntax in + let open Perm.Infix in + let range = Range.of_low_and_chunk low chunk in + let replace_node node = + match node.node with + | Node.NotOwned Partially -> DR.error (MissingResource Unfixable) + | Node.NotOwned Totally -> + DR.error (MissingResource (Fixable { is_store = false; low; chunk })) + | MemVal { min_perm; _ } -> + if min_perm >=% Readable then DR.ok node + else + DR.error + (InsufficientPermission { required = Readable; actual = min_perm }) + in + let rebuild_parent = with_children in + let** framed, tree = frame_range t ~replace_node ~rebuild_parent range in + let++ sval, _ = Node.decode ~low ~chunk framed.node in + (sval, tree) + + let store (t : t) (low : Expr.t) (chunk : Chunk.t) (sval : SVal.t) : + (t, err) DR.t = + let open DR.Syntax in + let open Delayed.Syntax in + let open Perm.Infix in + let range = Range.of_low_and_chunk low chunk in + let replace_node node = + match node.node with + | NotOwned Totally -> + DR.error (MissingResource (Fixable { is_store = true; low; chunk })) + | NotOwned Partially -> DR.error (MissingResource Unfixable) + | MemVal { min_perm; _ } -> + if min_perm >=% Writable then + let* leaf = sval_leaf ~low ~chunk ~value:sval ~perm:min_perm in + DR.ok leaf + else + DR.error + (InsufficientPermission { required = Writable; actual = min_perm }) + in + let rebuild_parent = of_children in + let++ _, tree = frame_range t ~replace_node ~rebuild_parent range in + tree + + let zero_init (t : t) (range : Range.t) : (t, err) DR.t = + let open DR.Syntax in + let open Perm.Infix in + let replace_node node = + match node.node with + | NotOwned _ -> DR.error (MissingResource Unfixable) + | MemVal { min_perm; _ } -> + if min_perm >=% Writable then DR.ok (zeros ~perm:min_perm range) + else + DR.error + (InsufficientPermission { required = Writable; actual = min_perm }) + in + let rebuild_parent = of_children in + let++ _, tree = frame_range t ~replace_node ~rebuild_parent range in + tree + + let poison (t : t) (range : Range.t) : (t, err) DR.t = + let open DR.Syntax in + let open Perm.Infix in + let replace_node node = + match node.node with + | NotOwned _ -> DR.error (MissingResource Unfixable) + | MemVal { min_perm; _ } -> + if min_perm >=% Writable then DR.ok (poisoned ~perm:min_perm range) + else + DR.error + (InsufficientPermission { required = Writable; actual = min_perm }) + in + let rebuild_parent = of_children in + let++ _, tree = frame_range t ~replace_node ~rebuild_parent range in + tree + + let get_perm_at (tree : t) (ofs : Expr.t) : (Perm.t, err) DR.t = + let range = + let open Expr.Infix in + (ofs, ofs + Expr.int 1) + in + let { span; _ } = tree in + let rec rec_call treep = + match Node.exact_perm treep.node with + | `StopLooking r -> DR.of_result r + | `KeepLooking -> + let left, right = Option.get treep.children in + if%sat Range.is_inside range left.span then rec_call left + else rec_call right + in + if%sat Range.is_inside range span then rec_call tree + else DR.error (MissingResource Unfixable) + + let weak_valid_pointer (tree : t) (ofs : Expr.t) : (bool, err) DR.t = + let open Delayed.Syntax in + let open Perm.Infix in + let open Expr.Infix in + let* at_ofs = get_perm_at tree ofs in + match at_ofs with + | Ok p when p >=% Nonempty -> DR.ok true + | _ -> + let+ at_ofs_minus_one = get_perm_at tree (ofs - Expr.int 1) in + at_ofs_minus_one |> Result.map (fun p -> p >=% Nonempty) + + let drop_perm (t : t) (low : Expr.t) (high : Expr.t) (perm : Perm.t) : + (t, err) DR.t = + let rec rec_set_perm { node; span; children } = + let node = Node.drop_perm_exn ~perm node in + let children = + Option.map (fun (a, b) -> (rec_set_perm a, rec_set_perm b)) children + in + { node; span; children } + in + let open DR.Syntax in + let range = Range.make low high in + let replace_node node = + match node.node with + | NotOwned _ -> DR.error (MissingResource Unfixable) + | MemVal { min_perm = Freeable; _ } -> DR.ok (rec_set_perm node) + | MemVal { min_perm; _ } -> + DR.error + (InsufficientPermission { required = Freeable; actual = min_perm }) + in + let rebuild_parent = update_parent_perm in + let++ _, t = frame_range t ~replace_node ~rebuild_parent range in + t + + let rec lvars { node; span; children; _ } = + let node_lvars = Node.lvars node in + let span_lvars = Range.lvars span in + let children_lvars = + match children with + | Some (a, b) -> SS.union (lvars a) (lvars b) + | None -> SS.empty + in + SS.union (SS.union node_lvars span_lvars) children_lvars + + let rec alocs { node; span; children; _ } = + let node_lvars = Node.alocs node in + let span_lvars = Range.alocs span in + let children_lvars = + match children with + | Some (a, b) -> SS.union (alocs a) (alocs b) + | None -> SS.empty + in + SS.union (SS.union node_lvars span_lvars) children_lvars + + let rec assertions { node; span; children; _ } = + let low, high = span in + match node with + | NotOwned Totally -> [] + | NotOwned Partially + | MemVal { mem_val = Poisoned Partially; _ } + | MemVal { mem_val = LazyValue; _ } -> + let left, right = Option.get children in + assertions left @ assertions right + | MemVal { mem_val = Poisoned Totally; exact_perm = perm; _ } -> + [ Preds.Core.hole ~low ~high ~perm ] + | MemVal { mem_val = Zeros; exact_perm = perm; _ } -> + [ Preds.Core.zeros ~low ~high ~perm ] + | MemVal { mem_val = Single sval; exact_perm = perm; _ } -> + let chunk, sval = SVal.leak sval in + [ Preds.Core.single ~ofs:low ~chunk ~sval ~perm ] + | MemVal { mem_val = Array sarr; exact_perm = perm; _ } -> + let chunk, sval_arr = SVArr.leak sarr in + let chksize = Expr.int (Chunk.size chunk) in + let total_size = + let open Expr.Infix in + (high - low) / chksize + in + [ Preds.Core.array ~ofs:low ~perm ~chunk ~size:total_size ~sval_arr ] + + let rec assertions_others { node; span; children; _ } = + let low, high = span in + match node with + | NotOwned Totally -> [] + | NotOwned Partially | MemVal { mem_val = Poisoned Partially; _ } -> + let left, right = Option.get children in + assertions_others left @ assertions_others right + | MemVal { mem_val = Poisoned Totally; _ } -> [] + | MemVal { mem_val = Zeros; _ } -> [] + | MemVal { mem_val = LazyValue; _ } -> [] + | MemVal { mem_val = Single value; _ } -> SVal.assertions_others value + | MemVal { mem_val = Array svarr; _ } -> + SVArr.assertions_others ~low ~high svarr + + let rec substitution + ~svarr_subst + ~sval_subst + ~le_subst + { node; span; children } = + let node = Node.substitution ~sval_subst ~svarr_subst node in + let span = Range.substitution ~le_subst span in + let children = + Option.map + (fun (left, right) -> + let f = substitution ~sval_subst ~le_subst ~svarr_subst in + (f left, f right)) + children + in + { node; span; children } + + let box t = + let rec flatten_tree { node; span; children; _ } = + match node with + | NotOwned Partially + | MemVal { mem_val = Poisoned Partially | LazyValue; _ } -> + let left, right = Option.get children in + flatten_tree left @ flatten_tree right + | node -> [ (span, node) ] + in + let open PrintBox in + frame @@ vlist_map (fun (x, y) -> box_range_and_node x y) (flatten_tree t) + + let pp fmt tree = PrintBox_text.pp fmt (box tree) +end + +type t = { bounds : Range.t option; root : Tree.t option } [@@deriving yojson] + +let pp_full fmt = function + | { bounds; root } -> + let pp_aux fmt (bounds, root) = + Fmt.pf fmt "%a@ %a" + (Fmt.option ~none:(Fmt.any "NO BOUNDS") Range.pp) + bounds + (Fmt.option ~none:(Fmt.any "EMPTY") Tree.pp_full) + root + in + (Fmt.parens (Fmt.vbox pp_aux)) fmt (bounds, root) + +let pp fmt t = + Fmt.pf fmt "%a@ %a" + (Fmt.option ~none:(Fmt.any "NO BOUNDS") Range.pp) + t.bounds + (Fmt.option ~none:(Fmt.any "EMPTY") Tree.pp) + t.root + +let empty = { bounds = None; root = None } +let is_empty t = Option.is_none t.bounds && Option.is_none t.root + +let lvars = function + | { bounds; root } -> + SS.union + (Option.fold ~none:SS.empty ~some:Range.lvars bounds) + (Option.fold ~none:SS.empty ~some:Tree.lvars root) + +let alocs = function + | { bounds; root } -> + SS.union + (Option.fold ~none:SS.empty ~some:Range.alocs bounds) + (Option.fold ~none:SS.empty ~some:Tree.alocs root) + +let get_root = function + | { root; _ } -> Ok root + +let is_in_bounds range bounds = + match bounds with + | None -> Expr.true_ + | Some bounds -> Range.is_inside range bounds + +let get_perm_at t ofs = + let open DR.Syntax in + match t with + | { bounds; root } -> + let is_in_bounds = + let open Expr.Infix in + is_in_bounds (ofs, ofs + Expr.int 1) bounds + in + if%sat is_in_bounds then + match root with + | None -> DR.error (MissingResource Unfixable) + | Some root -> + let++ perm = Tree.get_perm_at root ofs in + Some perm + else DR.ok None + +let weak_valid_pointer (t : t) (ofs : Expr.t) : (bool, err) DR.t = + let is_sure_false bounds ofs = + let open Expr.Infix in + match bounds with + | None -> Expr.false_ + | Some (low, high) -> ofs < low || ofs > high + in + match t with + | { bounds; root } -> ( + if%sat is_sure_false bounds ofs then DR.ok false + else + match root with + | None -> DR.error (MissingResource Unfixable) + | Some root -> Tree.weak_valid_pointer root ofs) + +let get_bounds = function + | { bounds; _ } -> Ok bounds + +let load_bounds = function + | { bounds = Some bounds; _ } -> Ok bounds + | { bounds = None; _ } -> Error (MissingResource Unfixable) + +let cons_bounds = function + | { bounds; root } -> Ok (bounds, { root; bounds = None }) + +let prod_bounds t bounds = + match t with + | { bounds = _; root } -> Ok { root; bounds = Some bounds } + +let rem_bounds t = + match t with + | { bounds = _; root } -> Ok { root; bounds = None } + +let with_root_opt t root = Ok { t with root } +let with_root t root = with_root_opt t (Some root) + +let alloc low high = + let bounds = Range.make low high in + { root = Some (Tree.poisoned bounds); bounds = Some bounds } + +let drop_perm t low high new_perm = + let open DR.Syntax in + match t with + | { bounds; root } -> ( + match root with + | None -> DR.error (MissingResource Unfixable) + | Some tree -> + let++ new_root = Tree.drop_perm tree low high new_perm in + { root = Some new_root; bounds }) + +let is_exclusively_owned_helper t low high = + let open DR.Syntax in + let** bounds = DR.of_result (get_bounds t) in + match t with + (* Can't free something already freed *) + | { bounds = None; _ } -> DR.error (MissingResource Unfixable) + | { bounds = Some bounds; root } -> + (* Can only free if entirely freeable *) + if%ent Range.is_equal (low, high) bounds then + match root with + | None -> DR.error (MissingResource Unfixable) + | Some root -> + let+* node, _ = Tree.cons_node root (low, high) in + Result.map (fun () -> true) (Node.check_perm (Some Freeable) node) + else + DR.error + (Unhandled + "Freeing only part of an object (this might need fixing in the MM)") + +let is_exclusively_owned tree low high : bool Delayed.t = + Delayed.map (is_exclusively_owned_helper tree low high) (fun _ -> true) + +let cons_single t low chunk = + let open DR.Syntax in + let range = Range.of_low_and_chunk low chunk in + let** span = DR.of_result (get_bounds t) in + if%sat is_in_bounds range span then + let** root = DR.of_result (get_root t) in + match root with + | None -> + DR.error (MissingResource (Fixable { is_store = false; low; chunk })) + | Some root -> + let** value, perm, root_framed = Tree.get_single root low chunk in + let++ wroot = DR.of_result (with_root t root_framed) in + (value, perm, wroot) + else DR.error BufferOverrun + +let prod_single t low chunk sval perm = + let open DR.Syntax in + let range = Range.of_low_and_chunk low chunk in + let** root = DR.of_result (get_root t) in + let root = Option.value root ~default:(Tree.create_root range) in + let** root_set = Tree.prod_single root low chunk sval perm in + let** bounds = DR.of_result (get_bounds t) in + let learned = + match bounds with + | None -> [] + | Some bounds -> [ Range.is_inside range bounds ] + in + DR.of_result ~learned (with_root t root_set) + +let get_array t low size chunk = + let open DR.Syntax in + let range = Range.of_low_chunk_and_size low chunk size in + let** span = DR.of_result (get_bounds t) in + if%sat is_in_bounds range span then + let** root = DR.of_result (get_root t) in + match root with + | None -> DR.error (MissingResource Unfixable) + | Some root -> + let** array, perm, root_framed = Tree.get_array root low chunk size in + let++ wroot = DR.of_result (with_root t root_framed) in + (array, perm, wroot) + else DR.error BufferOverrun + +let cons_array t low size chunk = + let open DR.Syntax in + let range = Range.of_low_chunk_and_size low chunk size in + match t with + | { bounds = None; _ } -> DR.error (MissingResource Unfixable) + | { bounds = Some bounds; root } -> + if%sat is_in_bounds range (Some bounds) then + match root with + | None -> DR.error (MissingResource Unfixable) + | Some root -> + let** array, perm, root_framed = + Tree.cons_array root low chunk size + in + let++ wroot = DR.of_result (with_root t root_framed) in + (array, perm, wroot) + else DR.error BufferOverrun + +let prod_array t low size chunk array perm = + let open DR.Syntax in + let range = Range.of_low_chunk_and_size low chunk size in + let** root = DR.of_result (get_root t) in + let root = Option.value root ~default:(Tree.create_root range) in + let** root_set = Tree.prod_array root low size chunk array perm in + let** bounds = DR.of_result (get_bounds t) in + let learned = + match bounds with + | None -> [] + | Some bounds -> [ Range.is_inside range bounds ] + in + DR.of_result ~learned (with_root t root_set) + +let cons_simple_mem_val ~expected_mem_val t low high = + let open DR.Syntax in + let range = (low, high) in + let** span = DR.of_result (get_bounds t) in + if%sat is_in_bounds range span then + let** root = DR.of_result (get_root t) in + match root with + | None -> DR.error (MissingResource Unfixable) + | Some root -> + let** node, root_framed = Tree.cons_node root range in + let res = + match node with + | MemVal { mem_val; exact_perm = perm; _ } + when expected_mem_val mem_val -> Ok perm + | NotOwned _ -> Error (MissingResource Unfixable) + | _ -> Error WrongMemVal + in + let++ wroot = + DR.of_result + ( Result.bind res @@ fun perm -> + Result.map (fun mem -> (mem, perm)) (with_root t root_framed) ) + in + wroot + else DR.error BufferOverrun + +let prod_simple_mem_val ~mem_val t low high perm = + let open DR.Syntax in + let range = (low, high) in + let** root = DR.of_result (get_root t) in + let root = Option.value ~default:(Tree.create_root range) root in + let** root_set = Tree.prod_node root range (Node.make_owned ~perm ~mem_val) in + let** bounds = DR.of_result (get_bounds t) in + let learned = + match bounds with + | None -> [] + | Some bounds -> [ Range.is_inside range bounds ] + in + DR.of_result ~learned (with_root t root_set) + +let cons_hole = + cons_simple_mem_val ~expected_mem_val:(function + | Poisoned Totally -> true + | _ -> false) + +let prod_hole = prod_simple_mem_val ~mem_val:(Poisoned Totally) + +let cons_zeros = + cons_simple_mem_val ~expected_mem_val:(function + | Zeros -> true + | _ -> false) + +let prod_zeros = prod_simple_mem_val ~mem_val:Zeros + +let _check_valid_alignment chunk ofs = + let al = Chunk.align chunk in + let al_expr = Expr.int al in + let divides x y = + let open Expr.Infix in + y == Expr.int 0 || Expr.imod y x == Expr.int 0 + in + if%sat divides al_expr ofs then DR.ok () + else DR.error (InvalidAlignment { offset = ofs; alignment = al }) + +let load t chunk ofs = + let open DR.Syntax in + (* FIXME: this should be reestablished asap *) + (* let** () = check_valid_alignment chunk ofs in *) + let range = Range.of_low_and_chunk ofs chunk in + let** span = DR.of_result (get_bounds t) in + if%sat is_in_bounds range span then + let** root = DR.of_result (get_root t) in + match root with + | None -> + DR.error + (MissingResource (Fixable { is_store = false; low = ofs; chunk })) + | Some root -> + let** value, root = Tree.load root ofs chunk in + let++ wroot = DR.of_result (with_root t root) in + (value, wroot) + else DR.error BufferOverrun + +let store t chunk ofs value = + let open DR.Syntax in + (* let** () = check_valid_alignment chunk ofs in *) + let range = Range.of_low_and_chunk ofs chunk in + let** span = DR.of_result (get_bounds t) in + if%sat is_in_bounds range span then + let** root = DR.of_result (get_root t) in + match root with + | None -> DR.error (MissingResource Unfixable) + | Some root -> + let** root = Tree.store root ofs chunk value in + DR.of_result (with_root t root) + else DR.error BufferOverrun + +let zero_init t ofs size = + let open DR.Syntax in + let range = Range.of_low_and_size ofs size in + let** span = DR.of_result (get_bounds t) in + if%sat is_in_bounds range span then + let** root = DR.of_result (get_root t) in + match root with + | None -> DR.error (MissingResource Unfixable) + | Some root -> + let** root = Tree.zero_init root range in + DR.of_result (with_root t root) + else DR.error BufferOverrun + +let poison t ofs size = + let open DR.Syntax in + let range = Range.of_low_and_size ofs size in + let** span = DR.of_result (get_bounds t) in + if%sat is_in_bounds range span then + let** root = DR.of_result (get_root t) in + match root with + | None -> DR.error (MissingResource Unfixable) + | Some root -> + let** root = Tree.poison root range in + DR.of_result (with_root t root) + else DR.error BufferOverrun + +let move dst_tree dst_ofs src_tree src_ofs size = + let open DR.Syntax in + let dst_range, src_range = + let open Expr.Infix in + ((dst_ofs, dst_ofs + size), (src_ofs, src_ofs + size)) + in + let** src_span = DR.of_result (get_bounds src_tree) in + if%sat is_in_bounds src_range src_span then + let** src_root = DR.of_result (get_root src_tree) in + match src_root with + | None -> DR.error (MissingResource Unfixable) + | Some src_root -> + let** framed, _ = + Tree.frame_range src_root + ~replace_node:(fun x -> DR.ok x) + ~rebuild_parent:(fun t ~left:_ ~right:_ -> Delayed.return t) + src_range + in + let** () = + match framed.node with + | NotOwned _ -> DR.error (MissingResource Unfixable) + | _ -> DR.ok () + in + let** dst_span = DR.of_result (get_bounds dst_tree) in + if%sat is_in_bounds dst_range dst_span then + let** dst_root = DR.of_result (get_root dst_tree) in + match dst_root with + | None -> DR.error (MissingResource Unfixable) + | Some dst_root -> + let** _, new_dst_root = + Tree.frame_range dst_root + ~replace_node:(fun current -> + match current.node with + | NotOwned _ -> DR.error (MissingResource Unfixable) + | _ -> DR.ok (Tree.realign framed dst_ofs)) + ~rebuild_parent:Tree.of_children dst_range + in + DR.of_result (with_root dst_tree new_dst_root) + else DR.error BufferOverrun + else DR.error BufferOverrun + +let assertions (t : t) = + let bounds = + Option.fold ~none:[] + ~some:(fun (low, high) -> [ Preds.Core.bounds ~low ~high ]) + t.bounds + in + let tree = + match t.root with + | None -> [] + | Some root -> Tree.assertions root + in + bounds @ tree + +let merge ~old_tree ~new_tree = + let open DR.Syntax in + Logging.verbose (fun m -> m "OLD TREE:@\n%a" pp old_tree); + Logging.verbose (fun m -> m "NEW TREE:@\n%a" pp new_tree); + if is_empty old_tree then DR.ok new_tree + else if is_empty new_tree then DR.ok old_tree + else + let def_bounds = + match new_tree.bounds with + | Some bounds -> Some bounds + | None -> old_tree.bounds + in + let rec get_owned_nodes (t : Tree.t) : Tree.t list = + match t.node with + | NotOwned Totally -> [] + | NotOwned Partially -> + let left, right = Option.get t.children in + get_owned_nodes left @ get_owned_nodes right + | _ -> [ t ] + in + let++ def_root = + match (old_tree.root, new_tree.root) with + | None, None -> DR.ok None + | None, Some d | Some d, None -> DR.ok (Some d) + | Some d, Some o when Tree.is_empty o -> DR.ok (Some d) + | Some o, Some d when Tree.is_empty o -> DR.ok (Some d) + | Some old_root, Some new_root -> + let new_owned_nodes = get_owned_nodes new_root in + Logging.verbose (fun fmt -> + fmt "There are %d new owned nodes" (List.length new_owned_nodes)); + let++ tree = + List.fold_left + (fun acc (tree_node : Tree.t) -> + let** acc = acc in + let replace_node _ = DR.ok tree_node in + let rebuild_parent = Tree.of_children in + let++ _, tree = + Tree.frame_range acc ~replace_node ~rebuild_parent + tree_node.span + in + tree) + (DR.ok old_root) new_owned_nodes + in + Some tree + in + Logging.verbose (fun m -> + m "TREE AFTER MERGE:@\n%a" (Fmt.Dump.option Tree.pp) def_root); + { bounds = def_bounds; root = def_root } + +let substitution ~le_subst ~sval_subst ~svarr_subst t = + match t with + | { bounds; root } -> + let bounds = Option.map (Range.substitution ~le_subst) bounds in + let root = + Option.map (Tree.substitution ~sval_subst ~le_subst ~svarr_subst) root + in + { bounds; root } + +module Lift = struct + open Gillian.Debugger.Utils + + let get_variable + ~(make_node : + name:string -> + value:string -> + ?children:Variable.t list -> + unit -> + Variable.t) + ~loc + t : Variable.t = + match t with + | { bounds; root } -> + let bounds = + match bounds with + | None -> make_node ~name:"Bounds" ~value:"Not owned" () + | Some bounds -> + make_node ~name:"Bounds" ~value:"" + ~children:(Range.Lift.as_variables ~make_node bounds) + () + in + let root = + match root with + | None -> make_node ~name:"Tree" ~value:"Not owned" () + | Some root -> Tree.Lift.as_variable ~make_node root + in + make_node ~name:loc ~value:"Allocated" ~children:[ bounds; root ] () +end + +let assertions_others t = + Option.fold t.root ~some:Tree.assertions_others ~none:[] + +let instantiate low high = + { + bounds = Some (Range.make low high); + root = Some (Tree.instantiate low high); + } + +let is_concrete { bounds; root } = + Option.fold ~none:true ~some:Range.is_concrete bounds + && Option.fold ~none:true ~some:Tree.is_concrete root diff --git a/Gillian-LLVM/lib/llvm_memory_model/SHeapTree.mli b/Gillian-LLVM/lib/llvm_memory_model/SHeapTree.mli new file mode 100644 index 000000000..94e9dc269 --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/SHeapTree.mli @@ -0,0 +1,107 @@ +open Gil_syntax +open Gillian.Utils.Containers +open Monadic +open SVal + +type missingResourceType = + | Unfixable + | Fixable of { is_store : bool; low : Expr.t; chunk : Chunk.t } +[@@deriving show, yojson] + +type err = + | UseAfterFree + | BufferOverrun + | InsufficientPermission of { required : Perm.t; actual : Perm.t } + | InvalidAlignment of { alignment : int; offset : Expr.t } + | MissingResource of missingResourceType + | Unhandled of string + | WrongMemVal + | MemoryNotFreed + | LoadingPoison +[@@deriving yojson] + +val pp_err : err Fmt.t +val err_equal : err -> err -> bool + +type 'a or_error = ('a, err) Result.t +type 'a d_or_error = ('a, err) Delayed_result.t + +module Range : sig + type t = Expr.t * Expr.t + + val of_low_chunk_and_size : Expr.t -> Chunk.t -> Expr.t -> t +end + +type t [@@deriving yojson] + +val pp : t Fmt.t +val pp_full : t Fmt.t +val empty : t +val is_empty : t -> bool +val is_concrete : t -> bool +val lvars : t -> SS.t +val alocs : t -> SS.t +val load_bounds : t -> Range.t or_error +val cons_bounds : t -> (Range.t option * t) or_error +val prod_bounds : t -> Range.t -> t or_error + +val cons_single : + t -> Expr.t -> Chunk.t -> (SVal.t * Perm.t option * t) d_or_error + +val prod_single : t -> Expr.t -> Chunk.t -> SVal.t -> Perm.t -> t d_or_error + +val get_array : + t -> Expr.t -> Expr.t -> Chunk.t -> (SVArray.t * Perm.t option * t) d_or_error + +val cons_array : + t -> Expr.t -> Expr.t -> Chunk.t -> (SVArray.t * Perm.t option * t) d_or_error + +val prod_array : + t -> Expr.t -> Expr.t -> Chunk.t -> SVArray.t -> Perm.t -> t d_or_error + +val instantiate : Expr.t -> Expr.t -> t +val cons_hole : t -> Expr.t -> Expr.t -> (t * Perm.t option) d_or_error +val prod_hole : t -> Expr.t -> Expr.t -> Perm.t -> t d_or_error +val cons_zeros : t -> Expr.t -> Expr.t -> (t * Perm.t option) d_or_error +val prod_zeros : t -> Expr.t -> Expr.t -> Perm.t -> t d_or_error +val alloc : Expr.t -> Expr.t -> t +val store : t -> Chunk.t -> Expr.t -> SVal.t -> t d_or_error +val poison : t -> Expr.t -> Expr.t -> t d_or_error +val zero_init : t -> Expr.t -> Expr.t -> t d_or_error +val load : t -> Chunk.t -> Expr.t -> (SVal.t * t) d_or_error +val is_exclusively_owned : t -> Expr.t -> Expr.t -> bool Delayed.t +val drop_perm : t -> Expr.t -> Expr.t -> Perm.t -> t d_or_error +val get_perm_at : t -> Expr.t -> Perm.t option d_or_error +val weak_valid_pointer : t -> Expr.t -> bool d_or_error + +(** [move dst_tree dst_ofs src_tree src_ofs size] moves [size] bytes from + [src_tree] at [src_ofs] into [dst_tree] at [dst_ofs] and returns the new + [dst_tree] after modification *) +val move : t -> Expr.t -> t -> Expr.t -> Expr.t -> t d_or_error + +val assertions : t -> (LActions.ga * Expr.t list * Expr.t list) list +val assertions_others : t -> Asrt.atom list + +val substitution : + le_subst:(Expr.t -> Expr.t) -> + sval_subst:(SVal.t -> SVal.t) -> + svarr_subst:(SVArray.t -> SVArray.t) -> + t -> + t + +val merge : old_tree:t -> new_tree:t -> t d_or_error + +module Lift : sig + open Gillian.Debugger.Utils + + val get_variable : + make_node: + (name:string -> + value:string -> + ?children:Variable.t list -> + unit -> + Variable.t) -> + loc:string -> + t -> + Variable.t +end diff --git a/Gillian-LLVM/lib/llvm_memory_model/SVal.ml b/Gillian-LLVM/lib/llvm_memory_model/SVal.ml new file mode 100644 index 000000000..5141c8678 --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/SVal.ml @@ -0,0 +1,525 @@ +open Gil_syntax +open Monadic +open Delayed.Syntax +module DO = Delayed_option +module DR = Delayed_result + +module SVal = struct + (* A symbolic value is just a value with its chunk, so we know how to interpret it. *) + type t = { value : Expr.t; chunk : Chunk.t } [@@deriving yojson] + + let leak_chunk t = t.chunk + let make ~chunk ~value = { value; chunk } + let alocs v = Expr.alocs v.value + let lvars v = Expr.lvars v.value + let substitution ~le_subst v = { v with value = le_subst v.value } + let leak t = (t.chunk, t.value) + let is_concrete v = Expr.is_concrete v.value + + let vanish_or_fail_on_none f e fail_string = + match e with + | Some e -> Delayed.return (f e) + | None -> + if !Gillian.Utils.Config.under_approximation then Delayed.vanish () + else failwith fail_string + + let create_sval e = + let open Delayed.Syntax in + let* runtimetype = LLVMRuntimeTypes.type_of_expr e in + vanish_or_fail_on_none + (fun runtimetype -> + make ~chunk:(LLVMRuntimeTypes.type_to_chunk runtimetype) ~value:e) + runtimetype + (Format.asprintf "Expression is not a valid symbolic value: %a" Expr.pp e) + + let reduce v = + let open Delayed.Syntax in + let+ value = Delayed.reduce v.value in + { v with value } + + let unsign_int ~bit_size (e : Expr.t) = + let open Expr.Infix in + if%sat Expr.zero_i <= e then Delayed.return e + else + let two_power_size = Z.(one lsl bit_size) in + let open Expr.Infix in + Delayed.return (e + Expr.int_z two_power_size) + + let sign_int ~bit_size (e : Expr.t) = + let open Expr.Infix in + let two_power_size = Z.(one lsl bit_size) in + let imax = Expr.int_z Z.((two_power_size asr 1) - one) in + if%sat e <= imax then Delayed.return e + else + let open Expr.Infix in + Delayed.return (e - Expr.int_z two_power_size) + + let syntactic_equal a b = + Chunk.equal a.chunk b.chunk && Expr.equal a.value b.value + + let sure_is_zero { chunk; value } = + if Chunk.is_int chunk then + match value with + | Expr.Lit (Int z) -> Z.equal z Z.zero + | _ -> false + else + match value with + | Lit (Num 0.) -> true + | _ -> false + + let pp ft t = Fmt.pf ft "(%a : %s)" Expr.pp t.value (Chunk.to_string t.chunk) + + let to_gil_expr ~chunk t = + if Chunk.equal chunk t.chunk then + let type_expr e1 ty = + let open Expr.Infix in + Expr.BinOp (Expr.typeof e1, Equal, Expr.type_ ty) + in + let* learned, _ = + let act_value = Expr.list_nth t.value 1 in + match chunk with + | IntegerChunk w -> + let learned = [ type_expr act_value (Type.BvType w) ] in + Delayed.return (learned, LLVMRuntimeTypes.Int w) + | IntegerOrPtrChunk -> + let* rtype = LLVMRuntimeTypes.type_of_expr t.value in + vanish_or_fail_on_none + (fun runtimetype -> + let learned = + [ + type_expr act_value + (LLVMRuntimeTypes.rtype_to_gil_type runtimetype); + ] + in + (learned, runtimetype)) + rtype + (Format.asprintf "Expression is not a valid symbolic value: %a" + Expr.pp t.value) + | F32 -> + let learned = [ type_expr act_value Type.NumberType ] in + Delayed.return (learned, LLVMRuntimeTypes.F32) + | F64 -> + let learned = [ type_expr act_value Type.NumberType ] in + Delayed.return (learned, LLVMRuntimeTypes.F64) + in + Delayed.return ~learned t.value + else + Fmt.failwith "to_gil_expr: chunk mismatch: %s vs %s" + (Chunk.to_string chunk) (Chunk.to_string t.chunk) + + let zero_of_chunk (chunk : Chunk.t) = + let make value = make ~chunk ~value in + match chunk with + | IntegerChunk w -> make (Expr.zero_bv w) + | IntegerOrPtrChunk -> make (Expr.zero_bv (Llvmconfig.ptr_width ())) + | F32 -> make (Lit (Num 0.)) + | F64 -> make (Lit (Num 0.)) + + let any_of_chunk_reified (chunk : Chunk.t) : + (Expr.t * (string * Type.t) list) list = + let types = LLVMRuntimeTypes.chunk_to_type chunk in + let make_branch (ty : LLVMRuntimeTypes.t) = + let lvar = LVar.alloc () in + let learned_types = [ (lvar, LLVMRuntimeTypes.rtype_to_gil_type ty) ] in + let expr = + Expr.list + [ Expr.string (LLVMRuntimeTypes.type_to_string ty); Expr.LVar lvar ] + in + (expr, learned_types) + in + List.map make_branch types + + let any_of_chunk (chunk : Chunk.t) : t Delayed.t = + let make value = make ~chunk ~value in + let branches = + any_of_chunk_reified chunk + |> List.map (fun (exprs, learned_types) -> + let learned = [] in + Delayed.return ~learned_types ~learned (make exprs)) + in + Delayed.branches branches + + let reencode ~(chunk : Chunk.t) (v : t) = + let open Delayed.Syntax in + match (Chunk.to_components v.chunk, Chunk.to_components chunk) with + | Ptr, Ptr -> Delayed.return v + | Ptr, Float _ | Float _, Ptr -> + failwith "Trying to convert between ptr and float, unhandled" + | Int { bit_width = w }, Ptr | Ptr, Int { bit_width = w } -> + if Int.equal w (Llvmconfig.ptr_width ()) then ( + Logging.normal (fun m -> + m "Warning: over-approximating ptr to int type punning"); + any_of_chunk chunk) + else failwith "Trying to convert between non pointer sized int and Ptr" + | Int _, Float _ | Float _, Int _ -> + if sure_is_zero v then Delayed.return (zero_of_chunk chunk) + else + let () = + Logging.normal (fun m -> + m "Warning: over-approximating float-int type punning") + in + any_of_chunk chunk + | Int { bit_width = size_from }, Int { bit_width = size_to } -> + if size_from != size_to then + failwith "Error: sval reencode size mismatch, shouldn't happen" + else Delayed.return v + | Float { bit_width = size_from }, Float { bit_width = size_to } -> + if size_from != size_to then + failwith "Error: sval float reencode size mismatch, shouldn't happen"; + Delayed.return v + + (** Returns the value represented as an array of small-endian bytes *) + let to_raw_bytes_se (sval : t) : Expr.t list Delayed.t = + if not (Chunk.is_int sval.chunk) then + Fmt.failwith "Unhandled: byte_array of float value"; + let size = Chunk.size sval.chunk in + (* We can't just Seq.init, because it would recreate a LVar every time *) + let array = List.init size (fun _ -> LVar.alloc ()) in + let learned_types = List.map (fun lvar -> (lvar, Type.BvType 8)) array in + let exprs = List.map (fun lvar -> Expr.LVar lvar) array in + let learned = + List.init size (fun i -> + let target_lvar = List.nth exprs i in + let lb = i * 8 in + let ub = (i + 1) * 8 in + let extracted = + Expr.BVExprIntrinsic + ( BVOps.BVExtract, + [ + Expr.Literal lb; + Expr.Literal ub; + Expr.BvExpr (sval.value, size * 8); + ], + Some 8 ) + in + Expr.BinOp (target_lvar, Equal, extracted)) + in + let result = + match !Llvmconfig.endianness with + | `LittleEndian -> exprs + | `BigEndian -> List.rev exprs + in + Delayed.return ~learned_types ~learned result + + (** Takes an array of small-endian bytes and builds a value *) + let of_raw_bytes_se ~chunk (bytes : Expr.t list) : t Delayed.t = + let open Delayed.Syntax in + if not (Chunk.is_int chunk) then + Fmt.failwith "Unhandled: byte_array of float value"; + let bytes = + match !Llvmconfig.endianness with + | `LittleEndian -> bytes + | `BigEndian -> List.rev bytes + in + let expr = Expr.bv_concat bytes in + make ~chunk ~value:expr |> Delayed.return + + let assertions_others t = + let open Expr.Infix in + Option.fold (Chunk.type_of t.chunk) ~none:[] ~some:(fun x -> + List.fold_left + (fun curr ty -> + Expr.BinOp (curr, BinOp.Or, Expr.typeof t.value == Expr.type_ ty)) + Expr.true_ x + |> fun x -> [ Asrt.Pure x ]) +end + +module SVArray = struct + type t = { values : Expr.t; chunk : Chunk.t } [@@deriving yojson] + + let is_concrete v = Expr.is_concrete v.values + let make ~chunk ~values = { values; chunk } + let alocs v = Expr.alocs v.values + let lvars v = Expr.lvars v.values + let leak t = (t.chunk, t.values) + let leak_chunk t = t.chunk + + let reduce t = + let open Delayed.Syntax in + let+ values = Delayed.reduce t.values in + { t with values } + + let pp ft t = + Fmt.pf ft "(%a: [%s])" Expr.pp t.values (Chunk.to_string t.chunk) + + (* To be sound, this should be only ever called + if the size given is guaranteed to be + the size of the array *) + let concretize_with_size ~size ({ chunk; values } : t) = + List.init size (fun i -> + let value = Expr.list_nth values i in + SVal.make ~chunk ~value) + + let sure_is_all_zeros { chunk; values } = + if Chunk.is_int chunk then + match values with + | Expr.EList l -> + List.for_all + (function + | Expr.Lit (Int z) -> Z.equal z Z.zero + | _ -> false) + l + | Expr.Lit (LList l) -> + List.for_all + (function + | Literal.Int z -> Z.equal z Z.zero + | _ -> false) + l + | _ -> false + else + match values with + | Expr.EList l -> + List.for_all + (function + | Expr.Lit (Num 0.) -> true + | _ -> false) + l + | Expr.Lit (LList l) -> + List.for_all + (function + | Literal.Num 0. -> true + | _ -> false) + l + | _ -> false + + let syntactic_equal arr_a arr_b = + Chunk.equal arr_a.chunk arr_b.chunk && Expr.equal arr_a.values arr_b.values + + let concat_same_chunk left right = + if Chunk.equal left.chunk right.chunk then + Some + { chunk = left.chunk; values = Expr.list_cat left.values right.values } + else None + + let singleton SVal.{ chunk; value } = { chunk; values = Expr.EList [ value ] } + + (** This assumes chunks are properly respected outside of the call of this function *) + let cons_same_chunk (el : SVal.t) (arr : t) = + concat_same_chunk (singleton el) arr + + let append_same_chunk arr el = concat_same_chunk arr (singleton el) + + let of_two_svals_same_chunk (first : SVal.t) (second : SVal.t) = + if Chunk.equal first.chunk second.chunk then + Some + { + chunk = first.chunk; + values = Expr.EList [ first.value; second.value ]; + } + else None + + let make_zeros ~chunk ~size : t Delayed.t = + let return ?learned ?learned_types values = + Delayed.return ?learned ?learned_types { chunk; values } + in + let size = Engine.Reduction.reduce_lexpr size in + match size with + | Lit (Int n) when Z.(n <= Z.of_int 512) -> + (* We chose an arbitrary size limit, because we don't want to allocate + a huge list of data for specs like (p, 2^32). + If it gets bigger, the alternative is still sound. *) + Logging.verbose (fun fmt -> fmt "Zeros pf: Concrete: %a" Expr.pp size); + let values = + Expr.EList (List.init (Z.to_int n) (fun _ -> Expr.zero_i)) + in + return values + | _ -> + let open Expr.Infix in + Logging.verbose (fun fmt -> + fmt "Zeros pf: not as concrete: %a" Expr.pp size); + let values_var = LVar.alloc () in + let values = Expr.LVar values_var in + let i = LVar.alloc () in + let i_e = Expr.LVar i in + let zero = Expr.zero_i in + let learned_types = [ (values_var, Type.ListType) ] in + let correct_length = Expr.list_length values == size in + let all_zero = + forall + [ (i, Some IntType) ] + ((zero <= i_e && i_e < size) + ==> (Expr.list_nth_e values i_e == zero)) + in + return ~learned:[ correct_length; all_zero ] ~learned_types values + + let byte_array_of_sval (sval : SVal.t) : t Delayed.t = + let open Delayed.Syntax in + let+ result = SVal.to_raw_bytes_se sval in + { chunk = sval.chunk; values = Expr.EList result } + + let decode_sval_into ~chunk (sval : SVal.t) = + let open Delayed.Syntax in + match (Chunk.to_components sval.chunk, Chunk.to_components chunk) with + | Ptr, Ptr -> Delayed.return (singleton sval) + | Ptr, Float _ | Float _, Ptr -> + failwith "Trying to convert between ptr and float, unhandled" + | Int { bit_width = from }, Ptr | Ptr, Int { bit_width = from } -> + if Int.equal from (Llvmconfig.ptr_width ()) then + let () = + Logging.normal (fun m -> + m "Warning: over-approximating ptr to int type punning") + in + let+ sval = SVal.any_of_chunk chunk in + singleton sval + else failwith "Trying to convert between non pointer sized int and Ptr" + | Float { bit_width = from }, Float { bit_width = into } -> + if from < into then + failwith + "Error: decomposing one smaller float into a list of bigger ones" + else if from == into then Delayed.return (singleton sval) + else + (* We're in the case where we're decoding one F64 into 2 F32s. + Gillian can't really handle that, so we're over-approximating here. *) + let () = + assert (Chunk.equal chunk F32 && Chunk.equal sval.chunk F64) + in + let first = LVar.alloc () in + let second = LVar.alloc () in + let learned_types = + [ (first, Type.NumberType); (second, Type.NumberType) ] + in + let values = Expr.EList [ Expr.LVar first; Expr.LVar second ] in + let array = make ~chunk ~values in + Delayed.return ~learned_types array + | Float { bit_width = from }, Int { bit_width = into; _ } + | Int { bit_width = from; _ }, Float { bit_width = into } -> + (* Float-int type punning. I can't possibly model that, I'm going to over-approximate. *) + if from < into then + failwith + "Error: type-punning one smaller float/ints into a list of bigger \ + ones" + else if from mod into != 0 then + failwith "decomposition size doesn't match (float/int punning)" + else + let amount = from / into in + let+ values = + Seq.fold_left + (fun acc _ -> + let* acc = acc in + let+ sval = SVal.any_of_chunk chunk in + sval.value :: acc) + (Delayed.return []) (Seq.init amount Fun.id) + in + make ~chunk ~values:(Expr.EList values) + | Int { bit_width = size_from }, Int { bit_width = size_into } -> + if size_from < size_into then + failwith + "Trying to build an array of elements smaller than the total size \ + of the array" + else + let num_elems = size_from / size_into in + let each_elem = + List.init num_elems (fun i -> + Expr.bv_extract i (i + size_into) sval.value) + in + make ~chunk ~values:(Expr.list each_elem) |> Delayed.return + + let decode_as_sval ~chunk arr = + let get_exactly_one arr = + SVal.{ chunk; value = Expr.list_nth arr.values 0 } + in + let open Delayed.Syntax in + match (Chunk.to_components arr.chunk, Chunk.to_components chunk) with + | Ptr, Ptr -> Delayed.return (get_exactly_one arr) + | Ptr, Float _ | Float _, Ptr -> + failwith "Trying to convert between ptr and float, unhandled" + | Int { bit_width = from }, Ptr | Ptr, Int { bit_width = from } -> + if Int.equal from (Llvmconfig.ptr_width ()) then + let () = + Logging.normal (fun m -> + m "Warning: over-approximating ptr to int type punning") + in + SVal.any_of_chunk chunk + else + failwith + "Trying to convert between non pointer sized int we dont currently \ + support this and Ptr" + | Int _, Float _ | Float _, Int _ -> + if sure_is_all_zeros arr then Delayed.return (SVal.zero_of_chunk chunk) + else + let () = + Logging.normal (fun m -> + m "Warning: over-approximating float-int type punning (array)") + in + SVal.any_of_chunk chunk + | Int { bit_width = size_from }, Int { bit_width = size_to } -> + if size_from == size_to then + let selem = get_exactly_one arr in + Delayed.return + SVal. + { + chunk; + value = Expr.bv_extract_between_sz size_from size_to selem.value; + } + else + (* Same size conversion so just concat everything *) + let ln = size_to / size_from in + let bts = + List.init ln (fun i -> + let elem = Expr.list_nth arr.values i in + elem) + in + let built = Expr.bv_concat bts in + Delayed.return SVal.{ chunk; value = built } + | Float { bit_width = size_from }, Float { bit_width = size_to } -> + if size_from > size_to then + failwith + "Error: reencoding an array of a float type to a single element of \ + smaller type"; + if size_from < size_to then + failwith "unhandled: reencoding 2 F32 as 1 F64"; + Delayed.return (get_exactly_one arr) + + let reencode ~chunk arr : t Delayed.t = + if Chunk.equal chunk arr.chunk then Delayed.return arr + else failwith "unimplemented: decoding an array as another one" + + let array_sub ~arr ~start ~size : t = + { arr with values = Expr.list_sub ~lst:arr.values ~start ~size } + + let split_at_offset ~at arr : t * t = + let size_right = + let open Expr.Infix in + Expr.list_length arr.values - at + in + ( array_sub ~arr ~start:Expr.zero_i ~size:at, + array_sub ~arr ~start:at ~size:size_right ) + + let split_at_byte ~at arr : (t * t) Delayed.t = + let chunk_size = Expr.int (Chunk.size arr.chunk) in + let can_keep_chunk = + let open Expr.Infix in + Expr.imod at chunk_size == Expr.zero_i + in + if%ent can_keep_chunk then + Delayed.return (split_at_offset ~at:Expr.Infix.(at / chunk_size) arr) + else failwith "Unhandled: split_at_byte that doesn't preserve chunk" + + (* let split_array_in ~size ~amount arr = + let i f = Expr.int f in + List.init amount (fun k -> + let values = + Expr.list_sub ~lst:e ~start:(i (k * size)) ~size:(i size) + in + SVArr.Arr values) *) + + (* It's unclear what I'm going to do with + this. I don't know how to ensure that size is always the right hing.*) + + let assertions_others ~(low : Expr.t) ~(high : Expr.t) (arr : t) = + let chunk_size = Chunk.size arr.chunk |> Expr.int in + let open Expr.Infix in + let size = (high - low) / chunk_size in + [ + Asrt.Pure (Expr.list_length arr.values == size); + Asrt.Pure (Expr.typeof arr.values == Expr.type_ Type.ListType); + ] + + let to_gil_expr ~size:_ ~chunk t = + if Chunk.equal t.chunk chunk then t.values + else + Fmt.failwith "Chunk mismatch: %s vs %s" (Chunk.to_string t.chunk) + (Chunk.to_string chunk) + + let subst ~le_subst t = { t with values = le_subst t.values } +end diff --git a/Gillian-LLVM/lib/llvm_memory_model/SVal.mli b/Gillian-LLVM/lib/llvm_memory_model/SVal.mli new file mode 100644 index 000000000..eb71c1d15 --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/SVal.mli @@ -0,0 +1,84 @@ +open Gillian.Utils.Prelude +open Gil_syntax +open Monadic + +module SVal : sig + type t [@@deriving yojson] + + val make : chunk:Chunk.t -> value:Gil_syntax.Expr.t -> t + val create_sval : Gil_syntax.Expr.t -> t Delayed.t + val is_concrete : t -> bool + val pp : Format.formatter -> t -> unit + val alocs : t -> SS.t + val lvars : t -> SS.t + val sure_is_zero : t -> bool + val substitution : le_subst:(Expr.t -> Expr.t) -> t -> t + val syntactic_equal : t -> t -> bool + val reencode : chunk:Chunk.t -> t -> t Monadic.Delayed.t + val to_gil_expr : chunk:Chunk.t -> t -> Gil_syntax.Expr.t Delayed.t + val reduce : t -> t Monadic.Delayed.t + val zero_of_chunk : Chunk.t -> t + val any_of_chunk : Chunk.t -> t Monadic.Delayed.t + val any_of_chunk_reified : Chunk.t -> (Expr.t * (string * Type.t) list) list + val leak : t -> Chunk.t * Expr.t + val leak_chunk : t -> Chunk.t + val assertions_others : t -> Asrt.atom list +end + +module SVArray : sig + type t [@@deriving yojson] + + val make : chunk:Chunk.t -> values:Expr.t -> t + val is_concrete : t -> bool + val alocs : t -> SS.t + val lvars : t -> SS.t + val reduce : t -> t Monadic.Delayed.t + val pp : Format.formatter -> t -> unit + val sure_is_all_zeros : t -> bool + val syntactic_equal : t -> t -> bool + val leak : t -> Chunk.t * Expr.t + val leak_chunk : t -> Chunk.t + + val make_zeros : + chunk:Chunk.t -> size:Gil_syntax.Expr.t -> t Monadic.Delayed.t + + (** Decodes one sval into an array. For example one U32 into two U16s *) + val decode_sval_into : chunk:Chunk.t -> SVal.t -> t Monadic.Delayed.t + + val decode_as_sval : chunk:Chunk.t -> t -> SVal.t Monadic.Delayed.t + val byte_array_of_sval : SVal.t -> t Monadic.Delayed.t + val singleton : SVal.t -> t + + (** Reencodes an array with another chunk. + Should really be avoided if possible. *) + val reencode : chunk:Chunk.t -> t -> t Monadic.Delayed.t + + val array_sub : + arr:t -> start:Gil_syntax.Expr.t -> size:Gil_syntax.Expr.t -> t + + (** Splits at an offset in the array. + For example, for an array of 4 u32 numbers, spliting at 2 gives 2 arrays of 2 u32s *) + val split_at_offset : at:Expr.t -> t -> t * t + + (** Splits at a byte in the array. + For example, spliting an array containing 1 value of type u32 at byte 2, + gives 2 arrays of u8s. *) + val split_at_byte : at:Expr.t -> t -> (t * t) Monadic.Delayed.t + + (** Creates an array of two sval if they have the same chunk, + otherwise, returns None *) + val of_two_svals_same_chunk : SVal.t -> SVal.t -> t option + + (** Concatenates two arrays if they have the same chunk, + otherwise returns None *) + val concat_same_chunk : t -> t -> t option + + (** [cons_same_chunk el arr] is [concat_same_chunk (singleting el) arr] *) + val cons_same_chunk : SVal.t -> t -> t option + + (* [append_same_chunk arr el] is [concat_same_chunk arr (singleting el)] *) + val append_same_chunk : t -> SVal.t -> t option + val to_gil_expr : size:Expr.t -> chunk:Chunk.t -> t -> Gil_syntax.Expr.t + val assertions_others : low:Expr.t -> high:Expr.t -> t -> Asrt.atom list + val subst : le_subst:(Gil_syntax.Expr.t -> Gil_syntax.Expr.t) -> t -> t +end diff --git a/Gillian-LLVM/lib/llvm_memory_model/archi.ml b/Gillian-LLVM/lib/llvm_memory_model/archi.ml new file mode 100644 index 000000000..75560255a --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/archi.ml @@ -0,0 +1,5 @@ +type t = Arch64 | Arch32 + +let a64 = [ Arch64 ] +let a32 = [ Arch32 ] +let any_arch = [ Arch32; Arch64 ] diff --git a/Gillian-LLVM/lib/llvm_memory_model/constants.ml b/Gillian-LLVM/lib/llvm_memory_model/constants.ml new file mode 100644 index 000000000..8a3c0e276 --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/constants.ml @@ -0,0 +1,134 @@ +module Internal_functions = struct + let malloc = "i__malloc" + let calloc = "i__calloc" + let memmove = "i__memmove" + let memcpy = "i__memcpy" + let memset = "i__memset" + let memcmp = "i__memcmp" + let store_zeros = "i__store_zeros" + let loadv = "i__loadv" + let storev = "i__storev" + let get_function_name = "i__get_function_name" + let ef_memcpy = "i__ef_memcpy" + let val_of_bool = "i__value_of_bool" + let bool_of_val = "i__bool_of_value" + let glob_set_fun = "i__glob_set_fun" + + module Rust = struct + let rust_alloc = "i__rust_alloc" + let rust_alloc_zeroed = "i__rust_alloc_zeroed" + let rust_dealloc = "i__rust_dealloc" + let rust_realloc = "i__rust_realloc" + end + + let hook = function + | "malloc" -> Some malloc + | "calloc" -> Some calloc + | "memmove" -> Some memmove + | "memcpy" -> Some memcpy + | "memset" -> Some memset + | "memcmp" -> Some memcmp + | "__rust_alloc" -> Some Rust.rust_alloc + | "__rust_alloc_zeroed" -> Some Rust.rust_alloc_zeroed + | "__rust_dealloc" -> Some Rust.rust_dealloc + | "__rust_realloc" -> Some Rust.rust_realloc + | _ -> None + + let names = + [ + malloc; + calloc; + memmove; + memcpy; + memset; + memcmp; + store_zeros; + loadv; + storev; + get_function_name; + ef_memcpy; + val_of_bool; + bool_of_val; + glob_set_fun; + Rust.rust_alloc; + Rust.rust_alloc_zeroed; + Rust.rust_dealloc; + Rust.rust_realloc; + ] +end + +module CBMC_names = struct + let initialize = "__CPROVER_initialize" + let start = "__CPROVER__start" +end + +module Gillian_C2_names = struct + let return_by_copy_name = "i___ret" + let ret_label = "ret" +end + +module Unop_functions = struct + let object_size = "i__unop_object_size" +end + +module Binop_functions = struct + let eq_maybe_ptr = "i__binop_equal_maybe_ptr" + let neq_maybe_ptr = "i__binop_notequal_maybe_ptr" + let gt_maybe_ptr = "i__binop_greaterthan_maybe_ptr" + let lt_maybe_ptr = "i__binop_lowerthan_maybe_ptr" + let geq_maybe_ptr = "i__binop_greatereq_maybe_ptr" + let leq_maybe_ptr = "i__binop_lesseq_maybe_ptr" + let add_maybe_ptr = "i__binop_add_maybe_ptr" + let sub_maybe_ptr = "i__binop_sub_maybe_ptr" + let mod_maybe_ptr = "i__binop_mod_maybe_ptr" + let overflow_plus_maybe_ptr = "i__binop_overflow_plus_maybe_ptr" +end + +module Cast_functions = struct + let unsign_int_same_size = "i__cast_unsign_int_same_size" + let sign_int_same_size = "i__cast_sign_int_same_size" +end + +module Internal_Predicates = struct + let _prefix = "i__" + let is_int = _prefix ^ "is_int" + let is_ptr_to_0 = _prefix ^ "is_ptr_to_0" + let is_ptr = _prefix ^ "is_ptr" + let is_ptr_to_0_opt = _prefix ^ "is_ptr_to_0_opt" + let is_ptr_opt = _prefix ^ "is_ptr_opt" + let is_ptr_to_int_opt = _prefix ^ "is_ptr_to_int_opt" + let is_ptr_to_float_opt = _prefix ^ "is_ptr_to_float_opt" + let is_ptr_to_long_opt = _prefix ^ "is_ptr_to_long_opt" + let is_ptr_to_single_opt = _prefix ^ "is_ptr_to_single_opt" + let is_long = _prefix ^ "is_long" + let is_single = _prefix ^ "is_single" + let is_float = _prefix ^ "is_float" + + (** Internal value getters *) + let ptr_to_0_get = _prefix ^ "ptr_to_0" + + let ptr_get = _prefix ^ "ptr" + let int_get = _prefix ^ "int" + let single_get = _prefix ^ "single" + let long_get = _prefix ^ "long" + let float_get = _prefix ^ "float" + + (** global_env *) + let global_env = _prefix ^ "global_env" + + let glob_fun = _prefix ^ "glob_fun" + let glob_var_unallocated = _prefix ^ "glob_var_unallocated" + let glob_var_unallocated_loc = _prefix ^ "glob_var_unallocated_loc" + let fun_ptr = _prefix ^ "function_ptr" + + (* Arrays *) + + let malloced = _prefix ^ "malloced" + let zeros_ptr_size = _prefix ^ "zeros_ptr_size" + let undefs_ptr_size = _prefix ^ "undefs_ptr_size" + let array_ptr = _prefix ^ "array_ptr" + + (* Pointer arithmetic *) + + let ptr_add = _prefix ^ "ptr_add" +end diff --git a/Gillian-LLVM/lib/llvm_memory_model/dune b/Gillian-LLVM/lib/llvm_memory_model/dune new file mode 100644 index 000000000..c2c6cfc22 --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/dune @@ -0,0 +1,11 @@ +(library + (name llvm_memory_model) + (libraries + gillian + gillian.ppx_sat.runtime + ppx_deriving_yojson.runtime + ppx_deriving.runtime + printbox-text ; we want to get rid of printbox as a dependency + states) + (preprocess + (pps gillian.ppx_sat ppx_deriving_yojson ppx_deriving.std))) diff --git a/Gillian-LLVM/lib/llvm_memory_model/interface.ml b/Gillian-LLVM/lib/llvm_memory_model/interface.ml new file mode 100644 index 000000000..abb38146b --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/interface.ml @@ -0,0 +1,131 @@ +(* First, type definitions *) + +type mem_ac = + | Alloc + | DropPerm + | GetCurPerm + | WeakValidPointer + | Store + | Load + | Free + | Move + | Poison + | ZeroInit + | GetArray + | GetBounds + +type genv_ac = GetSymbol | SetSymbol | GetDef | SetDef +type ac = AGEnv of genv_ac | AMem of mem_ac +type mem_ga = Single | Array | Hole | Zeros | Bounds | Freed +type genv_ga = Symbol | Definition +type ga = GMem of mem_ga | GGenv of genv_ga + +(* Some things about the semantics of these Actions *) + +let is_overlapping_asrt = function + | GGenv _ -> true + | _ -> false + +(* Then serialization and deserialization functions *) + +let mem_prefix = "mem" +let genv_prefix = "genv" + +let str_mem_ac = function + | Alloc -> "alloc" + | DropPerm -> "dropperm" + | WeakValidPointer -> "weakvalidpointer" + | GetCurPerm -> "getperm" + | Store -> "store" + | Load -> "load" + | Move -> "move" + | Free -> "free" + | Poison -> "poison" + | ZeroInit -> "zeroinit" + | GetArray -> "getArray" + | GetBounds -> "getBounds" + +let mem_ac_from_str = function + | "alloc" -> Alloc + | "dropperm" -> DropPerm + | "weakvalidpointer" -> WeakValidPointer + | "getcurperm" -> GetCurPerm + | "store" -> Store + | "load" -> Load + | "free" -> Free + | "move" -> Move + | "poison" -> Poison + | "zeroinit" -> ZeroInit + | "getArray" -> GetArray + | "getBounds" -> GetBounds + | s -> failwith ("Unknown Memory Action : " ^ s) + +let str_genv_ac = function + | GetSymbol -> "getsymbol" + | SetSymbol -> "setsymbol" + | GetDef -> "getdef" + | SetDef -> "setdef" + +let genv_ac_from_str = function + | "getsymbol" -> GetSymbol + | "setsymbol" -> SetSymbol + | "getdef" -> GetDef + | "setdef" -> SetDef + | s -> failwith ("Unknown Global Env Action : " ^ s) + +let separator_char = '_' +let separator_string = String.make 1 separator_char + +let str_ac = function + | AMem mem_ac -> mem_prefix ^ separator_string ^ str_mem_ac mem_ac + | AGEnv genv_ac -> genv_prefix ^ separator_string ^ str_genv_ac genv_ac + +let ac_from_str str = + match String.split_on_char separator_char str with + | [ pref; ac ] when String.equal pref mem_prefix -> AMem (mem_ac_from_str ac) + | [ pref; ac ] when String.equal pref genv_prefix -> + AGEnv (genv_ac_from_str ac) + | _ -> failwith ("Unknown action : " ^ str) + +let str_mem_ga = function + | Single -> "single" + | Array -> "array" + | Hole -> "hole" + | Zeros -> "zeros" + | Bounds -> "bounds" + | Freed -> "freed" + +let str_genv_ga = function + | Definition -> "def" + | Symbol -> "symb" + +let mem_ga_from_str = function + | "single" -> Single + | "array" -> Array + | "bounds" -> Bounds + | "zeros" -> Zeros + | "hole" -> Hole + | "freed" -> Freed + | str -> failwith ("Unknown memory assertion : " ^ str) + +let genv_ga_from_str = function + | "symb" -> Symbol + | "def" -> Definition + | str -> failwith ("Unknown global assertion : " ^ str) + +let str_ga = function + | GMem mem_ga -> mem_prefix ^ separator_string ^ str_mem_ga mem_ga + | GGenv genv_ga -> genv_prefix ^ separator_string ^ str_genv_ga genv_ga + +let ga_from_str str = + match String.split_on_char separator_char str with + | [ pref; ga ] when String.equal pref mem_prefix -> GMem (mem_ga_from_str ga) + | [ pref; ga ] when String.equal pref genv_prefix -> + GGenv (genv_ga_from_str ga) + | _ -> failwith ("Unknown GA : " ^ str) + +let ga_to_action_str action str = ga_from_str str |> action |> str_ac + +(** Additional stuff *) + +let is_overlapping_asrt_str str = ga_from_str str |> is_overlapping_asrt diff --git a/Gillian-LLVM/lib/llvm_memory_model/interface.mli b/Gillian-LLVM/lib/llvm_memory_model/interface.mli new file mode 100644 index 000000000..952be1018 --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/interface.mli @@ -0,0 +1,42 @@ +(** {3 Type definitions} *) + +type mem_ac = + | Alloc + | DropPerm + | GetCurPerm + | WeakValidPointer + | Store + | Load + | Free + | Move + | Poison + | ZeroInit + | GetArray + | GetBounds + +type genv_ac = GetSymbol | SetSymbol | GetDef | SetDef + +type ac = + | AGEnv of genv_ac (** Actions related to the memory *) + | AMem of mem_ac (** Actions related to the global environment *) + +type mem_ga = Single | Array | Hole | Zeros | Bounds | Freed +type genv_ga = Symbol | Definition +type ga = GMem of mem_ga | GGenv of genv_ga + +(** {3 Serialization of actions} *) + +(** Serializes an action into a string *) +val str_ac : ac -> string + +(** Deserializes a string into an action *) +val ac_from_str : string -> ac + +(** {3 Global assertion serialization } *) + +val str_ga : ga -> string +val ga_from_str : string -> ga + +(** {3 Gillian-related things} *) + +val is_overlapping_asrt_str : string -> bool diff --git a/Gillian-LLVM/lib/llvm_memory_model/llvmconfig.ml b/Gillian-LLVM/lib/llvm_memory_model/llvmconfig.ml new file mode 100644 index 000000000..09777712c --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/llvmconfig.ml @@ -0,0 +1,21 @@ +let include_dirs : string list ref = ref [] +let source_dirs : string list ref = ref [] +let machine_model = ref Machine_model.archi64 +let kstats_file : string option ref = ref None +let harness : string option ref = ref None +let archi = ref Archi.Arch64 +let endianness : [ `LittleEndian | `BigEndian ] ref = ref `BigEndian +let hide_genv = ref false + +let ptr64 () = + match !archi with + | Arch64 -> true + | Arch32 -> false + +let ptr_width () : int = + match !archi with + | Arch64 -> 64 + | Arch32 -> 32 + +let nondet_on_missing = ref true +let print_unhandled = ref false diff --git a/Gillian-LLVM/lib/llvm_memory_model/machine_model.ml b/Gillian-LLVM/lib/llvm_memory_model/machine_model.ml new file mode 100644 index 000000000..590f5b3bf --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/machine_model.ml @@ -0,0 +1,43 @@ +type t = { + alignment : int; + bool_width : int; + char_is_unsigned : bool; + char_width : int; + double_width : int; + int_width : int; + is_big_endian : bool; + long_double_width : int; + long_int_width : int; + long_long_int_width : int; + memory_operand_size : int; + null_is_zero : bool; + pointer_width : int; + short_int_width : int; + single_width : int; + wchar_t_is_unsigned : bool; + wchar_t_width : int; + word_size : int; +} +[@@deriving eq, show { with_path = false }] + +let archi64 = + { + alignment = 1; + bool_width = 8; + char_is_unsigned = false; + char_width = 8; + double_width = 64; + int_width = 32; + is_big_endian = false; + long_double_width = 128; + long_int_width = 64; + long_long_int_width = 64; + memory_operand_size = 4; + null_is_zero = true; + pointer_width = 64; + short_int_width = 16; + single_width = 32; + wchar_t_width = 32; + word_size = 32; + wchar_t_is_unsigned = false; + } diff --git a/Gillian-LLVM/lib/llvm_memory_model/memories.ml b/Gillian-LLVM/lib/llvm_memory_model/memories.ml new file mode 100644 index 000000000..3aff2dde7 --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/memories.ml @@ -0,0 +1,24 @@ +open Gillian + +module LLVM_Base = struct + module MonadicSMemory = LLVM.MonadicSMemory_Base + module ParserAndCompiler = Gillian.ParserAndCompiler.Dummy + module ExternalSemantics = LLVM.ExternalSemantics + module InitData = LLVM.MyInitData + module MyInitData = LLVM.MyInitData +end + +module LLVM_ALoc = struct + include LLVM_Base + module MonadicSMemory = LLVM.MonadicSMemory_ALoc +end + +module LLVM_Split = struct + include LLVM_Base + module MonadicSMemory = LLVM.MonadicSMemory_Split +end + +module DefaultMem = + States.MyMonadicSMemory.Make (LLVM_ALoc.MonadicSMemory) (LLVM.MyInitData) + +module SMemory = Monadic.MonadicSMemory.Lift (DefaultMem) diff --git a/Gillian-LLVM/lib/llvm_memory_model/perm.ml b/Gillian-LLVM/lib/llvm_memory_model/perm.ml new file mode 100644 index 000000000..abebf197e --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/perm.ml @@ -0,0 +1,48 @@ +type t = Freeable | Writable | Readable | Nonempty [@@deriving yojson] + +let to_int = function + | Freeable -> 4 + | Writable -> 3 + | Readable -> 2 + | Nonempty -> 1 + +let opt_to_int = function + | None -> 0 + | Some x -> to_int x + +module Infix = struct + let ( >% ), ( <% ), ( <=% ), ( >=% ), ( =% ) = + let make op a b = op (to_int a) (to_int b) in + (make ( > ), make ( < ), make ( <= ), make ( >= ), make ( = )) + + let ( >%? ), ( <%? ), ( <=%? ), ( >=%? ), ( =%? ) = + let make op a b = op (opt_to_int a) (opt_to_int b) in + (make ( > ), make ( < ), make ( <= ), make ( >= ), make ( = )) +end + +let min pa pb = + let open Infix in + if pa <=% pb then pa else pb + +let to_string = function + | Freeable -> "Freeable" + | Writable -> "Writable" + | Readable -> "Readable" + | Nonempty -> "Nonempty" + +let pp ft t = Format.fprintf ft "%s" (to_string t) + +let opt_to_string = function + | None -> "None" + | Some p -> to_string p + +let of_string = function + | "Freeable" -> Freeable + | "Writable" -> Writable + | "Readable" -> Readable + | "Nonempty" -> Nonempty + | str -> failwith ("Unknown permission : " ^ str) + +let opt_of_string = function + | "None" -> None + | str -> Some (of_string str) diff --git a/Gillian-LLVM/lib/llvm_memory_model/utils.ml b/Gillian-LLVM/lib/llvm_memory_model/utils.ml new file mode 100644 index 000000000..362d56ab9 --- /dev/null +++ b/Gillian-LLVM/lib/llvm_memory_model/utils.ml @@ -0,0 +1,52 @@ +open States + +(* Typings *) +module type ActionAddition = ActionAdder.ActionAddition +module type FilterVals = Filter.FilterVals +module type IDs = MyUtils.IDs +module type Injection = Injector.Injection +module type NameMap = Mapper.NameMap +module type MyMonadicSMemory = MyMonadicSMemory.S +module type PMapIndex = PMap.PMapIndex +module type PMapType = PMap.PMapType +module type OpenPMapType = PMap.OpenPMapType + +type filter_mode = Filter.filter_mode +type index_mode = PMap.index_mode + +(* Helpers *) +module DummyInject = Injector.DummyInject + +module IDs : IDs = struct + let id1 = "left_" + let id2 = "right_" +end + +(* Indices *) +module LocationIndex = PMap.LocationIndex +module IntegerIndex = PMap.IntegerIndex +module StringIndex = PMap.StringIndex + +(* Leaves *) +module Agreement = Agreement +module Exclusive = Exclusive +module Fractional = Fractional + +(* Transformers *) +module ActionAdder = ActionAdder.Make +module Filter = Filter.Make +module Freeable = Freeable.Make +module Injector = Injector.Make +module Logger = Logger.Make +module Mapper = Mapper.Make +module MList = MList.Make +module Product = Product.Make +module Sum = Sum.Make + +(* PMaps *) +module ALocPMap = PMap.Make (PMap.ALocImpl) +module SplitPMap (I : PMapIndex) = PMap.Make (PMap.SplitImplSat (I)) +module OpenALocPMap = PMap.MakeOpen (PMap.ALocImpl) +module OpenSplitPMap (I : PMapIndex) = PMap.MakeOpen (PMap.SplitImplSat (I)) +module OpenPMap (I : PMapIndex) = PMap.MakeOpen (PMap.BaseImplSat (I)) +module PMap (I : PMapIndex) = PMap.Make (PMap.BaseImplSat (I)) diff --git a/Gillian-LLVM/lib/sRunner.ml b/Gillian-LLVM/lib/sRunner.ml new file mode 100644 index 000000000..8a4a88b1b --- /dev/null +++ b/Gillian-LLVM/lib/sRunner.ml @@ -0,0 +1,47 @@ +open Gillian +open Gillian.Utils +open Gil_syntax +open Llvm_memory_model.Memories +module DummyParserAndCompiler = ParserAndCompiler.Dummy + +module Outcome = + Bulk.Outcome.Make_Symbolic (SMemory) (NoopParser) + (General.External.Dummy (Gil_syntax.Annot.Basic)) + +module Suite = struct + include Bulk.Suite.ByFolder (struct + let max_depth = 1 + let cmd_name = "bulk-wpst" + let exec_mode = Gillian.Utils.Exec_mode.Symbolic + end) + + let contains_substring s1 s2 = + let re = Str.regexp_string s2 in + try + ignore (Str.search_forward re s1 0); + true + with Not_found -> false + + let filter_source s = + Filename.check_suffix s ".gil" + && not (!Gillian.Utils.Config.ci && contains_substring s "bug/") + + let beforeEach () = Generators.reset () +end + +module Expectations = struct + type matcher = Alcotest_runner.AlcotestCheckers.Make(Outcome).matcher + type outcome = Outcome.t + type category = Suite.category + type info = Suite.info + + let expectation (expect : matcher) (test : (info, string) Bulk.Test.t) outcome + = + let cat = test.category in + match cat with + | "fail" -> expect.finish_in_fail outcome + | "succeed" -> expect.finish_in_normal_mode AllOfThem outcome + | _ -> failwith "Unknown category" +end + +include Alcotest_runner.AlcotestRunner.Make (Outcome) (Suite) (Expectations) diff --git a/Gillian-LLVM/runtime/dune b/Gillian-LLVM/runtime/dune new file mode 100644 index 000000000..6a545300c --- /dev/null +++ b/Gillian-LLVM/runtime/dune @@ -0,0 +1,6 @@ +(install + (section + (site + (gillian-llvm runtime))) + (files) + (package gillian-llvm)) diff --git a/GillianCore/BulkTesting/suite.mli b/GillianCore/BulkTesting/suite.mli index 1ac3344b9..efc70f54f 100644 --- a/GillianCore/BulkTesting/suite.mli +++ b/GillianCore/BulkTesting/suite.mli @@ -42,4 +42,4 @@ module ByFolder (P : sig val max_depth : int val cmd_name : string val exec_mode : Exec_mode.t -end) : S +end) : S with type category = string diff --git a/GillianCore/GIL_Syntax/BVArg.ml b/GillianCore/GIL_Syntax/BVArg.ml new file mode 100644 index 000000000..e69de29bb diff --git a/GillianCore/GIL_Syntax/BVOps.ml b/GillianCore/GIL_Syntax/BVOps.ml new file mode 100644 index 000000000..aa7bc0261 --- /dev/null +++ b/GillianCore/GIL_Syntax/BVOps.ml @@ -0,0 +1,66 @@ +type t = TypeDef__.bvop = + | BVConcat + | BVExtract + | BVNot + | BVAnd + | BVOr + | BVNeg + | BVPlus + | BVMul + | BVUDiv + | BVUrem + | BVShl + | BVLShr + | BVXor + | BVSrem + | BVSub + | BVSignExtend + | BVZeroExtend + | BVSdiv + | BVSmod + | BVAshr + | BVUlt + | BVUleq + | BVSlt + | BVSleq + | BVUMulO + | BVSMulO + | BVNegO + | BVUAddO + | BVSAddO +[@@deriving eq, ord] + +let str (x : t) = + match x with + | BVConcat -> "bvconcat" + | BVExtract -> "bvextract" + | BVNot -> "bvnot" + | BVAnd -> "bvand" + | BVOr -> "bvor" + | BVNeg -> "bvneg" + | BVPlus -> "bvplus" + | BVMul -> "bvmul" + | BVUDiv -> "bvudiv" + | BVUrem -> "bvurem" + | BVShl -> "bvshl" + | BVLShr -> "bvlshr" + | BVXor -> "bvxor" + | BVSrem -> "bvsrem" + | BVSub -> "bvsub" + | BVSignExtend -> "bvsext" + | BVZeroExtend -> "bvzext" + | BVSdiv -> "bvsdiv" + | BVSmod -> "bvsmod" + | BVAshr -> "bvashr" + | BVUlt -> "bvult" + | BVUleq -> "bvuleq" + | BVSlt -> "bvslt" + | BVSleq -> "bvsleq" + | BVUMulO -> "bvumulo" + | BVSMulO -> "bvsmulo" + | BVNegO -> "bvnego" + | BVUAddO -> "bvuaddo" + | BVSAddO -> "bvsaddo" + +let to_yojson = TypeDef__.bvop_to_yojson +let of_yojson = TypeDef__.bvop_of_yojson diff --git a/GillianCore/GIL_Syntax/Expr.ml b/GillianCore/GIL_Syntax/Expr.ml index 650e2b70e..4f1b38be5 100644 --- a/GillianCore/GIL_Syntax/Expr.ml +++ b/GillianCore/GIL_Syntax/Expr.ml @@ -1,11 +1,12 @@ open Names -(** GIL Expressions *) +(* TypeDef__.expr = *) type t = TypeDef__.expr = | Lit of Literal.t (** GIL literals *) | PVar of string (** GIL program variables *) | LVar of LVar.t (** GIL logical variables *) | ALoc of string (** GIL abstract locations *) + | BVExprIntrinsic of BVOps.t * bv_arg list * int option | UnOp of UnOp.t * t (** Unary operators *) | BinOp of t * BinOp.t * t (** Binary operators *) | LstSub of t * t * t (** Sublist or (list, start, len) *) @@ -16,7 +17,9 @@ type t = TypeDef__.expr = (** Existential quantification. *) | ForAll of (string * Type.t option) list * t (** Universal quantification. *) -[@@deriving eq, ord] + +and bv_arg = TypeDef__.bv_arg = Literal of int | BvExpr of (t * int) +[@@deriving eq, ord, yojson] let to_yojson = TypeDef__.expr_to_yojson let of_yojson = TypeDef__.expr_of_yojson @@ -30,11 +33,49 @@ let int n = lit (Int (Z.of_int n)) let int_z z = lit (Int z) let string s = lit (String s) let bool b = lit (Bool b) +let bv_z (z : Z.t) (w : int) = lit (LBitvector (z, w)) +let zero_bv (w : int) = bv_z Z.zero w let false_ = Lit (Bool false) let true_ = Lit (Bool true) let zero_i = int_z Z.zero let one_i = int_z Z.one +let extract_bv_width (e : t) = + match e with + | Lit (LBitvector (_, w)) -> w + | BVExprIntrinsic (_, _, Some w) -> w + | _ -> failwith "unrecoginized bitvector expression" + +let concat_single (little : t) (big : t) : t = + let little_size = extract_bv_width little in + let big_size = extract_bv_width big in + let nwidth = Int.add little_size big_size in + BVExprIntrinsic + ( BVOps.BVConcat, + [ BvExpr (big, big_size); BvExpr (little, little_size) ], + Some nwidth ) + +let reduce (f : 'a -> 'a -> 'a) (list : 'a List.t) : 'a = + List.fold_right f (List.tl list) (List.hd list) + +let bv_concat (lst : t List.t) = + reduce (fun elem sum -> concat_single elem sum) lst + +let bv_extract (low_index : int) (high_index : int) (e : t) : t = + let src_width = extract_bv_width e in + let nsize = high_index - low_index + 1 in + BVExprIntrinsic + ( BVOps.BVExtract, + [ Literal high_index; Literal low_index; BvExpr (e, src_width) ], + Some nsize ) + +let bv_extract_between_sz (src : int) (dst : int) (e : t) : t = + let src_width = extract_bv_width e in + assert (src = src_width); + if dst > src then + failwith "We are reading outside of a symbolic value... unsound" + else bv_extract 0 dst e + let num_to_int = function | Lit (Num n) -> int (int_of_float n) | e -> UnOp (NumToInt, e) @@ -339,6 +380,32 @@ module Map = Map.Make (MyExpr) (** Optional map over expressions *) +let rec sequence_opt (l : 'a option list) : 'a list option = + match l with + | [] -> Some [] + | h :: tl -> ( + match h with + | Some x -> Option.map (fun lst -> x :: lst) (sequence_opt tl) + | None -> None) + +let partition_bvargs (lst : bv_arg list) : (t * int) list * int list = + List.partition_map + (function + | BvExpr (e, w) -> Left (e, w) + | Literal i -> Right i) + lst + +let map_bv_arg_exprs (f : t -> t) (lst : bv_arg list) : bv_arg list = + List.map + (function + | BvExpr (e, w) -> BvExpr (f e, w) + | Literal i -> Literal i) + lst + +let exprs_from_bvargs (lst : bv_arg list) : t list = + let es, _ = partition_bvargs lst in + List.map (fun (e, _) -> e) es + let rec map_opt (f_before : t -> t option * bool) (f_after : (t -> t) option) @@ -358,6 +425,14 @@ let rec map_opt match mapped_expr with | Lit _ | LVar _ | ALoc _ | PVar _ -> Some mapped_expr | UnOp (op, e) -> Option.map (fun e -> UnOp (op, e)) (map_e e) + | BVExprIntrinsic (op, es, w) -> + let map_bv_arg = function + | Literal w -> Some (Literal w) + | BvExpr (e, w) -> map_e e |> Option.map (fun x -> BvExpr (x, w)) + in + + List.map map_bv_arg es |> sequence_opt + |> Option.map (fun args -> BVExprIntrinsic (op, args, w)) | BinOp (e1, op, e2) -> ( match (map_e e1, map_e e2) with | Some e1', Some e2' -> Some (BinOp (e1', op, e2')) @@ -390,6 +465,12 @@ let rec pp fmt e = match e with | Lit l -> Literal.pp fmt l | PVar v | LVar v | ALoc v -> Fmt.string fmt v + | BVExprIntrinsic (op, es, w) -> + Fmt.pf fmt "%s(%a: %a)" (BVOps.str op) + (Fmt.list ~sep:Fmt.comma pp_bv_arg) + es + (Fmt.option ~none:Fmt.nop Fmt.int) + w | BinOp (e1, op, e2) -> ( match op with | LstNth | StrNth | LstRepeat -> @@ -415,6 +496,11 @@ let rec pp fmt e = (Fmt.list ~sep:Fmt.comma pp_var_with_type) bt pp e +and pp_bv_arg fmt (arg : bv_arg) = + match arg with + | Literal w -> Fmt.pf fmt "lit(%d)" w + | BvExpr (e, w) -> Fmt.pf fmt "expr(%a, %d)" pp e w + let rec full_pp fmt e = match e with | Lit _ -> Fmt.pf fmt "Lit %a" pp e @@ -472,6 +558,13 @@ let rec is_concrete (le : t) : bool = match le with | Lit _ | PVar _ -> true | LVar _ | ALoc _ | Exists _ | ForAll _ -> false + | BVExprIntrinsic (_, es, _) -> + loop + (List.filter_map + (function + | Literal _ -> None + | BvExpr (e, _) -> Some e) + es) | UnOp (_, e) -> f e | BinOp (e1, _, e2) -> loop [ e1; e2 ] | LstSub (e1, e2, e3) -> loop [ e1; e2; e3 ] diff --git a/GillianCore/GIL_Syntax/Gil_syntax.ml b/GillianCore/GIL_Syntax/Gil_syntax.ml index 656d59030..c8ec20c22 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.ml +++ b/GillianCore/GIL_Syntax/Gil_syntax.ml @@ -22,5 +22,6 @@ module SLCmd = SLCmd module Spec = Spec module Type = Type module UnOp = UnOp +module BVOps = BVOps module Var = Var module Visitors = Visitors diff --git a/GillianCore/GIL_Syntax/Gil_syntax.mli b/GillianCore/GIL_Syntax/Gil_syntax.mli index 9227ab7af..9100b036a 100644 --- a/GillianCore/GIL_Syntax/Gil_syntax.mli +++ b/GillianCore/GIL_Syntax/Gil_syntax.mli @@ -43,7 +43,7 @@ end module Constant : sig (** GIL Constants *) - type t = + type t = TypeDef__.constant = | Min_float (** The smallest float *) | Max_float (** The largest float *) | MaxSafeInteger (** {m 2^{53} - 1} *) @@ -62,7 +62,7 @@ end module Type : sig (** GIL Types *) - type t = + type t = TypeDef__.typ = | UndefinedType (** Type of Undefined *) | NullType (** Type of Null *) | EmptyType (** Type of Empty *) @@ -75,6 +75,7 @@ module Type : sig | ListType (** Type of lists *) | TypeType (** Type of types *) | SetType (** Type of sets *) + | BvType of int [@@deriving yojson, eq, show] (** Printer *) @@ -88,7 +89,7 @@ end module Literal : sig (** GIL Literals *) - type t = + type t = TypeDef__.literal = | Undefined (** The literal [undefined] *) | Null (** The literal [null] *) | Empty (** The literal [empty] *) @@ -100,6 +101,7 @@ module Literal : sig | Loc of string (** GIL locations (uninterpreted symbols) *) | Type of Type.t (** GIL types ({!type:Type.t}) *) | LList of t list (** Lists of GIL literals *) + | LBitvector of (Z.t * int) | Nono (** Negative information *) [@@deriving yojson, eq] @@ -126,7 +128,7 @@ end module UnOp : sig (** GIL Unary Operators *) - type t = + type t = TypeDef__.unop = | IUnaryMinus (** Integer unary minus *) | FUnaryMinus (** Float unary minus *) | Not (** Negation *) @@ -174,11 +176,49 @@ module UnOp : sig val str : t -> string end +(** @canonical Gillian.Gil_syntax.BVOps *) +module BVOps : sig + type t = TypeDef__.bvop = + | BVConcat + | BVExtract + | BVNot + | BVAnd + | BVOr + | BVNeg + | BVPlus + | BVMul + | BVUDiv + | BVUrem + | BVShl + | BVLShr + | BVXor + | BVSrem + | BVSub + | BVSignExtend + | BVZeroExtend + | BVSdiv + | BVSmod + | BVAshr + | BVUlt + | BVUleq + | BVSlt + | BVSleq + | BVUMulO + | BVSMulO + | BVNegO + | BVUAddO + | BVSAddO + [@@deriving yojson, eq] + + (** Printer *) + val str : t -> string +end + (** @canonical Gillian.Gil_syntax.BinOp *) module BinOp : sig (** GIL Binary Operators *) - type t = + type t = TypeDef__.binop = | Equal (** Equality *) | ILessThan (** Less for integers *) | ILessThanEqual (** Less or equal for integers *) @@ -236,7 +276,7 @@ end module NOp : sig (** GIL N-ary Operators *) - type t = + type t = TypeDef__.nop = | LstCat (** List concatenation *) | SetUnion (** Set union *) | SetInter (** Set intersection *) @@ -250,11 +290,12 @@ end module Expr : sig (** GIL Expressions *) - type t = + type t = TypeDef__.expr = | Lit of Literal.t (** GIL literals *) | PVar of string (** GIL program variables *) | LVar of string (** GIL logical variables (interpreted symbols) *) | ALoc of string (** GIL abstract locations (uninterpreted symbols) *) + | BVExprIntrinsic of BVOps.t * bv_arg list * int option | UnOp of UnOp.t * t (** Unary operators ({!type:UnOp.t}) *) | BinOp of t * BinOp.t * t (** Binary operators ({!type:BinOp.t}) *) | LstSub of t * t * t (** Sublist *) @@ -264,11 +305,18 @@ module Expr : sig | Exists of (string * Type.t option) list * t (** Existential quantification. *) | ForAll of (string * Type.t option) list * t + + and bv_arg = TypeDef__.bv_arg = Literal of int | BvExpr of (t * int) [@@deriving yojson] (** {2: Helpers for building expressions} Operations will be optimised away if possible, e.g. [type_ (EList x)] will give [Lit (Type ListType)] directly instead of using {!UnOp.TypeOf} *) + val partition_bvargs : bv_arg list -> (t * int) list * int list + val exprs_from_bvargs : bv_arg list -> t list + val map_bv_arg_exprs : (t -> t) -> bv_arg list -> bv_arg list + val bv_extract_between_sz : int -> int -> t -> t + val bv_extract : int -> int -> t -> t val lit : Literal.t -> t val num : float -> t val num_int : int -> t @@ -286,6 +334,8 @@ module Expr : sig (** Lit (Int Z.one) *) val one_i : t + val bv_z : Z.t -> int -> t + val zero_bv : int -> t val int_to_num : t -> t val num_to_int : t -> t val type_ : Type.t -> t @@ -302,6 +352,7 @@ module Expr : sig val imod : t -> t -> t val type_eq : t -> Type.t -> t val is_concrete_zero_i : t -> bool + val bv_concat : t list -> t module Infix : sig (** Floating point math *) @@ -446,7 +497,7 @@ end module Asrt : sig (** GIL Assertions *) - type atom = + type atom = TypeDef__.assertion_atom = | Emp (** Empty heap *) | Pred of string * Expr.t list (** Predicates *) | Pure of Expr.t (** Pure formula *) @@ -523,7 +574,7 @@ end module SLCmd : sig (** GIL Separation-Logic Commands *) - type t = + type t = TypeDef__.slcmd = | Fold of string * Expr.t list * (string * (string * Expr.t) list) option (** Fold predicate *) | Unfold of string * Expr.t list * (string * string) list option * bool @@ -554,7 +605,7 @@ end module LCmd : sig (** GIL Logical Commands *) - type t = + type t = TypeDef__.lcmd = | If of Expr.t * t list * t list (** If-then-else *) | Branch of Expr.t (** Branching on a FO formual *) | Macro of string * Expr.t list (** Macros *) @@ -578,7 +629,7 @@ module Cmd : sig (** Optional bindings for procedure calls *) type logic_bindings_t = string * (string * Expr.t) list - type 'label t = + type 'label t = 'label TypeDef__.cmd = | Skip (** Skip *) | Assignment of string * Expr.t (** Variable Assignment *) | LAction of string * string * Expr.t list (** Action *) @@ -625,7 +676,7 @@ end module Pred : sig (** GIL Predicates *) - type t = { + type t = TypeDef__.pred = { pred_name : string; (** Name of the predicate *) pred_source_path : string option; pred_internal : bool; @@ -708,13 +759,13 @@ end module Lemma : sig (** GIL Lemmas *) - type spec = { + type spec = TypeDef__.lemma_spec = { lemma_hyp : Asrt.t; (** Hypothesis *) lemma_concs : Asrt.t list; (** Conclusion *) lemma_spec_variant : Expr.t option; (** Variant *) } - type t = { + type t = TypeDef__.lemma = { lemma_name : string; (** Name *) lemma_source_path : string option; lemma_internal : bool; @@ -759,7 +810,7 @@ end module Flag : sig (** Return-flags for GIL specifications *) - type t = + type t = TypeDef__.flag = | Normal (** Normal return *) | Error (** Error return *) | Bug (** Instant crash - for biabduction *) @@ -776,7 +827,7 @@ module Spec : sig (** GIL specifications *) (** Single specification *) - type st = { + type st = TypeDef__.single_spec = { ss_pre : Asrt.t; (** Precondition *) ss_posts : Asrt.t list; (** Postcondition *) ss_variant : Expr.t option; (** Variant *) @@ -786,7 +837,7 @@ module Spec : sig } (** Full specification *) - type t = { + type t = TypeDef__.spec = { spec_name : string; (** Procedure/spec name *) spec_params : string list; (** Procedure/spec parameters *) spec_sspecs : st list; (** List of single specifications *) @@ -912,7 +963,7 @@ module Proc : sig Most functions in Gillian that work with indexed procedures assume for efficiency that the label of the i-th command is always Some i (starting from 0). *) - type ('annot, 'label) t = { + type ('annot, 'label) t = ('annot, 'label) TypeDef__.proc = { proc_name : string; proc_source_path : string option; proc_internal : bool; @@ -1112,1505 +1163,4 @@ module Prog : sig val pp_indexed : Format.formatter -> ?pp_annot:'a Fmt.t -> ('a, int) t -> unit end -(** @canonical Gillian.Gil_syntax.Visitors *) -module Visitors : sig - (** Classes for traversing the GIL AST *) - - class ['b] endo : object ('b) - constraint - 'b = < visit_'annot : 'c -> 'd -> 'd - ; visit_'label : 'c -> 'f -> 'f - ; visit_ALoc : 'c -> Expr.t -> string -> Expr.t - ; visit_And : 'c -> BinOp.t -> BinOp.t - ; visit_Impl : 'c -> BinOp.t -> BinOp.t - ; visit_Apply : - 'c -> 'f Cmd.t -> string -> Expr.t -> 'f option -> 'f Cmd.t - ; visit_ApplyLem : - 'c -> SLCmd.t -> string -> Expr.t list -> string list -> SLCmd.t - ; visit_Arguments : 'c -> 'f Cmd.t -> string -> 'f Cmd.t - ; visit_Assert : 'c -> LCmd.t -> Expr.t -> LCmd.t - ; visit_Assignment : 'c -> 'f Cmd.t -> string -> Expr.t -> 'f Cmd.t - ; visit_Assume : 'c -> LCmd.t -> Expr.t -> LCmd.t - ; visit_AssumeType : 'c -> LCmd.t -> Expr.t -> Type.t -> LCmd.t - ; visit_BinOp : 'c -> Expr.t -> Expr.t -> BinOp.t -> Expr.t -> Expr.t - ; visit_BitwiseAnd : 'c -> BinOp.t -> BinOp.t - ; visit_BitwiseAndL : 'c -> BinOp.t -> BinOp.t - ; visit_BitwiseAndF : 'c -> BinOp.t -> BinOp.t - ; visit_BitwiseNot : 'c -> UnOp.t -> UnOp.t - ; visit_BitwiseOr : 'c -> BinOp.t -> BinOp.t - ; visit_BitwiseOrL : 'c -> BinOp.t -> BinOp.t - ; visit_BitwiseOrF : 'c -> BinOp.t -> BinOp.t - ; visit_BitwiseXor : 'c -> BinOp.t -> BinOp.t - ; visit_BitwiseXorL : 'c -> BinOp.t -> BinOp.t - ; visit_BitwiseXorF : 'c -> BinOp.t -> BinOp.t - ; visit_Bool : 'c -> Literal.t -> bool -> Literal.t - ; visit_BooleanType : 'c -> Type.t -> Type.t - ; visit_Branch : 'c -> LCmd.t -> Expr.t -> LCmd.t - ; visit_Bug : 'c -> Flag.t -> Flag.t - ; visit_Call : - 'c -> - 'f Cmd.t -> - string -> - Expr.t -> - Expr.t list -> - 'f option -> - (string * (string * Expr.t) list) option -> - 'f Cmd.t - ; visit_Car : 'c -> UnOp.t -> UnOp.t - ; visit_Cdr : 'c -> UnOp.t -> UnOp.t - ; visit_Constant : 'c -> Literal.t -> Constant.t -> Literal.t - ; visit_ECall : - 'c -> - 'f Cmd.t -> - string -> - Expr.t -> - Expr.t list -> - 'f option -> - 'f Cmd.t - ; visit_EList : 'c -> Expr.t -> Expr.t list -> Expr.t - ; visit_ESet : 'c -> Expr.t -> Expr.t list -> Expr.t - ; visit_Exists : - 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t - ; visit_Emp : 'c -> Asrt.atom -> Asrt.atom - ; visit_Empty : 'c -> Literal.t -> Literal.t - ; visit_EmptyType : 'c -> Type.t -> Type.t - ; visit_Epsilon : 'c -> Constant.t -> Constant.t - ; visit_Equal : 'c -> BinOp.t -> BinOp.t - ; visit_Error : 'c -> Flag.t -> Flag.t - ; visit_FDiv : 'c -> BinOp.t -> BinOp.t - ; visit_FLessThan : 'c -> BinOp.t -> BinOp.t - ; visit_FLessThanEqual : 'c -> BinOp.t -> BinOp.t - ; visit_FMinus : 'c -> BinOp.t -> BinOp.t - ; visit_FMod : 'c -> BinOp.t -> BinOp.t - ; visit_ForAll : - 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t - ; visit_FPlus : 'c -> BinOp.t -> BinOp.t - ; visit_FTimes : 'c -> BinOp.t -> BinOp.t - ; visit_FUnaryMinus : 'c -> UnOp.t -> UnOp.t - ; visit_Fail : 'c -> 'f Cmd.t -> string -> Expr.t list -> 'f Cmd.t - ; visit_Fold : - 'c -> - SLCmd.t -> - string -> - Expr.t list -> - (string * (string * Expr.t) list) option -> - SLCmd.t - ; visit_CorePred : - 'c -> - Asrt.atom -> - string -> - Expr.t list -> - Expr.t list -> - Asrt.atom - ; visit_Wand : - 'c -> - Asrt.atom -> - string * Expr.t list -> - string * Expr.t list -> - Asrt.atom - ; visit_GUnfold : 'c -> SLCmd.t -> string -> SLCmd.t - ; visit_Goto : 'c -> 'f Cmd.t -> 'f -> 'f Cmd.t - ; visit_GuardedGoto : 'c -> 'f Cmd.t -> Expr.t -> 'f -> 'f -> 'f Cmd.t - ; visit_IDiv : 'c -> BinOp.t -> BinOp.t - ; visit_ILessThan : 'c -> BinOp.t -> BinOp.t - ; visit_ILessThanEqual : 'c -> BinOp.t -> BinOp.t - ; visit_IMinus : 'c -> BinOp.t -> BinOp.t - ; visit_IMod : 'c -> BinOp.t -> BinOp.t - ; visit_IPlus : 'c -> BinOp.t -> BinOp.t - ; visit_ITimes : 'c -> BinOp.t -> BinOp.t - ; visit_IUnaryMinus : 'c -> UnOp.t -> UnOp.t - ; visit_If : - 'c -> LCmd.t -> Expr.t -> LCmd.t list -> LCmd.t list -> LCmd.t - ; visit_Int : 'c -> Literal.t -> Z.t -> Literal.t - ; visit_IntType : 'c -> Type.t -> Type.t - ; visit_Invariant : 'c -> SLCmd.t -> Asrt.t -> string list -> SLCmd.t - ; visit_Consume : 'c -> SLCmd.t -> Asrt.t -> string list -> SLCmd.t - ; visit_Produce : 'c -> SLCmd.t -> Asrt.t -> SLCmd.t - ; visit_LAction : - 'c -> 'f Cmd.t -> string -> string -> Expr.t list -> 'f Cmd.t - ; visit_LList : 'c -> Literal.t -> Literal.t list -> Literal.t - ; visit_LVar : 'c -> Expr.t -> string -> Expr.t - ; visit_LeftShift : 'c -> BinOp.t -> BinOp.t - ; visit_LeftShiftL : 'c -> BinOp.t -> BinOp.t - ; visit_LeftShiftF : 'c -> BinOp.t -> BinOp.t - ; visit_IsInt : 'c -> UnOp.t -> UnOp.t - ; visit_ListType : 'c -> Type.t -> Type.t - ; visit_Lit : 'c -> Expr.t -> Literal.t -> Expr.t - ; visit_Loc : 'c -> Literal.t -> string -> Literal.t - ; visit_LocalTime : 'c -> Constant.t -> Constant.t - ; visit_Logic : 'c -> 'f Cmd.t -> LCmd.t -> 'f Cmd.t - ; visit_LstCat : 'c -> NOp.t -> NOp.t - ; visit_LstLen : 'c -> UnOp.t -> UnOp.t - ; visit_LstNth : 'c -> BinOp.t -> BinOp.t - ; visit_LstRepeat : 'c -> BinOp.t -> BinOp.t - ; visit_LstRev : 'c -> UnOp.t -> UnOp.t - ; visit_LstSub : 'c -> Expr.t -> Expr.t -> Expr.t -> Expr.t -> Expr.t - ; visit_M_abs : 'c -> UnOp.t -> UnOp.t - ; visit_M_acos : 'c -> UnOp.t -> UnOp.t - ; visit_M_asin : 'c -> UnOp.t -> UnOp.t - ; visit_M_atan : 'c -> UnOp.t -> UnOp.t - ; visit_M_atan2 : 'c -> BinOp.t -> BinOp.t - ; visit_M_ceil : 'c -> UnOp.t -> UnOp.t - ; visit_M_cos : 'c -> UnOp.t -> UnOp.t - ; visit_M_exp : 'c -> UnOp.t -> UnOp.t - ; visit_M_floor : 'c -> UnOp.t -> UnOp.t - ; visit_M_isNaN : 'c -> UnOp.t -> UnOp.t - ; visit_M_log : 'c -> UnOp.t -> UnOp.t - ; visit_M_pow : 'c -> BinOp.t -> BinOp.t - ; visit_M_round : 'c -> UnOp.t -> UnOp.t - ; visit_M_sgn : 'c -> UnOp.t -> UnOp.t - ; visit_M_sin : 'c -> UnOp.t -> UnOp.t - ; visit_M_sqrt : 'c -> UnOp.t -> UnOp.t - ; visit_M_tan : 'c -> UnOp.t -> UnOp.t - ; visit_Macro : 'c -> LCmd.t -> string -> Expr.t list -> LCmd.t - ; visit_MaxSafeInteger : 'c -> Constant.t -> Constant.t - ; visit_Max_float : 'c -> Constant.t -> Constant.t - ; visit_Min_float : 'c -> Constant.t -> Constant.t - ; visit_NOp : 'c -> Expr.t -> NOp.t -> Expr.t list -> Expr.t - ; visit_NoneType : 'c -> Type.t -> Type.t - ; visit_Nono : 'c -> Literal.t -> Literal.t - ; visit_Normal : 'c -> Flag.t -> Flag.t - ; visit_Not : 'c -> UnOp.t -> UnOp.t - ; visit_Null : 'c -> Literal.t -> Literal.t - ; visit_NullType : 'c -> Type.t -> Type.t - ; visit_Num : 'c -> Literal.t -> float -> Literal.t - ; visit_NumberType : 'c -> Type.t -> Type.t - ; visit_ObjectType : 'c -> Type.t -> Type.t - ; visit_Or : 'c -> BinOp.t -> BinOp.t - ; visit_PVar : 'c -> Expr.t -> string -> Expr.t - ; visit_PhiAssignment : - 'c -> 'f Cmd.t -> (string * Expr.t list) list -> 'f Cmd.t - ; visit_Pi : 'c -> Constant.t -> Constant.t - ; visit_Pred : 'c -> Asrt.atom -> string -> Expr.t list -> Asrt.atom - ; visit_Pure : 'c -> Asrt.atom -> Expr.t -> Asrt.atom - ; visit_Random : 'c -> Constant.t -> Constant.t - ; visit_ReturnError : 'c -> 'f Cmd.t -> 'f Cmd.t - ; visit_ReturnNormal : 'c -> 'f Cmd.t -> 'f Cmd.t - ; visit_SL : 'c -> LCmd.t -> SLCmd.t -> LCmd.t - ; visit_SepAssert : 'c -> SLCmd.t -> Asrt.t -> string list -> SLCmd.t - ; visit_SetDiff : 'c -> BinOp.t -> BinOp.t - ; visit_SetInter : 'c -> NOp.t -> NOp.t - ; visit_SetMem : 'c -> BinOp.t -> BinOp.t - ; visit_SetSub : 'c -> BinOp.t -> BinOp.t - ; visit_SetToList : 'c -> UnOp.t -> UnOp.t - ; visit_SetType : 'c -> Type.t -> Type.t - ; visit_SetUnion : 'c -> NOp.t -> NOp.t - ; visit_SignedRightShift : 'c -> BinOp.t -> BinOp.t - ; visit_SignedRightShiftL : 'c -> BinOp.t -> BinOp.t - ; visit_SignedRightShiftF : 'c -> BinOp.t -> BinOp.t - ; visit_Skip : 'c -> 'f Cmd.t -> 'f Cmd.t - ; visit_FreshSVar : 'c -> LCmd.t -> string -> LCmd.t - ; visit_StrCat : 'c -> BinOp.t -> BinOp.t - ; visit_StrLen : 'c -> UnOp.t -> UnOp.t - ; visit_StrLess : 'c -> BinOp.t -> BinOp.t - ; visit_NumToInt : 'c -> UnOp.t -> UnOp.t - ; visit_IntToNum : 'c -> UnOp.t -> UnOp.t - ; visit_StrLess : 'c -> BinOp.t -> BinOp.t - ; visit_StrNth : 'c -> BinOp.t -> BinOp.t - ; visit_String : 'c -> Literal.t -> string -> Literal.t - ; visit_StringType : 'c -> Type.t -> Type.t - ; visit_SymbExec : 'c -> SLCmd.t -> SLCmd.t - ; visit_ToInt32Op : 'c -> UnOp.t -> UnOp.t - ; visit_ToIntOp : 'c -> UnOp.t -> UnOp.t - ; visit_ToNumberOp : 'c -> UnOp.t -> UnOp.t - ; visit_ToStringOp : 'c -> UnOp.t -> UnOp.t - ; visit_ToUint16Op : 'c -> UnOp.t -> UnOp.t - ; visit_ToUint32Op : 'c -> UnOp.t -> UnOp.t - ; visit_Type : 'c -> Literal.t -> Type.t -> Literal.t - ; visit_TypeOf : 'c -> UnOp.t -> UnOp.t - ; visit_TypeType : 'c -> Type.t -> Type.t - ; visit_Types : 'c -> Asrt.atom -> (Expr.t * Type.t) list -> Asrt.atom - ; visit_UTCTime : 'c -> Constant.t -> Constant.t - ; visit_UnOp : 'c -> Expr.t -> UnOp.t -> Expr.t -> Expr.t - ; visit_Undefined : 'c -> Literal.t -> Literal.t - ; visit_UndefinedType : 'c -> Type.t -> Type.t - ; visit_Unfold : - 'c -> - SLCmd.t -> - string -> - Expr.t list -> - (string * string) list option -> - bool -> - SLCmd.t - ; visit_Package : - 'c -> - SLCmd.t -> - string * Expr.t list -> - string * Expr.t list -> - SLCmd.t - ; visit_UnsignedRightShift : 'c -> BinOp.t -> BinOp.t - ; visit_UnsignedRightShiftL : 'c -> BinOp.t -> BinOp.t - ; visit_UnsignedRightShiftF : 'c -> BinOp.t -> BinOp.t - ; visit_assertion_atom : 'c -> Asrt.atom -> Asrt.atom - ; visit_assertion : 'c -> Asrt.t -> Asrt.t - ; visit_bindings : - 'c -> - string * (string * Expr.t) list -> - string * (string * Expr.t) list - ; visit_binop : 'c -> BinOp.t -> BinOp.t - ; visit_bispec : 'c -> BiSpec.t -> BiSpec.t - ; visit_cmd : 'c -> 'f Cmd.t -> 'f Cmd.t - ; visit_constant : 'c -> Constant.t -> Constant.t - ; visit_expr : 'c -> Expr.t -> Expr.t - ; visit_flag : 'c -> Flag.t -> Flag.t - ; visit_lcmd : 'c -> LCmd.t -> LCmd.t - ; visit_lemma : 'c -> Lemma.t -> Lemma.t - ; visit_lemma_spec : 'c -> Lemma.spec -> Lemma.spec - ; visit_literal : 'c -> Literal.t -> Literal.t - ; visit_macro : 'c -> Macro.t -> Macro.t - ; visit_nop : 'c -> NOp.t -> NOp.t - ; visit_pred : 'c -> Pred.t -> Pred.t - ; visit_proc : 'c -> ('d, 'f) Proc.t -> ('d, 'f) Proc.t - ; visit_single_spec : 'c -> Spec.st -> Spec.st - ; visit_slcmd : 'c -> SLCmd.t -> SLCmd.t - ; visit_spec : 'c -> Spec.t -> Spec.t - ; visit_typ : 'c -> Type.t -> Type.t - ; visit_unop : 'c -> UnOp.t -> UnOp.t - ; .. > - - method visit_'annot : 'c -> 'd -> 'd - method visit_'label : 'c -> 'f -> 'f - method visit_ALoc : 'c -> Expr.t -> string -> Expr.t - method visit_And : 'c -> BinOp.t -> BinOp.t - method visit_Impl : 'c -> BinOp.t -> BinOp.t - - method visit_Apply : - 'c -> 'f Cmd.t -> string -> Expr.t -> 'f option -> 'f Cmd.t - - method visit_ApplyLem : - 'c -> SLCmd.t -> string -> Expr.t list -> string list -> SLCmd.t - - method visit_Arguments : 'c -> 'f Cmd.t -> string -> 'f Cmd.t - method visit_Assert : 'c -> LCmd.t -> Expr.t -> LCmd.t - method visit_Assignment : 'c -> 'f Cmd.t -> string -> Expr.t -> 'f Cmd.t - method visit_Assume : 'c -> LCmd.t -> Expr.t -> LCmd.t - method visit_AssumeType : 'c -> LCmd.t -> Expr.t -> Type.t -> LCmd.t - method visit_BinOp : 'c -> Expr.t -> Expr.t -> BinOp.t -> Expr.t -> Expr.t - method visit_BitwiseAnd : 'c -> BinOp.t -> BinOp.t - method visit_BitwiseAndL : 'c -> BinOp.t -> BinOp.t - method visit_BitwiseAndF : 'c -> BinOp.t -> BinOp.t - method visit_BitwiseNot : 'c -> UnOp.t -> UnOp.t - method visit_BitwiseOr : 'c -> BinOp.t -> BinOp.t - method visit_BitwiseOrL : 'c -> BinOp.t -> BinOp.t - method visit_BitwiseOrF : 'c -> BinOp.t -> BinOp.t - method visit_BitwiseXor : 'c -> BinOp.t -> BinOp.t - method visit_BitwiseXorL : 'c -> BinOp.t -> BinOp.t - method visit_BitwiseXorF : 'c -> BinOp.t -> BinOp.t - method visit_Bool : 'c -> Literal.t -> bool -> Literal.t - method visit_BooleanType : 'c -> Type.t -> Type.t - method visit_Branch : 'c -> LCmd.t -> Expr.t -> LCmd.t - method visit_Bug : 'c -> Flag.t -> Flag.t - - method visit_Call : - 'c -> - 'f Cmd.t -> - string -> - Expr.t -> - Expr.t list -> - 'f option -> - (string * (string * Expr.t) list) option -> - 'f Cmd.t - - method visit_Car : 'c -> UnOp.t -> UnOp.t - method visit_Cdr : 'c -> UnOp.t -> UnOp.t - method visit_Constant : 'c -> Literal.t -> Constant.t -> Literal.t - - method visit_ECall : - 'c -> 'f Cmd.t -> string -> Expr.t -> Expr.t list -> 'f option -> 'f Cmd.t - - method visit_EList : 'c -> Expr.t -> Expr.t list -> Expr.t - method visit_ESet : 'c -> Expr.t -> Expr.t list -> Expr.t - - method visit_Exists : - 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t - - method visit_Emp : 'c -> Asrt.atom -> Asrt.atom - method visit_Empty : 'c -> Literal.t -> Literal.t - method visit_EmptyType : 'c -> Type.t -> Type.t - method visit_Epsilon : 'c -> Constant.t -> Constant.t - method visit_Equal : 'c -> BinOp.t -> BinOp.t - method visit_Error : 'c -> Flag.t -> Flag.t - method visit_FDiv : 'c -> BinOp.t -> BinOp.t - method visit_FLessThan : 'c -> BinOp.t -> BinOp.t - method visit_FLessThanEqual : 'c -> BinOp.t -> BinOp.t - method visit_FMinus : 'c -> BinOp.t -> BinOp.t - method visit_FMod : 'c -> BinOp.t -> BinOp.t - method visit_FPlus : 'c -> BinOp.t -> BinOp.t - method visit_FTimes : 'c -> BinOp.t -> BinOp.t - method visit_FUnaryMinus : 'c -> UnOp.t -> UnOp.t - method visit_Fail : 'c -> 'f Cmd.t -> string -> Expr.t list -> 'f Cmd.t - - method visit_Fold : - 'c -> - SLCmd.t -> - string -> - Expr.t list -> - (string * (string * Expr.t) list) option -> - SLCmd.t - - method visit_ForAll : - 'c -> Expr.t -> (string * Type.t option) list -> Expr.t -> Expr.t - - method visit_CorePred : - 'c -> Asrt.atom -> string -> Expr.t list -> Expr.t list -> Asrt.atom - - method visit_Wand : - 'c -> - Asrt.atom -> - string * Expr.t list -> - string * Expr.t list -> - Asrt.atom - - method visit_GUnfold : 'c -> SLCmd.t -> string -> SLCmd.t - method visit_Goto : 'c -> 'f Cmd.t -> 'f -> 'f Cmd.t - method visit_GuardedGoto : 'c -> 'f Cmd.t -> Expr.t -> 'f -> 'f -> 'f Cmd.t - method visit_IDiv : 'c -> BinOp.t -> BinOp.t - method visit_ILessThan : 'c -> BinOp.t -> BinOp.t - method visit_ILessThanEqual : 'c -> BinOp.t -> BinOp.t - method visit_IMinus : 'c -> BinOp.t -> BinOp.t - method visit_IMod : 'c -> BinOp.t -> BinOp.t - method visit_IPlus : 'c -> BinOp.t -> BinOp.t - method visit_ITimes : 'c -> BinOp.t -> BinOp.t - method visit_IUnaryMinus : 'c -> UnOp.t -> UnOp.t - - method visit_If : - 'c -> LCmd.t -> Expr.t -> LCmd.t list -> LCmd.t list -> LCmd.t - - method visit_Int : 'c -> Literal.t -> Z.t -> Literal.t - method visit_IntType : 'c -> Type.t -> Type.t - method visit_Invariant : 'c -> SLCmd.t -> Asrt.t -> string list -> SLCmd.t - method visit_Consume : 'c -> SLCmd.t -> Asrt.t -> string list -> SLCmd.t - method visit_Produce : 'c -> SLCmd.t -> Asrt.t -> SLCmd.t - - method visit_LAction : - 'c -> 'f Cmd.t -> string -> string -> Expr.t list -> 'f Cmd.t - - method visit_LList : 'c -> Literal.t -> Literal.t list -> Literal.t - method visit_LVar : 'c -> Expr.t -> string -> Expr.t - method visit_LeftShift : 'c -> BinOp.t -> BinOp.t - method visit_LeftShiftL : 'c -> BinOp.t -> BinOp.t - method visit_LeftShiftF : 'c -> BinOp.t -> BinOp.t - method visit_IsInt : 'c -> UnOp.t -> UnOp.t - method visit_ListType : 'c -> Type.t -> Type.t - method visit_Lit : 'c -> Expr.t -> Literal.t -> Expr.t - method visit_Loc : 'c -> Literal.t -> string -> Literal.t - method visit_LocalTime : 'c -> Constant.t -> Constant.t - method visit_Logic : 'c -> 'f Cmd.t -> LCmd.t -> 'f Cmd.t - method visit_LstCat : 'c -> NOp.t -> NOp.t - method visit_LstLen : 'c -> UnOp.t -> UnOp.t - method visit_LstNth : 'c -> BinOp.t -> BinOp.t - method visit_LstRepeat : 'c -> BinOp.t -> BinOp.t - method visit_LstRev : 'c -> UnOp.t -> UnOp.t - method visit_LstSub : 'c -> Expr.t -> Expr.t -> Expr.t -> Expr.t -> Expr.t - method visit_M_abs : 'c -> UnOp.t -> UnOp.t - method visit_M_acos : 'c -> UnOp.t -> UnOp.t - method visit_M_asin : 'c -> UnOp.t -> UnOp.t - method visit_M_atan : 'c -> UnOp.t -> UnOp.t - method visit_M_atan2 : 'c -> BinOp.t -> BinOp.t - method visit_M_ceil : 'c -> UnOp.t -> UnOp.t - method visit_M_cos : 'c -> UnOp.t -> UnOp.t - method visit_M_exp : 'c -> UnOp.t -> UnOp.t - method visit_M_floor : 'c -> UnOp.t -> UnOp.t - method visit_M_isNaN : 'c -> UnOp.t -> UnOp.t - method visit_M_log : 'c -> UnOp.t -> UnOp.t - method visit_M_pow : 'c -> BinOp.t -> BinOp.t - method visit_M_round : 'c -> UnOp.t -> UnOp.t - method visit_M_sgn : 'c -> UnOp.t -> UnOp.t - method visit_M_sin : 'c -> UnOp.t -> UnOp.t - method visit_M_sqrt : 'c -> UnOp.t -> UnOp.t - method visit_M_tan : 'c -> UnOp.t -> UnOp.t - method visit_Macro : 'c -> LCmd.t -> string -> Expr.t list -> LCmd.t - method visit_MaxSafeInteger : 'c -> Constant.t -> Constant.t - method visit_Max_float : 'c -> Constant.t -> Constant.t - method visit_Min_float : 'c -> Constant.t -> Constant.t - method visit_NOp : 'c -> Expr.t -> NOp.t -> Expr.t list -> Expr.t - method visit_NoneType : 'c -> Type.t -> Type.t - method visit_Nono : 'c -> Literal.t -> Literal.t - method visit_Normal : 'c -> Flag.t -> Flag.t - method visit_Not : 'c -> UnOp.t -> UnOp.t - method visit_Null : 'c -> Literal.t -> Literal.t - method visit_NullType : 'c -> Type.t -> Type.t - method visit_Num : 'c -> Literal.t -> float -> Literal.t - method visit_NumberType : 'c -> Type.t -> Type.t - method visit_ObjectType : 'c -> Type.t -> Type.t - method visit_Or : 'c -> BinOp.t -> BinOp.t - method visit_PVar : 'c -> Expr.t -> string -> Expr.t - - method visit_PhiAssignment : - 'c -> 'f Cmd.t -> (string * Expr.t list) list -> 'f Cmd.t - - method visit_Pi : 'c -> Constant.t -> Constant.t - method visit_Pred : 'c -> Asrt.atom -> string -> Expr.t list -> Asrt.atom - method visit_Pure : 'c -> Asrt.atom -> Expr.t -> Asrt.atom - method visit_Random : 'c -> Constant.t -> Constant.t - method visit_ReturnError : 'c -> 'f Cmd.t -> 'f Cmd.t - method visit_ReturnNormal : 'c -> 'f Cmd.t -> 'f Cmd.t - method visit_SL : 'c -> LCmd.t -> SLCmd.t -> LCmd.t - method visit_SepAssert : 'c -> SLCmd.t -> Asrt.t -> string list -> SLCmd.t - method visit_SetDiff : 'c -> BinOp.t -> BinOp.t - method visit_SetInter : 'c -> NOp.t -> NOp.t - method visit_SetMem : 'c -> BinOp.t -> BinOp.t - method visit_SetSub : 'c -> BinOp.t -> BinOp.t - method visit_SetToList : 'c -> UnOp.t -> UnOp.t - method visit_SetType : 'c -> Type.t -> Type.t - method visit_SetUnion : 'c -> NOp.t -> NOp.t - method visit_SignedRightShift : 'c -> BinOp.t -> BinOp.t - method visit_SignedRightShiftL : 'c -> BinOp.t -> BinOp.t - method visit_SignedRightShiftF : 'c -> BinOp.t -> BinOp.t - method visit_Skip : 'c -> 'f Cmd.t -> 'f Cmd.t - method visit_FreshSVar : 'c -> LCmd.t -> string -> LCmd.t - method visit_StrCat : 'c -> BinOp.t -> BinOp.t - method visit_StrLen : 'c -> UnOp.t -> UnOp.t - method visit_StrLess : 'c -> BinOp.t -> BinOp.t - method visit_IntToNum : 'c -> UnOp.t -> UnOp.t - method visit_NumToInt : 'c -> UnOp.t -> UnOp.t - method visit_StrLess : 'c -> BinOp.t -> BinOp.t - method visit_StrNth : 'c -> BinOp.t -> BinOp.t - method visit_String : 'c -> Literal.t -> string -> Literal.t - method visit_StringType : 'c -> Type.t -> Type.t - method visit_SymbExec : 'c -> SLCmd.t -> SLCmd.t - method visit_ToInt32Op : 'c -> UnOp.t -> UnOp.t - method visit_ToIntOp : 'c -> UnOp.t -> UnOp.t - method visit_ToNumberOp : 'c -> UnOp.t -> UnOp.t - method visit_ToStringOp : 'c -> UnOp.t -> UnOp.t - method visit_ToUint16Op : 'c -> UnOp.t -> UnOp.t - method visit_ToUint32Op : 'c -> UnOp.t -> UnOp.t - method visit_Type : 'c -> Literal.t -> Type.t -> Literal.t - method visit_TypeOf : 'c -> UnOp.t -> UnOp.t - method visit_TypeType : 'c -> Type.t -> Type.t - method visit_Types : 'c -> Asrt.atom -> (Expr.t * Type.t) list -> Asrt.atom - method visit_UTCTime : 'c -> Constant.t -> Constant.t - method visit_UnOp : 'c -> Expr.t -> UnOp.t -> Expr.t -> Expr.t - method visit_Undefined : 'c -> Literal.t -> Literal.t - method visit_UndefinedType : 'c -> Type.t -> Type.t - - method visit_Unfold : - 'c -> - SLCmd.t -> - string -> - Expr.t list -> - (string * string) list option -> - bool -> - SLCmd.t - - method visit_Package : - 'c -> SLCmd.t -> string * Expr.t list -> string * Expr.t list -> SLCmd.t - - method visit_UnsignedRightShift : 'c -> BinOp.t -> BinOp.t - method visit_UnsignedRightShiftL : 'c -> BinOp.t -> BinOp.t - method visit_UnsignedRightShiftF : 'c -> BinOp.t -> BinOp.t - - method private visit_array : - 'env 'a. ('env -> 'a -> 'a) -> 'env -> 'a array -> 'a array - - method visit_assertion_atom : 'c -> Asrt.atom -> Asrt.atom - method visit_assertion : 'c -> Asrt.t -> Asrt.t - - method visit_bindings : - 'c -> string * (string * Expr.t) list -> string * (string * Expr.t) list - - method visit_binop : 'c -> BinOp.t -> BinOp.t - method visit_bispec : 'c -> BiSpec.t -> BiSpec.t - method private visit_bool : 'env. 'env -> bool -> bool - method private visit_bytes : 'env. 'env -> bytes -> bytes - method private visit_char : 'env. 'env -> char -> char - method visit_cmd : 'c -> 'f Cmd.t -> 'f Cmd.t - method visit_constant : 'c -> Constant.t -> Constant.t - method visit_expr : 'c -> Expr.t -> Expr.t - method visit_flag : 'c -> Flag.t -> Flag.t - method private visit_float : 'env. 'env -> float -> float - method private visit_int : 'env. 'env -> int -> int - method private visit_int32 : 'env. 'env -> int32 -> int32 - method private visit_int64 : 'env. 'env -> int64 -> int64 - - method private visit_lazy_t : - 'env 'a. ('env -> 'a -> 'a) -> 'env -> 'a Lazy.t -> 'a Lazy.t - - method visit_lcmd : 'c -> LCmd.t -> LCmd.t - method visit_lemma : 'c -> Lemma.t -> Lemma.t - method visit_lemma_spec : 'c -> Lemma.spec -> Lemma.spec - - method private visit_list : - 'env 'a. ('env -> 'a -> 'a) -> 'env -> 'a list -> 'a list - - method visit_literal : 'c -> Literal.t -> Literal.t - method visit_macro : 'c -> Macro.t -> Macro.t - method private visit_nativeint : 'env. 'env -> nativeint -> nativeint - method visit_nop : 'c -> NOp.t -> NOp.t - - method private visit_option : - 'env 'a. ('env -> 'a -> 'a) -> 'env -> 'a option -> 'a option - - method visit_pred : 'c -> Pred.t -> Pred.t - method visit_proc : 'c -> ('d, 'f) Proc.t -> ('d, 'f) Proc.t - - method private visit_ref : - 'env 'a. ('env -> 'a -> 'a) -> 'env -> 'a ref -> 'a ref - - method private visit_result : - 'env 'a 'e. - ('env -> 'a -> 'a) -> - ('env -> 'e -> 'e) -> - 'env -> - ('a, 'e) Result.result -> - ('a, 'e) Result.result - - method visit_single_spec : 'c -> Spec.st -> Spec.st - method visit_slcmd : 'c -> SLCmd.t -> SLCmd.t - method visit_spec : 'c -> Spec.t -> Spec.t - method private visit_string : 'env. 'env -> string -> string - method visit_typ : 'c -> Type.t -> Type.t - method private visit_unit : 'env. 'env -> unit -> unit - method visit_unop : 'c -> UnOp.t -> UnOp.t - end - - class virtual ['b] reduce : object ('b) - constraint - 'b = < visit_'annot : 'c -> 'd -> 'f - ; visit_'label : 'c -> 'g -> 'f - ; visit_ALoc : 'c -> ALoc.t -> 'f - ; visit_And : 'c -> 'f - ; visit_Impl : 'c -> 'f - ; visit_Apply : 'c -> string -> Expr.t -> 'g option -> 'f - ; visit_ApplyLem : 'c -> string -> Expr.t list -> string list -> 'f - ; visit_Arguments : 'c -> string -> 'f - ; visit_Assert : 'c -> Expr.t -> 'f - ; visit_Assignment : 'c -> string -> Expr.t -> 'f - ; visit_Assume : 'c -> Expr.t -> 'f - ; visit_AssumeType : 'c -> Expr.t -> Type.t -> 'f - ; visit_BinOp : 'c -> Expr.t -> BinOp.t -> Expr.t -> 'f - ; visit_BitwiseAnd : 'c -> 'f - ; visit_BitwiseAndL : 'c -> 'f - ; visit_BitwiseAndF : 'c -> 'f - ; visit_BitwiseNot : 'c -> 'f - ; visit_BitwiseOr : 'c -> 'f - ; visit_BitwiseOrL : 'c -> 'f - ; visit_BitwiseOrF : 'c -> 'f - ; visit_BitwiseXor : 'c -> 'f - ; visit_BitwiseXorL : 'c -> 'f - ; visit_BitwiseXorF : 'c -> 'f - ; visit_Bool : 'c -> bool -> 'f - ; visit_BooleanType : 'c -> 'f - ; visit_Branch : 'c -> Expr.t -> 'f - ; visit_Bug : 'c -> 'f - ; visit_Call : - 'c -> - string -> - Expr.t -> - Expr.t list -> - 'g option -> - (string * (string * Expr.t) list) option -> - 'f - ; visit_Car : 'c -> 'f - ; visit_Cdr : 'c -> 'f - ; visit_Constant : 'c -> Constant.t -> 'f - ; visit_IDiv : 'c -> 'f - ; visit_FDiv : 'c -> 'f - ; visit_ECall : - 'c -> string -> Expr.t -> Expr.t list -> 'g option -> 'f - ; visit_EList : 'c -> Expr.t list -> 'f - ; visit_ESet : 'c -> Expr.t list -> 'f - ; visit_Exists : 'c -> (string * Type.t option) list -> Expr.t -> 'f - ; visit_Emp : 'c -> 'f - ; visit_Empty : 'c -> 'f - ; visit_EmptyType : 'c -> 'f - ; visit_Epsilon : 'c -> 'f - ; visit_Equal : 'c -> 'f - ; visit_Error : 'c -> 'f - ; visit_Fail : 'c -> string -> Expr.t list -> 'f - ; visit_Fold : - 'c -> - string -> - Expr.t list -> - (string * (string * Expr.t) list) option -> - 'f - ; visit_ForAll : 'c -> (string * Type.t option) list -> Expr.t -> 'f - ; visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> 'f - ; visit_Wand : 'c -> string * Expr.t list -> string * Expr.t list -> 'f - ; visit_GUnfold : 'c -> string -> 'f - ; visit_Goto : 'c -> 'g -> 'f - ; visit_GuardedGoto : 'c -> Expr.t -> 'g -> 'g -> 'f - ; visit_If : 'c -> Expr.t -> LCmd.t list -> LCmd.t list -> 'f - ; visit_Invariant : 'c -> Asrt.t -> string list -> 'f - ; visit_Consume : 'c -> Asrt.t -> string list -> 'f - ; visit_Produce : 'c -> Asrt.t -> 'f - ; visit_LAction : 'c -> string -> string -> Expr.t list -> 'f - ; visit_LList : 'c -> Literal.t list -> 'f - ; visit_LVar : 'c -> LVar.t -> 'f - ; visit_LeftShift : 'c -> 'f - ; visit_LeftShiftL : 'c -> 'f - ; visit_LeftShiftF : 'c -> 'f - ; visit_IsInt : 'c -> 'f - ; visit_ILessThan : 'c -> 'f - ; visit_ILessThanEqual : 'c -> 'f - ; visit_FLessThan : 'c -> 'f - ; visit_FLessThanEqual : 'c -> 'f - ; visit_ListType : 'c -> 'f - ; visit_Lit : 'c -> Literal.t -> 'f - ; visit_Loc : 'c -> string -> 'f - ; visit_LocalTime : 'c -> 'f - ; visit_Logic : 'c -> LCmd.t -> 'f - ; visit_LstCat : 'c -> 'f - ; visit_LstLen : 'c -> 'f - ; visit_LstNth : 'c -> 'f - ; visit_LstRepeat : 'c -> 'f - ; visit_LstRev : 'c -> 'f - ; visit_LstSub : 'c -> Expr.t -> Expr.t -> Expr.t -> 'f - ; visit_M_abs : 'c -> 'f - ; visit_M_acos : 'c -> 'f - ; visit_M_asin : 'c -> 'f - ; visit_M_atan : 'c -> 'f - ; visit_M_atan2 : 'c -> 'f - ; visit_M_ceil : 'c -> 'f - ; visit_M_cos : 'c -> 'f - ; visit_M_exp : 'c -> 'f - ; visit_M_floor : 'c -> 'f - ; visit_M_isNaN : 'c -> 'f - ; visit_M_log : 'c -> 'f - ; visit_M_pow : 'c -> 'f - ; visit_M_round : 'c -> 'f - ; visit_M_sgn : 'c -> 'f - ; visit_M_sin : 'c -> 'f - ; visit_M_sqrt : 'c -> 'f - ; visit_M_tan : 'c -> 'f - ; visit_Macro : 'c -> string -> Expr.t list -> 'f - ; visit_Max_float : 'c -> 'f - ; visit_MaxSafeInteger : 'c -> 'f - ; visit_Min_float : 'c -> 'f - ; visit_IMinus : 'c -> 'f - ; visit_FMinus : 'c -> 'f - ; visit_IMod : 'c -> 'f - ; visit_FMod : 'c -> 'f - ; visit_NOp : 'c -> NOp.t -> Expr.t list -> 'f - ; visit_NoneType : 'c -> 'f - ; visit_Nono : 'c -> 'f - ; visit_Normal : 'c -> 'f - ; visit_Not : 'c -> 'f - ; visit_Null : 'c -> 'f - ; visit_NullType : 'c -> 'f - ; visit_Int : 'c -> Z.t -> 'f - ; visit_Num : 'c -> float -> 'f - ; visit_IntType : 'c -> 'f - ; visit_NumberType : 'c -> 'f - ; visit_ObjectType : 'c -> 'f - ; visit_Or : 'c -> 'f - ; visit_PVar : 'c -> string -> 'f - ; visit_PhiAssignment : 'c -> (string * Expr.t list) list -> 'f - ; visit_Pi : 'c -> 'f - ; visit_IPlus : 'c -> 'f - ; visit_FPlus : 'c -> 'f - ; visit_Pred : 'c -> string -> Expr.t list -> 'f - ; visit_Pure : 'c -> Expr.t -> 'f - ; visit_Random : 'c -> 'f - ; visit_ReturnError : 'c -> 'f - ; visit_ReturnNormal : 'c -> 'f - ; visit_SL : 'c -> SLCmd.t -> 'f - ; visit_SepAssert : 'c -> Asrt.t -> string list -> 'f - ; visit_SetDiff : 'c -> 'f - ; visit_SetInter : 'c -> 'f - ; visit_SetMem : 'c -> 'f - ; visit_SetSub : 'c -> 'f - ; visit_SetToList : 'c -> 'f - ; visit_SetType : 'c -> 'f - ; visit_SetUnion : 'c -> 'f - ; visit_SignedRightShift : 'c -> 'f - ; visit_SignedRightShiftL : 'c -> 'f - ; visit_SignedRightShiftF : 'c -> 'f - ; visit_Skip : 'c -> 'f - ; visit_FreshSVar : 'c -> string -> 'f - ; visit_StrCat : 'c -> 'f - ; visit_StrLen : 'c -> 'f - ; visit_StrLess : 'c -> 'f - ; visit_IntToNum : 'c -> 'f - ; visit_NumToInt : 'c -> 'f - ; visit_StrLess : 'c -> 'f - ; visit_StrNth : 'c -> 'f - ; visit_String : 'c -> string -> 'f - ; visit_StringType : 'c -> 'f - ; visit_SymbExec : 'c -> 'f - ; visit_ITimes : 'c -> 'f - ; visit_FTimes : 'c -> 'f - ; visit_ToInt32Op : 'c -> 'f - ; visit_ToIntOp : 'c -> 'f - ; visit_ToNumberOp : 'c -> 'f - ; visit_ToStringOp : 'c -> 'f - ; visit_ToUint16Op : 'c -> 'f - ; visit_ToUint32Op : 'c -> 'f - ; visit_Type : 'c -> Type.t -> 'f - ; visit_TypeOf : 'c -> 'f - ; visit_TypeType : 'c -> 'f - ; visit_Types : 'c -> (Expr.t * Type.t) list -> 'f - ; visit_UTCTime : 'c -> 'f - ; visit_UnOp : 'c -> UnOp.t -> Expr.t -> 'f - ; visit_IUnaryMinus : 'c -> 'f - ; visit_FUnaryMinus : 'c -> 'f - ; visit_Undefined : 'c -> 'f - ; visit_UndefinedType : 'c -> 'f - ; visit_Unfold : - 'c -> - string -> - Expr.t list -> - (string * string) list option -> - bool -> - 'f - ; visit_Package : - 'c -> string * Expr.t list -> string * Expr.t list -> 'f - ; visit_UnsignedRightShift : 'c -> 'f - ; visit_UnsignedRightShiftL : 'c -> 'f - ; visit_UnsignedRightShiftF : 'c -> 'f - ; visit_assertion_atom : 'c -> Asrt.atom -> 'f - ; visit_assertion : 'c -> Asrt.t -> 'f - ; visit_bindings : 'c -> string * (string * Expr.t) list -> 'f - ; visit_binop : 'c -> BinOp.t -> 'f - ; visit_bispec : 'c -> BiSpec.t -> 'f - ; visit_cmd : 'c -> 'g Cmd.t -> 'f - ; visit_constant : 'c -> Constant.t -> 'f - ; visit_expr : 'c -> Expr.t -> 'f - ; visit_flag : 'c -> Flag.t -> 'f - ; visit_lcmd : 'c -> LCmd.t -> 'f - ; visit_lemma : 'c -> Lemma.t -> 'f - ; visit_lemma_spec : 'c -> Lemma.spec -> 'f - ; visit_literal : 'c -> Literal.t -> 'f - ; visit_macro : 'c -> Macro.t -> 'f - ; visit_nop : 'c -> NOp.t -> 'f - ; visit_pred : 'c -> Pred.t -> 'f - ; visit_proc : 'c -> ('d, 'g) Proc.t -> 'f - ; visit_single_spec : 'c -> Spec.st -> 'f - ; visit_slcmd : 'c -> SLCmd.t -> 'f - ; visit_spec : 'c -> Spec.t -> 'f - ; visit_typ : 'c -> Type.t -> 'f - ; visit_unop : 'c -> UnOp.t -> 'f - ; .. > - - method virtual private plus : 'f -> 'f -> 'f - method visit_'annot : 'c -> 'd -> 'f - method visit_'label : 'c -> 'g -> 'f - method visit_ALoc : 'c -> ALoc.t -> 'f - method visit_And : 'c -> 'f - method visit_Impl : 'c -> 'f - method visit_Apply : 'c -> string -> Expr.t -> 'g option -> 'f - method visit_ApplyLem : 'c -> string -> Expr.t list -> string list -> 'f - method visit_Arguments : 'c -> string -> 'f - method visit_Assert : 'c -> Expr.t -> 'f - method visit_Assignment : 'c -> string -> Expr.t -> 'f - method visit_Assume : 'c -> Expr.t -> 'f - method visit_AssumeType : 'c -> Expr.t -> Type.t -> 'f - method visit_BinOp : 'c -> Expr.t -> BinOp.t -> Expr.t -> 'f - method visit_BitwiseAnd : 'c -> 'f - method visit_BitwiseAndL : 'c -> 'f - method visit_BitwiseAndF : 'c -> 'f - method visit_BitwiseNot : 'c -> 'f - method visit_BitwiseOr : 'c -> 'f - method visit_BitwiseOrL : 'c -> 'f - method visit_BitwiseOrF : 'c -> 'f - method visit_BitwiseXor : 'c -> 'f - method visit_BitwiseXorL : 'c -> 'f - method visit_BitwiseXorF : 'c -> 'f - method visit_Bool : 'c -> bool -> 'f - method visit_BooleanType : 'c -> 'f - method visit_Branch : 'c -> Expr.t -> 'f - method visit_Bug : 'c -> 'f - - method visit_Call : - 'c -> - string -> - Expr.t -> - Expr.t list -> - 'g option -> - (string * (string * Expr.t) list) option -> - 'f - - method visit_Car : 'c -> 'f - method visit_Cdr : 'c -> 'f - method visit_Constant : 'c -> Constant.t -> 'f - method visit_IDiv : 'c -> 'f - method visit_FDiv : 'c -> 'f - - method visit_ECall : - 'c -> string -> Expr.t -> Expr.t list -> 'g option -> 'f - - method visit_EList : 'c -> Expr.t list -> 'f - method visit_ESet : 'c -> Expr.t list -> 'f - method visit_Exists : 'c -> (string * Type.t option) list -> Expr.t -> 'f - method visit_Emp : 'c -> 'f - method visit_Empty : 'c -> 'f - method visit_EmptyType : 'c -> 'f - method visit_Epsilon : 'c -> 'f - method visit_Equal : 'c -> 'f - method visit_Error : 'c -> 'f - method visit_Fail : 'c -> string -> Expr.t list -> 'f - - method visit_Fold : - 'c -> - string -> - Expr.t list -> - (string * (string * Expr.t) list) option -> - 'f - - method visit_ForAll : 'c -> (string * Type.t option) list -> Expr.t -> 'f - method visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> 'f - method visit_Wand : 'c -> string * Expr.t list -> string * Expr.t list -> 'f - method visit_GUnfold : 'c -> string -> 'f - method visit_Goto : 'c -> 'g -> 'f - method visit_GuardedGoto : 'c -> Expr.t -> 'g -> 'g -> 'f - method visit_If : 'c -> Expr.t -> LCmd.t list -> LCmd.t list -> 'f - method visit_IsInt : 'c -> 'f - method visit_Invariant : 'c -> Asrt.t -> string list -> 'f - method visit_Consume : 'c -> Asrt.t -> string list -> 'f - method visit_Produce : 'c -> Asrt.t -> 'f - method visit_LAction : 'c -> string -> string -> Expr.t list -> 'f - method visit_LList : 'c -> Literal.t list -> 'f - method visit_LVar : 'c -> LVar.t -> 'f - method visit_LeftShift : 'c -> 'f - method visit_LeftShiftL : 'c -> 'f - method visit_LeftShiftF : 'c -> 'f - method visit_ILessThan : 'c -> 'f - method visit_ILessThanEqual : 'c -> 'f - method visit_FLessThan : 'c -> 'f - method visit_FLessThanEqual : 'c -> 'f - method visit_ListType : 'c -> 'f - method visit_Lit : 'c -> Literal.t -> 'f - method visit_Loc : 'c -> string -> 'f - method visit_LocalTime : 'c -> 'f - method visit_Logic : 'c -> LCmd.t -> 'f - method visit_LstCat : 'c -> 'f - method visit_LstLen : 'c -> 'f - method visit_LstNth : 'c -> 'f - method visit_LstRepeat : 'c -> 'f - method visit_LstRev : 'c -> 'f - method visit_LstSub : 'c -> Expr.t -> Expr.t -> Expr.t -> 'f - method visit_M_abs : 'c -> 'f - method visit_M_acos : 'c -> 'f - method visit_M_asin : 'c -> 'f - method visit_M_atan : 'c -> 'f - method visit_M_atan2 : 'c -> 'f - method visit_M_ceil : 'c -> 'f - method visit_M_cos : 'c -> 'f - method visit_M_exp : 'c -> 'f - method visit_M_floor : 'c -> 'f - method visit_M_isNaN : 'c -> 'f - method visit_M_log : 'c -> 'f - method visit_M_pow : 'c -> 'f - method visit_M_round : 'c -> 'f - method visit_M_sgn : 'c -> 'f - method visit_M_sin : 'c -> 'f - method visit_M_sqrt : 'c -> 'f - method visit_M_tan : 'c -> 'f - method visit_Macro : 'c -> string -> Expr.t list -> 'f - method visit_Max_float : 'c -> 'f - method visit_MaxSafeInteger : 'c -> 'f - method visit_Min_float : 'c -> 'f - method visit_IMinus : 'c -> 'f - method visit_FMinus : 'c -> 'f - method visit_IMod : 'c -> 'f - method visit_FMod : 'c -> 'f - method visit_NOp : 'c -> NOp.t -> Expr.t list -> 'f - method visit_NoneType : 'c -> 'f - method visit_Nono : 'c -> 'f - method visit_Normal : 'c -> 'f - method visit_Not : 'c -> 'f - method visit_Null : 'c -> 'f - method visit_NullType : 'c -> 'f - method visit_Int : 'c -> Z.t -> 'f - method visit_Num : 'c -> float -> 'f - method visit_IntType : 'c -> 'f - method visit_NumberType : 'c -> 'f - method visit_ObjectType : 'c -> 'f - method visit_Or : 'c -> 'f - method visit_PVar : 'c -> string -> 'f - method visit_PhiAssignment : 'c -> (string * Expr.t list) list -> 'f - method visit_Pi : 'c -> 'f - method visit_IPlus : 'c -> 'f - method visit_FPlus : 'c -> 'f - method visit_Pred : 'c -> string -> Expr.t list -> 'f - method visit_Pure : 'c -> Expr.t -> 'f - method visit_Random : 'c -> 'f - method visit_ReturnError : 'c -> 'f - method visit_ReturnNormal : 'c -> 'f - method visit_SL : 'c -> SLCmd.t -> 'f - method visit_SepAssert : 'c -> Asrt.t -> string list -> 'f - method visit_SetDiff : 'c -> 'f - method visit_SetInter : 'c -> 'f - method visit_SetMem : 'c -> 'f - method visit_SetSub : 'c -> 'f - method visit_SetToList : 'c -> 'f - method visit_SetType : 'c -> 'f - method visit_SetUnion : 'c -> 'f - method visit_SignedRightShift : 'c -> 'f - method visit_SignedRightShiftL : 'c -> 'f - method visit_SignedRightShiftF : 'c -> 'f - method visit_Skip : 'c -> 'f - method visit_FreshSVar : 'c -> string -> 'f - method visit_StrCat : 'c -> 'f - method visit_StrLen : 'c -> 'f - method visit_StrLess : 'c -> 'f - method visit_IntToNum : 'c -> 'f - method visit_NumToInt : 'c -> 'f - method visit_StrLess : 'c -> 'f - method visit_StrNth : 'c -> 'f - method visit_String : 'c -> string -> 'f - method visit_StringType : 'c -> 'f - method visit_SymbExec : 'c -> 'f - method visit_ITimes : 'c -> 'f - method visit_FTimes : 'c -> 'f - method visit_ToInt32Op : 'c -> 'f - method visit_ToIntOp : 'c -> 'f - method visit_ToNumberOp : 'c -> 'f - method visit_ToStringOp : 'c -> 'f - method visit_ToUint16Op : 'c -> 'f - method visit_ToUint32Op : 'c -> 'f - method visit_Type : 'c -> Type.t -> 'f - method visit_TypeOf : 'c -> 'f - method visit_TypeType : 'c -> 'f - method visit_Types : 'c -> (Expr.t * Type.t) list -> 'f - method visit_UTCTime : 'c -> 'f - method visit_UnOp : 'c -> UnOp.t -> Expr.t -> 'f - method visit_IUnaryMinus : 'c -> 'f - method visit_FUnaryMinus : 'c -> 'f - method visit_Undefined : 'c -> 'f - method visit_UndefinedType : 'c -> 'f - - method visit_Unfold : - 'c -> string -> Expr.t list -> (string * string) list option -> bool -> 'f - - method visit_Package : - 'c -> string * Expr.t list -> string * Expr.t list -> 'f - - method visit_UnsignedRightShift : 'c -> 'f - method visit_UnsignedRightShiftL : 'c -> 'f - method visit_UnsignedRightShiftF : 'c -> 'f - method visit_assertion_atom : 'c -> Asrt.atom -> 'f - method visit_assertion : 'c -> Asrt.t -> 'f - method visit_bindings : 'c -> string * (string * Expr.t) list -> 'f - method visit_binop : 'c -> BinOp.t -> 'f - method visit_bispec : 'c -> BiSpec.t -> 'f - method visit_cmd : 'c -> 'g Cmd.t -> 'f - method visit_constant : 'c -> Constant.t -> 'f - method visit_expr : 'c -> Expr.t -> 'f - method visit_flag : 'c -> Flag.t -> 'f - method visit_lcmd : 'c -> LCmd.t -> 'f - method visit_lemma : 'c -> Lemma.t -> 'f - method visit_lemma_spec : 'c -> Lemma.spec -> 'f - method visit_literal : 'c -> Literal.t -> 'f - method visit_macro : 'c -> Macro.t -> 'f - method visit_nop : 'c -> NOp.t -> 'f - method visit_pred : 'c -> Pred.t -> 'f - method visit_proc : 'c -> ('d, 'g) Proc.t -> 'f - method visit_single_spec : 'c -> Spec.st -> 'f - method visit_slcmd : 'c -> SLCmd.t -> 'f - method visit_spec : 'c -> Spec.t -> 'f - method visit_typ : 'c -> Type.t -> 'f - method visit_unop : 'c -> UnOp.t -> 'f - method virtual private zero : 'f - end - - class ['b] iter : object ('b) - constraint - 'b = < visit_'annot : 'c -> 'd -> unit - ; visit_'label : 'c -> 'f -> unit - ; visit_ALoc : 'c -> string -> unit - ; visit_And : 'c -> unit - ; visit_Impl : 'c -> unit - ; visit_Apply : 'c -> string -> Expr.t -> 'f option -> unit - ; visit_ApplyLem : 'c -> string -> Expr.t list -> string list -> unit - ; visit_Arguments : 'c -> string -> unit - ; visit_Assert : 'c -> Expr.t -> unit - ; visit_Assignment : 'c -> string -> Expr.t -> unit - ; visit_Assume : 'c -> Expr.t -> unit - ; visit_AssumeType : 'c -> Expr.t -> Type.t -> unit - ; visit_BinOp : 'c -> Expr.t -> BinOp.t -> Expr.t -> unit - ; visit_BitwiseAnd : 'c -> unit - ; visit_BitwiseAndL : 'c -> unit - ; visit_BitwiseAndF : 'c -> unit - ; visit_BitwiseNot : 'c -> unit - ; visit_BitwiseOr : 'c -> unit - ; visit_BitwiseOrL : 'c -> unit - ; visit_BitwiseOrF : 'c -> unit - ; visit_BitwiseXor : 'c -> unit - ; visit_BitwiseXorL : 'c -> unit - ; visit_BitwiseXorF : 'c -> unit - ; visit_Bool : 'c -> bool -> unit - ; visit_BooleanType : 'c -> unit - ; visit_Branch : 'c -> Expr.t -> unit - ; visit_Bug : 'c -> unit - ; visit_Call : - 'c -> - string -> - Expr.t -> - Expr.t list -> - 'f option -> - Cmd.logic_bindings_t option -> - unit - ; visit_Car : 'c -> unit - ; visit_Cdr : 'c -> unit - ; visit_Constant : 'c -> Constant.t -> unit - ; visit_ECall : - 'c -> string -> Expr.t -> Expr.t list -> 'f option -> unit - ; visit_EList : 'c -> Expr.t list -> unit - ; visit_ESet : 'c -> Expr.t list -> unit - ; visit_Exists : 'c -> (string * Type.t option) list -> Expr.t -> unit - ; visit_Emp : 'c -> unit - ; visit_Empty : 'c -> unit - ; visit_EmptyType : 'c -> unit - ; visit_Epsilon : 'c -> unit - ; visit_Equal : 'c -> unit - ; visit_Error : 'c -> unit - ; visit_FDiv : 'c -> unit - ; visit_FLessThan : 'c -> unit - ; visit_FLessThanEqual : 'c -> unit - ; visit_FMinus : 'c -> unit - ; visit_FMod : 'c -> unit - ; visit_FPlus : 'c -> unit - ; visit_FTimes : 'c -> unit - ; visit_FUnaryMinus : 'c -> unit - ; visit_Fail : 'c -> string -> Expr.t list -> unit - ; visit_Fold : - 'c -> - string -> - Expr.t list -> - (string * (string * Expr.t) list) option -> - unit - ; visit_ForAll : 'c -> (string * Type.t option) list -> Expr.t -> unit - ; visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> unit - ; visit_Wand : - 'c -> string * Expr.t list -> string * Expr.t list -> unit - ; visit_GUnfold : 'c -> string -> unit - ; visit_Goto : 'c -> 'f -> unit - ; visit_GuardedGoto : 'c -> Expr.t -> 'f -> 'f -> unit - ; visit_IDiv : 'c -> unit - ; visit_ILessThan : 'c -> unit - ; visit_ILessThanEqual : 'c -> unit - ; visit_IMinus : 'c -> unit - ; visit_IMod : 'c -> unit - ; visit_IPlus : 'c -> unit - ; visit_ITimes : 'c -> unit - ; visit_IUnaryMinus : 'c -> unit - ; visit_If : 'c -> Expr.t -> LCmd.t list -> LCmd.t list -> unit - ; visit_Int : 'c -> Z.t -> unit - ; visit_IntType : 'c -> unit - ; visit_Invariant : 'c -> Asrt.t -> string list -> unit - ; visit_Consume : 'c -> Asrt.t -> string list -> unit - ; visit_Produce : 'c -> Asrt.t -> unit - ; visit_LAction : 'c -> string -> string -> Expr.t list -> unit - ; visit_LList : 'c -> Literal.t list -> unit - ; visit_LVar : 'c -> string -> unit - ; visit_LeftShift : 'c -> unit - ; visit_LeftShiftL : 'c -> unit - ; visit_LeftShiftF : 'c -> unit - ; visit_IsInt : 'c -> unit - ; visit_ListType : 'c -> unit - ; visit_Lit : 'c -> Literal.t -> unit - ; visit_Loc : 'c -> string -> unit - ; visit_LocalTime : 'c -> unit - ; visit_Logic : 'c -> LCmd.t -> unit - ; visit_LstCat : 'c -> unit - ; visit_LstLen : 'c -> unit - ; visit_LstNth : 'c -> unit - ; visit_LstRepeat : 'c -> unit - ; visit_LstRev : 'c -> unit - ; visit_LstSub : 'c -> Expr.t -> Expr.t -> Expr.t -> unit - ; visit_M_abs : 'c -> unit - ; visit_M_acos : 'c -> unit - ; visit_M_asin : 'c -> unit - ; visit_M_atan : 'c -> unit - ; visit_M_atan2 : 'c -> unit - ; visit_M_ceil : 'c -> unit - ; visit_M_cos : 'c -> unit - ; visit_M_exp : 'c -> unit - ; visit_M_floor : 'c -> unit - ; visit_M_isNaN : 'c -> unit - ; visit_M_log : 'c -> unit - ; visit_M_pow : 'c -> unit - ; visit_M_round : 'c -> unit - ; visit_M_sgn : 'c -> unit - ; visit_M_sin : 'c -> unit - ; visit_M_sqrt : 'c -> unit - ; visit_M_tan : 'c -> unit - ; visit_Macro : 'c -> string -> Expr.t list -> unit - ; visit_MaxSafeInteger : 'c -> unit - ; visit_Max_float : 'c -> unit - ; visit_Min_float : 'c -> unit - ; visit_NOp : 'c -> NOp.t -> Expr.t list -> unit - ; visit_NoneType : 'c -> unit - ; visit_Nono : 'c -> unit - ; visit_Normal : 'c -> unit - ; visit_Not : 'c -> unit - ; visit_Null : 'c -> unit - ; visit_NullType : 'c -> unit - ; visit_Num : 'c -> float -> unit - ; visit_NumberType : 'c -> unit - ; visit_ObjectType : 'c -> unit - ; visit_Or : 'c -> unit - ; visit_PVar : 'c -> string -> unit - ; visit_PhiAssignment : 'c -> (string * Expr.t list) list -> unit - ; visit_Pi : 'c -> unit - ; visit_Pred : 'c -> string -> Expr.t list -> unit - ; visit_Pure : 'c -> Expr.t -> unit - ; visit_Random : 'c -> unit - ; visit_ReturnError : 'c -> unit - ; visit_ReturnNormal : 'c -> unit - ; visit_SL : 'c -> SLCmd.t -> unit - ; visit_SepAssert : 'c -> Asrt.t -> string list -> unit - ; visit_SetDiff : 'c -> unit - ; visit_SetInter : 'c -> unit - ; visit_SetMem : 'c -> unit - ; visit_SetSub : 'c -> unit - ; visit_SetToList : 'c -> unit - ; visit_SetType : 'c -> unit - ; visit_SetUnion : 'c -> unit - ; visit_SignedRightShift : 'c -> unit - ; visit_SignedRightShiftL : 'c -> unit - ; visit_SignedRightShiftF : 'c -> unit - ; visit_Skip : 'c -> unit - ; visit_FreshSVar : 'c -> string -> unit - ; visit_StrCat : 'c -> unit - ; visit_StrLen : 'c -> unit - ; visit_StrLess : 'c -> unit - ; visit_IntToNum : 'c -> unit - ; visit_NumToInt : 'c -> unit - ; visit_StrNth : 'c -> unit - ; visit_String : 'c -> string -> unit - ; visit_StringType : 'c -> unit - ; visit_SymbExec : 'c -> unit - ; visit_ToInt32Op : 'c -> unit - ; visit_ToIntOp : 'c -> unit - ; visit_ToNumberOp : 'c -> unit - ; visit_ToStringOp : 'c -> unit - ; visit_ToUint16Op : 'c -> unit - ; visit_ToUint32Op : 'c -> unit - ; visit_Type : 'c -> Type.t -> unit - ; visit_TypeOf : 'c -> unit - ; visit_TypeType : 'c -> unit - ; visit_Types : 'c -> (Expr.t * Type.t) list -> unit - ; visit_UTCTime : 'c -> unit - ; visit_UnOp : 'c -> UnOp.t -> Expr.t -> unit - ; visit_Undefined : 'c -> unit - ; visit_UndefinedType : 'c -> unit - ; visit_Unfold : - 'c -> - string -> - Expr.t list -> - (string * string) list option -> - bool -> - unit - ; visit_Package : - 'c -> string * Expr.t list -> string * Expr.t list -> unit - ; visit_UnsignedRightShift : 'c -> unit - ; visit_UnsignedRightShiftL : 'c -> unit - ; visit_UnsignedRightShiftF : 'c -> unit - ; visit_assertion_atom : 'c -> Asrt.atom -> unit - ; visit_assertion : 'c -> Asrt.t -> unit - ; visit_bindings : 'c -> string * (string * Expr.t) list -> unit - ; visit_binop : 'c -> BinOp.t -> unit - ; visit_bispec : 'c -> BiSpec.t -> unit - ; visit_cmd : 'c -> 'f Cmd.t -> unit - ; visit_constant : 'c -> Constant.t -> unit - ; visit_expr : 'c -> Expr.t -> unit - ; visit_flag : 'c -> Flag.t -> unit - ; visit_lcmd : 'c -> LCmd.t -> unit - ; visit_lemma : 'c -> Lemma.t -> unit - ; visit_lemma_spec : 'c -> Lemma.spec -> unit - ; visit_literal : 'c -> Literal.t -> unit - ; visit_macro : 'c -> Macro.t -> unit - ; visit_nop : 'c -> NOp.t -> unit - ; visit_pred : 'c -> Pred.t -> unit - ; visit_proc : 'c -> ('d, 'f) Proc.t -> unit - ; visit_single_spec : 'c -> Spec.st -> unit - ; visit_slcmd : 'c -> SLCmd.t -> unit - ; visit_spec : 'c -> Spec.t -> unit - ; visit_typ : 'c -> Type.t -> unit - ; visit_unop : 'c -> UnOp.t -> unit - ; .. > - - method visit_'annot : 'c -> 'd -> unit - method visit_'label : 'c -> 'f -> unit - method visit_ALoc : 'c -> string -> unit - method visit_And : 'c -> unit - method visit_Impl : 'c -> unit - method visit_Apply : 'c -> string -> Expr.t -> 'f option -> unit - method visit_ApplyLem : 'c -> string -> Expr.t list -> string list -> unit - method visit_Arguments : 'c -> string -> unit - method visit_Assert : 'c -> Expr.t -> unit - method visit_Assignment : 'c -> string -> Expr.t -> unit - method visit_Assume : 'c -> Expr.t -> unit - method visit_AssumeType : 'c -> Expr.t -> Type.t -> unit - method visit_BinOp : 'c -> Expr.t -> BinOp.t -> Expr.t -> unit - method visit_BitwiseAnd : 'c -> unit - method visit_BitwiseAndL : 'c -> unit - method visit_BitwiseAndF : 'c -> unit - method visit_BitwiseNot : 'c -> unit - method visit_BitwiseOr : 'c -> unit - method visit_BitwiseOrL : 'c -> unit - method visit_BitwiseOrF : 'c -> unit - method visit_BitwiseXor : 'c -> unit - method visit_BitwiseXorL : 'c -> unit - method visit_BitwiseXorF : 'c -> unit - method visit_Bool : 'c -> bool -> unit - method visit_BooleanType : 'c -> unit - method visit_Branch : 'c -> Expr.t -> unit - method visit_Bug : 'c -> unit - - method visit_Call : - 'c -> - string -> - Expr.t -> - Expr.t list -> - 'f option -> - (string * (string * Expr.t) list) option -> - unit - - method visit_Car : 'c -> unit - method visit_Cdr : 'c -> unit - method visit_Constant : 'c -> Constant.t -> unit - - method visit_ECall : - 'c -> string -> Expr.t -> Expr.t list -> 'f option -> unit - - method visit_EList : 'c -> Expr.t list -> unit - method visit_ESet : 'c -> Expr.t list -> unit - method visit_Exists : 'c -> (string * Type.t option) list -> Expr.t -> unit - method visit_Emp : 'c -> unit - method visit_Empty : 'c -> unit - method visit_EmptyType : 'c -> unit - method visit_Epsilon : 'c -> unit - method visit_Equal : 'c -> unit - method visit_Error : 'c -> unit - method visit_FDiv : 'c -> unit - method visit_FLessThan : 'c -> unit - method visit_FLessThanEqual : 'c -> unit - method visit_FMinus : 'c -> unit - method visit_FMod : 'c -> unit - method visit_FPlus : 'c -> unit - method visit_FTimes : 'c -> unit - method visit_FUnaryMinus : 'c -> unit - method visit_Fail : 'c -> string -> Expr.t list -> unit - - method visit_Fold : - 'c -> - string -> - Expr.t list -> - (string * (string * Expr.t) list) option -> - unit - - method visit_ForAll : 'c -> (string * Type.t option) list -> Expr.t -> unit - method visit_CorePred : 'c -> string -> Expr.t list -> Expr.t list -> unit - - method visit_Wand : - 'c -> string * Expr.t list -> string * Expr.t list -> unit - - method visit_GUnfold : 'c -> string -> unit - method visit_Goto : 'c -> 'f -> unit - method visit_GuardedGoto : 'c -> Expr.t -> 'f -> 'f -> unit - method visit_IDiv : 'c -> unit - method visit_ILessThan : 'c -> unit - method visit_ILessThanEqual : 'c -> unit - method visit_IMinus : 'c -> unit - method visit_IMod : 'c -> unit - method visit_IPlus : 'c -> unit - method visit_ITimes : 'c -> unit - method visit_IUnaryMinus : 'c -> unit - method visit_If : 'c -> Expr.t -> LCmd.t list -> LCmd.t list -> unit - method visit_Int : 'c -> Z.t -> unit - method visit_IntType : 'c -> unit - method visit_Invariant : 'c -> Asrt.t -> string list -> unit - method visit_Consume : 'c -> Asrt.t -> string list -> unit - method visit_Produce : 'c -> Asrt.t -> unit - method visit_LAction : 'c -> string -> string -> Expr.t list -> unit - method visit_LList : 'c -> Literal.t list -> unit - method visit_LVar : 'c -> string -> unit - method visit_LeftShift : 'c -> unit - method visit_LeftShiftL : 'c -> unit - method visit_LeftShiftF : 'c -> unit - method visit_IsInt : 'c -> unit - method visit_ListType : 'c -> unit - method visit_Lit : 'c -> Literal.t -> unit - method visit_Loc : 'c -> string -> unit - method visit_LocalTime : 'c -> unit - method visit_Logic : 'c -> LCmd.t -> unit - method visit_LstCat : 'c -> unit - method visit_LstLen : 'c -> unit - method visit_LstNth : 'c -> unit - method visit_LstRepeat : 'c -> unit - method visit_LstRev : 'c -> unit - method visit_LstSub : 'c -> Expr.t -> Expr.t -> Expr.t -> unit - method visit_M_abs : 'c -> unit - method visit_M_acos : 'c -> unit - method visit_M_asin : 'c -> unit - method visit_M_atan : 'c -> unit - method visit_M_atan2 : 'c -> unit - method visit_M_ceil : 'c -> unit - method visit_M_cos : 'c -> unit - method visit_M_exp : 'c -> unit - method visit_M_floor : 'c -> unit - method visit_M_isNaN : 'c -> unit - method visit_M_log : 'c -> unit - method visit_M_pow : 'c -> unit - method visit_M_round : 'c -> unit - method visit_M_sgn : 'c -> unit - method visit_M_sin : 'c -> unit - method visit_M_sqrt : 'c -> unit - method visit_M_tan : 'c -> unit - method visit_Macro : 'c -> string -> Expr.t list -> unit - method visit_MaxSafeInteger : 'c -> unit - method visit_Max_float : 'c -> unit - method visit_Min_float : 'c -> unit - method visit_NOp : 'c -> NOp.t -> Expr.t list -> unit - method visit_NoneType : 'c -> unit - method visit_Nono : 'c -> unit - method visit_Normal : 'c -> unit - method visit_Not : 'c -> unit - method visit_Null : 'c -> unit - method visit_NullType : 'c -> unit - method visit_Num : 'c -> float -> unit - method visit_NumberType : 'c -> unit - method visit_ObjectType : 'c -> unit - method visit_Or : 'c -> unit - method visit_PVar : 'c -> string -> unit - method visit_PhiAssignment : 'c -> (string * Expr.t list) list -> unit - method visit_Pi : 'c -> unit - method visit_Pred : 'c -> string -> Expr.t list -> unit - method visit_Pure : 'c -> Expr.t -> unit - method visit_Random : 'c -> unit - method visit_ReturnError : 'c -> unit - method visit_ReturnNormal : 'c -> unit - method visit_SL : 'c -> SLCmd.t -> unit - method visit_SepAssert : 'c -> Asrt.t -> string list -> unit - method visit_SetDiff : 'c -> unit - method visit_SetInter : 'c -> unit - method visit_SetMem : 'c -> unit - method visit_SetSub : 'c -> unit - method visit_SetToList : 'c -> unit - method visit_SetType : 'c -> unit - method visit_SetUnion : 'c -> unit - method visit_SignedRightShift : 'c -> unit - method visit_SignedRightShiftL : 'c -> unit - method visit_SignedRightShiftF : 'c -> unit - method visit_Skip : 'c -> unit - method visit_FreshSVar : 'c -> string -> unit - method visit_StrCat : 'c -> unit - method visit_StrLen : 'c -> unit - method visit_StrLess : 'c -> unit - method visit_IntToNum : 'c -> unit - method visit_NumToInt : 'c -> unit - method visit_StrNth : 'c -> unit - method visit_String : 'c -> string -> unit - method visit_StringType : 'c -> unit - method visit_SymbExec : 'c -> unit - method visit_ToInt32Op : 'c -> unit - method visit_ToIntOp : 'c -> unit - method visit_ToNumberOp : 'c -> unit - method visit_ToStringOp : 'c -> unit - method visit_ToUint16Op : 'c -> unit - method visit_ToUint32Op : 'c -> unit - method visit_Type : 'c -> Type.t -> unit - method visit_TypeOf : 'c -> unit - method visit_TypeType : 'c -> unit - method visit_Types : 'c -> (Expr.t * Type.t) list -> unit - method visit_UTCTime : 'c -> unit - method visit_UnOp : 'c -> UnOp.t -> Expr.t -> unit - method visit_Undefined : 'c -> unit - method visit_UndefinedType : 'c -> unit - - method visit_Unfold : - 'c -> - string -> - Expr.t list -> - (string * string) list option -> - bool -> - unit - - method visit_Package : - 'c -> string * Expr.t list -> string * Expr.t list -> unit - - method visit_UnsignedRightShift : 'c -> unit - method visit_UnsignedRightShiftL : 'c -> unit - method visit_UnsignedRightShiftF : 'c -> unit - - method private visit_array : - 'env 'a. ('env -> 'a -> unit) -> 'env -> 'a array -> unit - - method visit_assertion_atom : 'c -> Asrt.atom -> unit - method visit_assertion : 'c -> Asrt.t -> unit - method visit_bindings : 'c -> string * (string * Expr.t) list -> unit - method visit_binop : 'c -> BinOp.t -> unit - method visit_bispec : 'c -> BiSpec.t -> unit - method private visit_bool : 'env. 'env -> bool -> unit - method private visit_bytes : 'env. 'env -> bytes -> unit - method private visit_char : 'env. 'env -> char -> unit - method visit_cmd : 'c -> 'f Cmd.t -> unit - method visit_constant : 'c -> Constant.t -> unit - method visit_expr : 'c -> Expr.t -> unit - method visit_flag : 'c -> Flag.t -> unit - method private visit_float : 'env. 'env -> float -> unit - method private visit_int : 'env. 'env -> int -> unit - method private visit_int32 : 'env. 'env -> int32 -> unit - method private visit_int64 : 'env. 'env -> int64 -> unit - - method private visit_lazy_t : - 'env 'a. ('env -> 'a -> unit) -> 'env -> 'a Lazy.t -> unit - - method visit_lcmd : 'c -> LCmd.t -> unit - method visit_lemma : 'c -> Lemma.t -> unit - method visit_lemma_spec : 'c -> Lemma.spec -> unit - - method private visit_list : - 'env 'a. ('env -> 'a -> unit) -> 'env -> 'a list -> unit - - method visit_literal : 'c -> Literal.t -> unit - method visit_macro : 'c -> Macro.t -> unit - method private visit_nativeint : 'env. 'env -> nativeint -> unit - method visit_nop : 'c -> NOp.t -> unit - - method private visit_option : - 'env 'a. ('env -> 'a -> unit) -> 'env -> 'a option -> unit - - method visit_pred : 'c -> Pred.t -> unit - method visit_proc : 'c -> ('d, 'f) Proc.t -> unit - - method private visit_ref : - 'env 'a. ('env -> 'a -> unit) -> 'env -> 'a ref -> unit - - method private visit_result : - 'env 'a 'e. - ('env -> 'a -> unit) -> - ('env -> 'e -> unit) -> - 'env -> - ('a, 'e) Result.result -> - unit - - method visit_single_spec : 'c -> Spec.st -> unit - method visit_slcmd : 'c -> SLCmd.t -> unit - method visit_spec : 'c -> Spec.t -> unit - method private visit_string : 'env. 'env -> string -> unit - method visit_typ : 'c -> Type.t -> unit - method private visit_unit : 'env. 'env -> unit -> unit - method visit_unop : 'c -> UnOp.t -> unit - end - - module Utils : sig - module SS = Containers.SS - - class list_monoid : object - method private zero : 'b list - method private plus : 'a list -> 'a list -> 'a list - end - - (** Same as list_monoid but uses [rev_append] as [plus]. Will break any order-conservation *) - class non_ordered_list_monoid : object - method private zero : 'b list - method private plus : 'a list -> 'a list -> 'a list - end - - class ss_monoid : object - method private zero : SS.t - method private plus : SS.t -> SS.t -> SS.t - end - - class two_list_monoid : object - method private zero : 'c list * 'd list - - method private plus : - 'a list * 'b list -> 'a list * 'b list -> 'a list * 'b list - end - end -end +module Visitors = Visitors diff --git a/GillianCore/GIL_Syntax/Literal.ml b/GillianCore/GIL_Syntax/Literal.ml index 84b9a987d..ac4e86ddc 100644 --- a/GillianCore/GIL_Syntax/Literal.ml +++ b/GillianCore/GIL_Syntax/Literal.ml @@ -14,6 +14,7 @@ type t = TypeDef__.literal = | Loc of string (** GIL object locations *) | Type of Type.t (** GIL types ({!type:Type.t}) *) | LList of t list (** Lists of GIL literals *) + | LBitvector of (Z.t * int) | Nono [@@deriving ord] @@ -27,6 +28,7 @@ let rec equal la lb = | String sl, String sr | Loc sl, Loc sr -> String.equal sl sr | Type tl, Type tr -> Type.equal tl tr | LList ll, LList lr -> List.for_all2 equal ll lr + | LBitvector (vl, wl), LBitvector (vr, wr) -> Z.equal vl vr && Int.equal wl wr | _ -> false let to_yojson = TypeDef__.literal_to_yojson @@ -47,6 +49,7 @@ let rec pp fmt x = | Loc loc -> Fmt.string fmt loc | Type t -> Fmt.string fmt (Type.str t) | LList ll -> Fmt.pf fmt "{{ %a }}" (Fmt.list ~sep:Fmt.comma pp) ll + | LBitvector (v, w) -> Fmt.pf fmt "0x%sv%d" (Z.format "%x" v) w (** Typing *) let type_of (x : t) : Type.t = @@ -62,6 +65,7 @@ let type_of (x : t) : Type.t = | Loc _ -> ObjectType | Type _ -> TypeType | LList _ -> ListType + | LBitvector (_, w) -> BvType w | Nono -> NoneType let evaluate_constant (c : Constant.t) : t = diff --git a/GillianCore/GIL_Syntax/Type.ml b/GillianCore/GIL_Syntax/Type.ml index f2d11fd04..081eb4196 100644 --- a/GillianCore/GIL_Syntax/Type.ml +++ b/GillianCore/GIL_Syntax/Type.ml @@ -15,6 +15,7 @@ type t = TypeDef__.typ = | ListType (** Type of lists *) | TypeType (** Type of types *) | SetType (** Type of sets *) + | BvType of int [@@deriving yojson, eq, ord, show] (** Print *) @@ -32,6 +33,7 @@ let str (x : t) = | ListType -> "List" | TypeType -> "Type" | SetType -> "Set" + | BvType w -> "BvType_" ^ Int.to_string w module Set = Set.Make (struct type nonrec t = t diff --git a/GillianCore/GIL_Syntax/TypeDef__.ml b/GillianCore/GIL_Syntax/TypeDef__.ml index 17ad77768..313af195b 100644 --- a/GillianCore/GIL_Syntax/TypeDef__.ml +++ b/GillianCore/GIL_Syntax/TypeDef__.ml @@ -1,3 +1,9 @@ +let z_to_yojson z = `String (Z.to_string z) + +let z_of_yojson = function + | `String s -> ( try Ok (Z.of_string s) with Invalid_argument m -> Error m) + | _ -> Error "Invalid yojson for Z" + type constant = | Min_float | Max_float @@ -21,6 +27,7 @@ and typ = | ListType | TypeType | SetType + | BvType of int and literal = | Undefined @@ -28,20 +35,14 @@ and literal = | Empty | Constant of constant | Bool of bool - | Int of - (Z.t - [@opaque] - [@to_yojson fun z -> `String (Z.to_string z)] - [@of_yojson - function - | `String s -> ( - try Ok (Z.of_string s) with Invalid_argument m -> Error m) - | _ -> Error "Invalid yojson for Z"]) + | Int of (Z.t[@opaque] [@to_yojson z_to_yojson] [@of_yojson z_of_yojson]) | Num of float | String of string | Loc of string | Type of typ | LList of literal list + | LBitvector of + ((Z.t[@opaque] [@to_yojson z_to_yojson] [@of_yojson z_of_yojson]) * int) | Nono and binop = @@ -131,11 +132,45 @@ and unop = and nop = LstCat | SetUnion | SetInter +and bvop = + | BVConcat + | BVExtract + | BVNot + | BVAnd + | BVOr + | BVNeg + | BVPlus + | BVMul + | BVUDiv + | BVUrem + | BVShl + | BVLShr + | BVXor + | BVSrem + | BVSub + | BVSignExtend + | BVZeroExtend + | BVSdiv + | BVSmod + | BVAshr + | BVUlt + | BVUleq + | BVSlt + | BVSleq + | BVUMulO + | BVSMulO + | BVNegO + | BVUAddO + | BVSAddO + +and bv_arg = Literal of int | BvExpr of (expr * int) + and expr = | Lit of literal | PVar of string | LVar of string | ALoc of string + | BVExprIntrinsic of bvop * bv_arg list * int option | UnOp of unop * expr | BinOp of expr * binop * expr | LstSub of expr * expr * expr diff --git a/GillianCore/command_line/act_console.ml b/GillianCore/command_line/act_console.ml index eecd8e11a..6c197ba5d 100644 --- a/GillianCore/command_line/act_console.ml +++ b/GillianCore/command_line/act_console.ml @@ -74,6 +74,15 @@ struct Proc.(proc.proc_name, proc.proc_aliases, proc.proc_calls) :: acc) prog.procs [] in + L.verbose (fun m -> + m "%a" + (Fmt.list ~sep:(Fmt.any ",") (fun fm (pname, aliases, calls) -> + Fmt.pf fm "(%s, %a, %a)" pname + (Fmt.list ~sep:(Fmt.any ";") Fmt.string) + aliases + (Fmt.list ~sep:(Fmt.any ";") Fmt.string) + calls)) + fcalls); let call_graph = Call_graph.make () in let fnames = Hashtbl.create (List.length fcalls * 2) in fcalls diff --git a/GillianCore/engine/Abstraction/MP.ml b/GillianCore/engine/Abstraction/MP.ml index ce7e07c7d..3f87b0fdb 100644 --- a/GillianCore/engine/Abstraction/MP.ml +++ b/GillianCore/engine/Abstraction/MP.ml @@ -140,6 +140,10 @@ let rec missing_expr (kb : KB.t) (e : Expr.t) : KB.t list = (* The remaining cases proceed recursively *) | UnOp (_, e) -> f e | BinOp (e1, _, e2) -> join [ e1; e2 ] + | BVExprIntrinsic (_, es, _) -> + join + (let e, _ = Expr.partition_bvargs es in + List.map (fun (x, _) -> x) e) | NOp (_, le) | EList le | ESet le -> join le | LstSub (e1, e2, e3) -> let result = join [ e1; e2; e3 ] in @@ -285,6 +289,8 @@ let rec learn_expr | false, true -> f (BinOp (base_expr, IDiv, e2)) e1) (* TODO: Finish the remaining invertible binary operators *) | BinOp _ -> [] + (* TODO: Finish bit vectors inversions *) + | BVExprIntrinsic (_, _, _) -> [] (* Can we learn anything from Exists? *) | Exists _ | ForAll _ -> [] @@ -441,6 +447,14 @@ let rec simple_ins_formula (kb : KB.t) (pf : Expr.t) : KB.t list = let ins = List.map (fun ins -> KB.diff ins binders) ins_pf in List.map minimise_matchables ins | Lit _ | PVar _ | LVar _ | ALoc _ | LstSub _ | NOp _ | EList _ | ESet _ -> [] + | BVExprIntrinsic (_, es, _) -> + let exprs = Expr.exprs_from_bvargs es in + let lists = List.map simple_ins_expr exprs |> List_utils.list_product in + let sum = + List.map (fun lst -> List.fold_left KB.union KB.empty lst) lists + in + let dedup = List_utils.remove_duplicates sum in + List.map minimise_matchables dedup (** [ins_outs_formula kb pf] returns a list of possible ins-outs pairs for a given formula [pf] under a given knowledge base [kb] *) diff --git a/GillianCore/engine/Abstraction/Normaliser.ml b/GillianCore/engine/Abstraction/Normaliser.ml index 7182ef4f0..8c1ed34fe 100644 --- a/GillianCore/engine/Abstraction/Normaliser.ml +++ b/GillianCore/engine/Abstraction/Normaliser.ml @@ -116,6 +116,8 @@ module Make (SPState : PState.S) = struct SStore.put store pvar (LVar new_lvar); SESubst.put subst (PVar pvar) (LVar new_lvar); LVar new_lvar) + | BVExprIntrinsic (op, es, width) -> + BVExprIntrinsic (op, Expr.map_bv_arg_exprs f es, width) | BinOp (le1, bop, le2) -> ( let nle1 = f le1 in let nle2 = f le2 in @@ -173,7 +175,8 @@ module Make (SPState : PState.S) = struct (Exceptions.Impossible "normalise_lexpr: program variable in normalised \ expression") - | BinOp (_, _, _) | UnOp (_, _) -> UnOp (TypeOf, nle1) + | BinOp (_, _, _) | UnOp (_, _) | BVExprIntrinsic (_, _, _) -> + UnOp (TypeOf, nle1) | Exists _ | ForAll _ -> Lit (Type BooleanType) | EList _ | LstSub _ | NOp (LstCat, _) -> Lit (Type ListType) | NOp (_, _) | ESet _ -> Lit (Type SetType)) diff --git a/GillianCore/engine/BiAbduction/Abductor.ml b/GillianCore/engine/BiAbduction/Abductor.ml index 75add5ab1..1a00796e6 100644 --- a/GillianCore/engine/BiAbduction/Abductor.ml +++ b/GillianCore/engine/BiAbduction/Abductor.ml @@ -391,6 +391,7 @@ module Make let str_concat = String.concat ", " let sort_tests_by_callgraph tests callgraph = + L.verbose (fun m -> m "CG: %a" Call_graph.pp callgraph); let rec aux acc rest_tests = function | [] -> (acc, rest_tests) | name :: rest -> diff --git a/GillianCore/engine/FOLogic/Reduction.ml b/GillianCore/engine/FOLogic/Reduction.ml index e1779fc8e..4d5a4edc0 100644 --- a/GillianCore/engine/FOLogic/Reduction.ml +++ b/GillianCore/engine/FOLogic/Reduction.ml @@ -88,6 +88,8 @@ let rec normalise_list_expressions (le : Expr.t) : Expr.t = | _, Lit (Num _) -> raise (exn "LstNth with float") | le, n -> BinOp (le, LstNth, n)) | BinOp (le1, op, le2) -> BinOp (f le1, op, f le2) + | BVExprIntrinsic (op, es, width) -> + BVExprIntrinsic (op, Expr.map_bv_arg_exprs f es, width) (* Unary Operators **) | UnOp (Car, lst) -> ( match f lst with @@ -884,6 +886,8 @@ and reduce_lexpr_loop Base cases ------------------------- *) | Lit _ | PVar _ | ALoc _ -> le + | BVExprIntrinsic (op, es, width) -> + BVExprIntrinsic (op, Expr.map_bv_arg_exprs f es, width) (* ------------------------- LVar ------------------------- *) diff --git a/GillianCore/engine/FOLogic/typing.ml b/GillianCore/engine/FOLogic/typing.ml index edb1327e2..af5138603 100644 --- a/GillianCore/engine/FOLogic/typing.ml +++ b/GillianCore/engine/FOLogic/typing.ml @@ -117,6 +117,131 @@ module Infer_types_to_gamma = struct | None -> true | Some rt -> tt = rt + and type_bv_args_for_intrinsic + (flag : bool) + (gamma : Type_env.t) + (new_gamma : Type_env.t) + (ty_list : Type.t list) + (es : Expr.bv_arg list) + (lit_handler : int list -> bool) = + let f = f flag gamma new_gamma in + let bv_types, lit_types = + List.partition_map + (function + | Expr.BvExpr (e, w) -> Left (e, w) + | Expr.Literal i -> Right i) + es + in + let bv_types_match = + List.combine bv_types ty_list + |> List.map (fun ((e, w), expected_ty) -> + let act_ty = BvType w in + Type.equal expected_ty act_ty && f e act_ty) + |> List.for_all (fun x -> x) + in + bv_types_match && lit_handler lit_types + + and infer_bv_intrinsic + (flag : bool) + (gamma : Type_env.t) + (new_gamma : Type_env.t) + (op : BVOps.t) + (es : Expr.bv_arg list) + (width : int option) + (tt : Type.t) : bool = + let no_lits_constraint lst = List.length lst = 0 in + let extract_width (arg : Expr.bv_arg) : int option = + match arg with + | Expr.Literal _ -> None + | Expr.BvExpr (_, i) -> Some i + in + let type_bv_pred + (create_types_from_width : int -> t list * (int list -> bool) * t) = + if Option.is_none width then + Option.map create_types_from_width (List.hd es |> extract_width) + else None + in + let opt = + match op with + | BVUlt | BVUleq | BVSlt | BVSleq | BVUMulO | BVSMulO | BVUAddO | BVSAddO + -> + type_bv_pred (fun w -> + ([ BvType w; BvType w ], no_lits_constraint, Type.BooleanType)) + | BVNegO -> + type_bv_pred (fun w -> + ([ BvType w ], no_lits_constraint, Type.BooleanType)) + | BVNot | BVNeg -> + Option.map + (fun w -> ([ BvType w ], no_lits_constraint, BvType w)) + width + | BVOps.BVPlus + | BVOps.BVMul + | BVOps.BVAnd + | BVUDiv + | BVOr + | BVUrem + | BVShl + | BVLShr + | BVXor + | BVSrem + | BVSmod + | BVAshr + | BVSdiv + | BVSub -> + Option.map + (fun w -> ([ BvType w; BvType w ], no_lits_constraint, BvType w)) + width + | BVConcat -> ( + let x1 = List.nth_opt es 0 in + let x2 = List.nth_opt es 1 in + match (x1, x2) with + | Some (Expr.BvExpr (_, w1)), Some (Expr.BvExpr (_, w2)) -> + Some + ([ BvType w1; BvType w2 ], no_lits_constraint, BvType (w1 + w2)) + | _ -> None) + | BVExtract -> ( + let x1 = List.nth_opt es 0 in + let x2 = List.nth_opt es 1 in + let x3 = List.nth_opt es 2 in + match (x1, x2, x3) with + | ( Some (Expr.Literal i0), + Some (Expr.Literal i2), + Some (Expr.BvExpr (_, w)) ) -> + if i0 < w && i2 < w then + Some + ( [ BvType w ], + (fun lts -> + List.length lts = 2 + && List.for_all (fun x -> x < w) lts + && List.hd lts >= List.nth lts 1), + BvType (i0 - i2 + 1) ) + else None + | _ -> None) + | BVZeroExtend | BVSignExtend -> ( + let x1 = List.nth_opt es 0 in + let x2 = List.nth_opt es 1 in + match (x1, x2) with + | Some (Expr.Literal i0), Some (Expr.BvExpr (_, w)) -> + Some + ([ BvType w ], (fun lts -> List.length lts = 1), BvType (w + i0)) + | _ -> None) + in + + Option.map + (fun (type_list, handler, res_ty) -> + let params_typed = + type_bv_args_for_intrinsic flag gamma new_gamma type_list es handler + in + let rets_tped = + Type.equal res_ty + (Option.value ~default:BooleanType + (Option.map (fun w -> BvType w) width)) + && Type.equal tt res_ty + in + rets_tped && params_typed) + opt + |> Option.value ~default:false + and f (flag : bool) (gamma : Type_env.t) @@ -152,6 +277,8 @@ module Infer_types_to_gamma = struct | LstSub (le1, le2, le3) -> tt = ListType && f le1 ListType && f le2 IntType && f le3 IntType | UnOp (op, le) -> infer_unop flag gamma new_gamma op le tt + | BVExprIntrinsic (op, es, width) -> + infer_bv_intrinsic flag gamma new_gamma op es width tt | BinOp (le1, op, le2) -> infer_binop flag gamma new_gamma op le1 le2 tt | Exists (bt, le) | ForAll (bt, le) -> if not (tt = BooleanType) then false @@ -416,6 +543,62 @@ module Type_lexpr = struct (* | _ -> infer_type le NumberType constraints *)) | _, _ -> def_neg + and type_bv_intrinsic + gamma + le + (op : BVOps.t) + (es : Expr.bv_arg list) + (width : int option) = + let f = f gamma in + let infer_type = infer_type gamma in + let arity = + BVOps.( + match op with + | BVNeg | BVNegO | BVNot -> 1 + | BVShl + | BVLShr + | BVUrem + | BVUDiv + | BVXor + | BVSrem + | BVSub + | BVMul + | BVPlus + | BVAnd + | BVOr + | BVConcat + | BVAshr + | BVSdiv + | BVSmod + | BVSignExtend + | BVZeroExtend + | BVUAddO + | BVUlt + | BVUleq + | BVSlt + | BVSleq + | BVUMulO + | BVSMulO + | BVSAddO -> 2 + | BVExtract -> 3) + in + let pars = + List.map + (function + | Expr.BvExpr (e, _) -> + let _, b = f e in + b + | Expr.Literal _ -> true) + es + |> List.for_all (fun x -> x) + in + if pars && arity = List.length es then + infer_type le + (Option.value ~default:Type.BooleanType + (Option.map (fun w -> Type.BvType w) width)) + else (None, false) + (* Both expressions must be typable *) + and type_lstsub gamma le1 le2 le3 = let f = f gamma in let infer_type = infer_type gamma in @@ -467,6 +650,8 @@ module Type_lexpr = struct | Exists (bt, e) | ForAll (bt, e) -> type_quantified_expr gamma le bt e | UnOp (op, e) -> type_unop gamma le op e | BinOp (e1, op, e2) -> type_binop gamma le op e1 e2 + | BVExprIntrinsic (op, es, width) -> + type_bv_intrinsic gamma le op es width | NOp (SetUnion, les) | NOp (SetInter, les) -> let all_typable = typable_list ?target_type:(Some SetType) les in if all_typable then (Some SetType, true) else def_neg diff --git a/GillianCore/engine/concrete_semantics/CExprEval.ml b/GillianCore/engine/concrete_semantics/CExprEval.ml index 95b0ce28c..f960626f0 100644 --- a/GillianCore/engine/concrete_semantics/CExprEval.ml +++ b/GillianCore/engine/concrete_semantics/CExprEval.ml @@ -325,6 +325,10 @@ and evaluate_expr (store : CStore.t) (e : Expr.t) : CVal.M.t = (* if (!verbose) then Fmt.printf "The current store is: \n%s" CStore.pp store; *) raise (Failure err_msg) | Some v -> v) + | BVExprIntrinsic (_, _, _) -> + raise + (Failure + "Bitvector intrinsics currently unsupported in concrete semantics") | BinOp (e1, bop, e2) -> evaluate_binop store bop e1 e2 | UnOp (unop, e) -> evaluate_unop unop (ee e) | NOp (nop, le) -> evaluate_nop nop (List.map ee le) diff --git a/GillianCore/engine/general_semantics/general/g_interpreter.ml b/GillianCore/engine/general_semantics/general/g_interpreter.ml index ea2c36e1e..7b18c18a1 100644 --- a/GillianCore/engine/general_semantics/general/g_interpreter.ml +++ b/GillianCore/engine/general_semantics/general/g_interpreter.ml @@ -857,11 +857,11 @@ struct | Error x -> Right (Exec_err.EState x)) ret in - let b_counter, has_branched = - match successes with - | [] -> (b_counter, false) - | _ -> (b_counter + 1, true) + + let b_counter = + Int.max 0 (List.length successes - 1) + b_counter in + let has_branched = List.length successes > 1 in let spec_name = spec.data.spec_name in let success_confs = successes @@ -931,7 +931,10 @@ struct let args = build_args v_args params in let is_internal_proc proc_name = - (Prog.get_proc_exn prog.prog proc_name).proc_internal + Prog.get_proc prog.prog proc_name + |> Option.map (fun x -> + let open Proc in + x.proc_internal) in let symb_exec_proc = @@ -959,7 +962,7 @@ struct (* In bi-abduction, reached max depth of recursive calls *) | _, _, true -> [] (* In bi-abduction, recursive call *) - | true, false, _ -> symb_exec_proc () + | true, Some false, _ -> symb_exec_proc () (* TODO: When JS internals work | true, false, false when List.length @@ -2053,6 +2056,12 @@ struct if Hashtbl.mem prog.specs pid then Some conf else None) on_hold in + let () = + L.( + verbose (fun m -> + m "Resuming size of: %d total size of: %d" + (List.length hold_confs) (List.length on_hold))) + in continue_or_pause hold_confs (fun ?selector () -> eval_step ret_fun false prog results [] hold_confs selector [])) @@ -2226,7 +2235,9 @@ struct } in debug_log conf rest_confs; - + L.( + verbose (fun m -> + m "Evaluating a conf with holds %d" (List.length on_hold))); match conf with | None -> Handle_conf.none eval_step_state | Some (ConfCont ({ branch_count; _ } as c)) diff --git a/GillianCore/engine/symbolic_semantics/SState.ml b/GillianCore/engine/symbolic_semantics/SState.ml index f1bbf84b4..b783ee7e4 100644 --- a/GillianCore/engine/symbolic_semantics/SState.ml +++ b/GillianCore/engine/symbolic_semantics/SState.ml @@ -243,6 +243,15 @@ module Make (SMemory : SMemory.S) : | Some v -> v | None -> raise (Internal_State_Error ([ EVar x ], state))) | BinOp (e1, op, e2) -> BinOp (f e1, op, f e2) + | BVExprIntrinsic (op, es, width) -> + BVExprIntrinsic + ( op, + List.map + (function + | Expr.Literal i -> Expr.Literal i + | Expr.BvExpr (e, w) -> Expr.BvExpr (f e, w)) + es, + width ) (* Unary operators *) | UnOp (op, e) -> UnOp (op, f e) (* Lists, sets, n-ary operators *) diff --git a/GillianCore/gil_parser/GIL_Lexer.mll b/GillianCore/gil_parser/GIL_Lexer.mll index 1b3937de2..029c17f7f 100644 --- a/GillianCore/gil_parser/GIL_Lexer.mll +++ b/GillianCore/gil_parser/GIL_Lexer.mll @@ -22,6 +22,7 @@ "List", GIL_Parser.LISTTYPELIT; "Type", GIL_Parser.TYPETYPELIT; "Set", GIL_Parser.SETTYPELIT; + "Bitvector", GIL_Parser.BVTYPELIT; (* Literals *) "undefined", GIL_Parser.UNDEFINED; @@ -133,6 +134,7 @@ "normal", GIL_Parser.NORMAL; "error", GIL_Parser.ERROR; "fail", GIL_Parser.FAIL; + "bug", GIL_Parser.BUG; "trusted", GIL_Parser.TRUSTED; (* Procedure definition keywords *) @@ -145,11 +147,13 @@ } let digit = ['0'-'9'] +let hexdigit = ['0'-'9''a'-'f''A'-'F'] let letter = ['a'-'z''A'-'Z'] let identifier = letter(letter|digit|'_')* let float = '-'? digit+ ('.' digit*)? let int = '-'? digit+ 'i' +let bv = "0x" hexdigit+ 'v' digit+ let var2 = "_pvar_" (letter|digit|'_')* let lvar = '#' (letter|digit|'_'|'$')* @@ -171,6 +175,36 @@ rule read = parse | "{{" { GIL_Parser.LSTOPEN } | "}}" { GIL_Parser.LSTCLOSE } + (* Bv intrinsics *) + | "concat" { GIL_Parser.BVCONCAT } + | "extract" { GIL_Parser.BVEXTRACT } + | "bvnot" { GIL_Parser.BVNOT } + | "bvand" { GIL_Parser.BVAND } + | "bvor" { GIL_Parser.BVOR } + | "bvneg" { GIL_Parser.BVNEG } + | "bvadd" { GIL_Parser.BVADD } + | "bvmul" { GIL_Parser.BVMUL } + | "bvudiv" { GIL_Parser.BVUDIV } + | "bvurem" { GIL_Parser.BVUREM } + | "bvnego" { GIL_Parser.BVNEGO } + | "bvuaddo" { GIL_Parser.BVUADDO } + | "bvsaddo" { GIL_Parser.BVSADDO } + | "bvumulo" { GIL_Parser.BVUMULO } + | "bvsmulo" { GIL_Parser.BVSMULO } + | "bvshl" { GIL_Parser.BVSHL } + | "bvlshr" { GIL_Parser.BVLSHR } + | "bvxor" {GIL_Parser.BVXOR } + | "bvsrem" { GIL_Parser.BVSREM } + | "bvsub" { GIL_Parser.BVSUB } + | "bvult" { GIL_Parser.BVULT } + | "bvuleq" { GIL_Parser.BVULEQ } + | "bvslt" { GIL_Parser.BVSLT } + | "bvsleq" { GIL_Parser.BVSLEQ } + | "bvsext" { GIL_Parser.BVSIGNEXTEND } + | "bvzext" { GIL_Parser.BVZEROEXTEND } + | "bvsdiv" { GIL_Parser.BVSDIV } + | "bvsmod" { GIL_Parser.BVSMOD } + | "bvashr" { GIL_Parser.BVASHR } (* Constants *) | "$$min_float" { GIL_Parser.MIN_FLOAT } | "$$max_float" { GIL_Parser.MAX_FLOAT } @@ -281,6 +315,11 @@ rule read = parse let s_n = String.sub s 0 ((String.length s) - 1) in let n = Z.of_string s_n in GIL_Parser.INTEGER n } + | bv { let s = Lexing.lexeme lexbuf in + let l = String.split_on_char 'v' s in + let n = Z.of_string (List.nth l 0) in + let w = int_of_string (List.nth l 1) in + GIL_Parser.BITVECTOR (n, w) } | float { let n = float_of_string (Lexing.lexeme lexbuf) in GIL_Parser.FLOAT n } | '"' { read_string (Buffer.create 32) lexbuf } diff --git a/GillianCore/gil_parser/GIL_Parser.mly b/GillianCore/gil_parser/GIL_Parser.mly index a59c1572f..bed071d5a 100644 --- a/GillianCore/gil_parser/GIL_Parser.mly +++ b/GillianCore/gil_parser/GIL_Parser.mly @@ -21,6 +21,39 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" %token LISTTYPELIT %token TYPETYPELIT %token SETTYPELIT +%token BVTYPELIT + +(* BV intrinsics *) +%token BVCONCAT +%token BVEXTRACT +%token BVNOT +%token BVAND +%token BVOR +%token BVNEG +%token BVADD +%token BVMUL +%token BVUDIV +%token BVUREM +%token BVNEGO +%token BVUADDO +%token BVSADDO +%token BVUMULO +%token BVSMULO +%token BVSHL +%token BVLSHR +%token BVULT +%token BVXOR +%token BVSREM +%token BVSUB +%token BVULEQ +%token BVSLT +%token BVSLEQ +%token BVSIGNEXTEND +%token BVZEROEXTEND +%token BVSDIV +%token BVSMOD +%token BVASHR + (* Constants *) %token MIN_FLOAT %token MAX_FLOAT @@ -36,6 +69,7 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" %token FALSE %token FLOAT %token INTEGER +%token BITVECTOR %token NAN %token INFINITY %token STRING @@ -197,6 +231,7 @@ let normalised_lvar_r = Str.regexp "##NORMALISED_LVAR" %token VARIANT %token NORMAL %token ERROR +%token BUG %token FAIL %token TRUSTED (* Procedure definition keywords *) @@ -348,6 +383,43 @@ pred_head_target: (********* Expressions *********) (*******************************) + +gbvpred: +| BVULT { BVOps.BVUlt } +| BVULEQ { BVOps.BVUleq } +| BVSLT { BVOps.BVSlt } +| BVSLEQ { BVOps.BVSleq } +| BVUMULO { BVOps.BVUMulO } +| BVSMULO { BVOps.BVSMulO } +| BVNEGO { BVOps.BVNegO } +| BVUADDO { BVOps.BVUAddO } +| BVSADDO { BVOps.BVSAddO } + +gbvintrinsic: +| BVCONCAT { BVOps.BVConcat } +| BVEXTRACT { BVOps.BVExtract } +| BVNOT { BVOps.BVNot } +| BVAND { BVOps.BVAnd } +| BVOR { BVOps.BVOr } +| BVNEG { BVOps.BVNeg } +| BVADD { BVOps.BVPlus } +| BVMUL { BVOps.BVMul } +| BVUDIV { BVOps.BVUDiv } +| BVUREM { BVOps.BVUrem } +| BVSHL { BVOps.BVShl } +| BVLSHR { BVOps.BVLShr } +| BVXOR { BVOps.BVXor } +| BVSREM { BVOps.BVSrem } +| BVSUB { BVOps.BVSub } +| BVSIGNEXTEND { BVOps.BVSignExtend } +| BVZEROEXTEND { BVOps.BVZeroExtend } +| BVSDIV { BVOps.BVSdiv } +| BVSMOD { BVOps.BVSmod } +| BVASHR { BVOps.BVAshr } + +bv_arg_target: + | BVTYPELIT LBRACE e=expr_target COMMA width=INTEGER RBRACE { Expr.BvExpr(e,Z.to_int width) } + | n = INTEGER { Expr.Literal(Z.to_int n) } atomic_expr_target: (* literal *) | lit=lit_target { Expr.Lit lit } @@ -527,7 +599,11 @@ implication_expr: { Expr.BinOp (e1, Impl, e2) } expr_target: - implication_expr { $1 } + | itname=gbvintrinsic; LBRACE; es=separated_list(COMMA, bv_arg_target); COLON; width=INTEGER ; RBRACE + { Expr.BVExprIntrinsic(itname, es, Some (Z.to_int width)) } + | itname=gbvpred; LBRACE; es=separated_list(COMMA, bv_arg_target); COLON ; RBRACE + { Expr.BVExprIntrinsic(itname, es, None) } + | implication_expr { $1 } ; top_level_expr_target: @@ -675,6 +751,7 @@ gcmd_with_annot: let annot : Annot.t = Annot.make_basic ~origin_loc () in annot, cmd }; + (*** GIL commands ***) gcmd_target: (* skip *) @@ -763,6 +840,7 @@ g_mult_spec_line: g_spec_kind: | NORMAL { Flag.Normal } | ERROR { Flag.Error } + | BUG { Flag.Bug } g_sspec_target: (* {trusted} [spec_name: #bla, #ble, #bli] [[ .... ]] [[ .... ]] flag *) @@ -1149,6 +1227,7 @@ lit_target: | FALSE { Literal.Bool false } | FLOAT { Literal.Num $1 } | n = INTEGER { Literal.Int n } + | t = BITVECTOR { Literal.LBitvector t } | NAN { Literal.Num nan } | INFINITY { Literal.Num infinity } | STRING { Literal.String $1 } @@ -1225,4 +1304,5 @@ type_target: | LISTTYPELIT { Type.ListType } | TYPETYPELIT { Type.TypeType } | SETTYPELIT { Type.SetType } + | BVTYPELIT LBRACE width=INTEGER RBRACE {Type.BvType(Z.to_int width)} ; diff --git a/GillianCore/gil_parser/gil_parsing.ml b/GillianCore/gil_parser/gil_parsing.ml index 5989e5b63..499234375 100644 --- a/GillianCore/gil_parser/gil_parsing.ml +++ b/GillianCore/gil_parser/gil_parsing.ml @@ -57,6 +57,13 @@ module Make (Annot : Annot.S) = struct in { labeled_prog; init_data } + let get_callees (proc : ('a, 'b) Proc.t) : string list = + Array.to_list proc.proc_body + |> List.filter_map (function + | _, _, Cmd.Call (_, Expr.Lit (Literal.String callee), _, _, _) -> + Some callee + | _ -> None) + let trans_procs procs path internal_file = let procs' = Hashtbl.create Config.small_tbl_size in let () = @@ -67,7 +74,9 @@ module Make (Annot : Annot.S) = struct else Some path in let proc_internal = proc.proc_internal || internal_file in - Hashtbl.add procs' name { proc with proc_source_path; proc_internal }) + let proc_calls = get_callees proc in + Hashtbl.add procs' name + { proc with proc_source_path; proc_internal; proc_calls }) procs in procs' diff --git a/GillianCore/smt/smt.ml b/GillianCore/smt/smt.ml index eb38bbd20..4ac0d05af 100644 --- a/GillianCore/smt/smt.ml +++ b/GillianCore/smt/smt.ml @@ -15,7 +15,8 @@ let z3_config = ("timeout", "30000"); ] -let solver = new_solver z3 +let _debug_z3 = { z3 with log = printf_log } +let solver = new_solver _debug_z3 let cmd s = ack_command solver s let () = z3_config |> List.iter (fun (k, v) -> cmd (set_option (":" ^ k) v)) @@ -24,6 +25,7 @@ exception SMT_unknown let pp_sexp = Sexplib.Sexp.pp_hum let init_decls : sexp list ref = ref [] let builtin_funcs : sexp list ref = ref [] +let defined_bv_variants : int list ref = ref [] let sanitize_identifier = let pattern = Str.regexp "#" in @@ -141,7 +143,7 @@ let declare_recognizer ~name ~constructor ~typ = t_bool (list [ atom "_"; atom "is"; atom constructor ] <| atom "x") -let mk_datatype name type_params (variants : (module Variant.S) list) = +let create_datatype name type_params (variants : (module Variant.S) list) = let constructors, recognizer_defs = variants |> List.map (fun v -> @@ -155,6 +157,10 @@ let mk_datatype name type_params (variants : (module Variant.S) list) = |> List.split in let decl = declare_datatype name type_params constructors in + (decl, recognizer_defs) + +let mk_datatype name type_params (variants : (module Variant.S) list) = + let decl, recognizer_defs = create_datatype name type_params variants in let () = init_decls := recognizer_defs @ (decl :: !init_decls) in atom name @@ -177,6 +183,7 @@ module Type_operations = struct module List = (val nul "ListType" : Nullary) module Type = (val nul "TypeType" : Nullary) module Set = (val nul "SetType" : Nullary) + module Bv = (val un "BvType" "bvWidth" t_int : Unary) let t_gil_type = mk_datatype "GIL_Type" [] @@ -193,17 +200,56 @@ module Type_operations = struct (module List : Variant.S); (module Type : Variant.S); (module Set : Variant.S); + (module Bv : Variant.S); ] end let t_gil_type = Type_operations.t_gil_type +module BvLiteral = struct + let lit_name = "GIL_BVLiteral" + let t_lit_name = atom lit_name + let name (width : int) = Printf.sprintf "Bv_%d" width + let accessor (width : int) = Printf.sprintf "bv_under_value_%d" width + + let make_mod (width : int) = + Variant.un (name width) (accessor width) (t_bits width) + + let get_mods _ = + let needed_widths = !defined_bv_variants |> List.sort_uniq Int.compare in + L.verbose (fun m -> + m "BV variants: %a" (Fmt.list ~sep:Fmt.sp Fmt.int) needed_widths); + List.map + (fun x -> + let module S = (val make_mod x) in + (x, (module S : Variant.Unary))) + needed_widths + + let make_lit_recognizers _ : (int * string) list = + let mods = get_mods () in + List.map (fun (x, (module S : Variant.Unary)) -> (x, S.recognizer)) mods + + let decl_data_type _ = + let mods = get_mods () in + let mods_with_nop_constructor = + let module M = (val Variant.nul "BVNoop") in + (module M : Variant.S) + :: List.map + (fun (x, (module S : Variant.Unary)) -> (module S : Variant.S)) + mods + in + + create_datatype lit_name [] mods_with_nop_constructor +end + module Lit_operations = struct open Variant let gil_literal_name = "GIL_Literal" let t_gil_literal = atom gil_literal_name + module L = List + module T = Type module Undefined = (val nul "Undefined" : Nullary) module Null = (val nul "Null" : Nullary) module Empty = (val nul "Empty" : Nullary) @@ -214,8 +260,16 @@ module Lit_operations = struct module Loc = (val un "Loc" "locValue" t_int : Unary) module Type = (val un "Type" "tValue" t_gil_type : Unary) module List = (val un "List" "listValue" (t_seq t_gil_literal) : Unary) + module Bv = (val un "Bv" "bv_value" BvLiteral.t_lit_name : Unary) module None = (val nul "None" : Nullary) + let bv_recognizer_name w = Printf.sprintf "GIL_BVRecognizer_%d" w + let recog_bv w arg = atom (bv_recognizer_name w) <| arg + + let bv_guards _ = + let mods = BvLiteral.get_mods () in + L.map (fun (x, (module S : Variant.Unary)) -> (recog_bv x, T.BvType x)) mods + let _ = mk_datatype gil_literal_name [] [ @@ -230,7 +284,25 @@ module Lit_operations = struct (module Type : Variant.S); (module List : Variant.S); (module None : Variant.S); + (module Bv : Variant.S); ] + + let declare_bv_recognizers _ = + let mods = BvLiteral.get_mods () in + L.map + (fun (x, (module S : Variant.Unary)) -> + let name_of_candidate = "x" in + let candidate = atom name_of_candidate in + define_fun (bv_recognizer_name x) + [ (name_of_candidate, atom gil_literal_name) ] + t_bool + (list + [ + atom "and"; + Bv.recognize candidate; + S.recognize (Bv.access candidate); + ])) + mods end let t_gil_literal = Lit_operations.t_gil_literal @@ -303,6 +375,9 @@ let encode_type (t : Type.t) = | ListType -> Type_operations.List.construct | TypeType -> Type_operations.Type.construct | SetType -> Type_operations.Set.construct + | BvType w -> + defined_bv_variants := w :: !defined_bv_variants; + Type_operations.Bv.construct (nat_k w) with _ -> Fmt.failwith "DEATH: encode_type with arg: %a" Type.pp t module Encoding = struct @@ -322,6 +397,7 @@ module Encoding = struct | UndefinedType | NoneType | EmptyType | NullType -> t_gil_literal | SetType -> t_gil_literal_set | TypeType -> t_gil_type + | BvType width -> t_bits width type t = { consts : (string * sexp) Hashset.t; [@default Hashset.empty ()] @@ -347,7 +423,12 @@ module Encoding = struct let null_encoding = make ~kind:Simple_wrapped Lit_operations.Null.construct let empty_encoding = make ~kind:Simple_wrapped Lit_operations.Empty.construct let none_encoding = make ~kind:Simple_wrapped Lit_operations.None.construct - let native typ = make ~kind:(Native typ) + + let native typ = + (match typ with + | Type.BvType width -> defined_bv_variants := width :: !defined_bv_variants + | _ -> ()); + make ~kind:(Native typ) let make_const ?extra_asrts ~typ kind const = let const = sanitize_identifier const in @@ -401,6 +482,9 @@ module Encoding = struct | TypeType -> Type.construct | BooleanType -> Bool.construct | ListType -> List.construct + | BvType w -> + let module M = (val BvLiteral.make_mod w) in + fun x -> Bv.construct (M.construct x) | UndefinedType | NullType | EmptyType | NoneType | SetType -> Fmt.failwith "Cannot simple-wrap value of type %s" (Gil_syntax.Type.str typ) @@ -419,6 +503,14 @@ module Encoding = struct let get_bool = get_native ~accessor:Lit_operations.Bool.access let get_list = get_native ~accessor:Lit_operations.List.access + let get_bv (width : int) (e : t) : sexp = + get_native + ~accessor:(fun x -> + let m = BvLiteral.make_mod width in + let module M = (val m : Variant.Unary) in + Lit_operations.Bv.access x |> M.access) + e + let get_set { kind; expr; _ } = match kind with | Native SetType -> expr @@ -430,7 +522,7 @@ end let typeof_simple e = let open Type in - let guards = + let guards_non_bv = Lit_operations. [ (Null.recognize, NullType); @@ -446,6 +538,8 @@ let typeof_simple e = (List.recognize, ListType); ] in + let guards_bv = Lit_operations.bv_guards () in + let guards = guards_non_bv @ guards_bv in List.fold_left (fun acc (guard, typ) -> ite (guard e) (encode_type typ) acc) (encode_type UndefinedType) @@ -509,6 +603,7 @@ let rec encode_lit (lit : Literal.t) : Encoding.t = | Num n -> real_k (Q.of_float n) >- NumberType | String s -> encode_string s >- StringType | Loc l -> encode_string l >- ObjectType + | LBitvector (v, w) -> bv_k w v >- BvType w | Type t -> encode_type t >- TypeType | LList lits -> let args = List.map (fun lit -> simple_wrap (encode_lit lit)) lits in @@ -721,6 +816,53 @@ let encode_quantified_expr let expr = mk_quant quantified_vars encoded_assertion in native ~consts ~extra_asrts BooleanType expr +let encode_bvop + (op : BVOps.t) + (literals : int list) + (bvs : sexp list) + (width : int option) : Encoding.t = + let unop_encode (f : sexp -> sexp) = f (List.hd bvs) in + let binop_encode (f : sexp -> sexp -> sexp) = + f (List.hd bvs) (List.nth bvs 1) + in + let sexpr = + match op with + | BVOps.BVNeg -> unop_encode bv_neg + | BVOps.BVNot -> unop_encode bv_not + | BVOps.BVPlus -> binop_encode bv_add + | BVOps.BVAnd -> binop_encode bv_and + | BVOps.BVOr -> binop_encode bv_or + | BVOps.BVMul -> binop_encode bv_mul + | BVOps.BVUDiv -> binop_encode bv_udiv + | BVOps.BVUrem -> binop_encode bv_urem + | BVOps.BVShl -> binop_encode bv_shl + | BVOps.BVLShr -> binop_encode bv_lshr + | BVConcat -> binop_encode bv_concat + | BVXor -> binop_encode bv_xor + | BVSrem -> binop_encode bv_srem + | BVSub -> binop_encode bv_sub + | BVSdiv -> binop_encode bv_sdiv + | BVAshr -> binop_encode bv_ashr + | BVSmod -> binop_encode bv_smod + | BVZeroExtend -> bv_zero_extend (List.hd literals) (List.hd bvs) + | BVSignExtend -> bv_sign_extend (List.hd literals) (List.hd bvs) + | BVExtract -> + bv_extract (List.hd literals) (List.nth literals 1) (List.hd bvs) + | BVOps.BVUlt -> binop_encode bv_ult + | BVOps.BVUleq -> binop_encode bv_uleq + | BVOps.BVSlt -> binop_encode bv_slt + | BVOps.BVSleq -> binop_encode bv_sleq + | BVOps.BVNegO -> bv_nego (List.hd bvs) + | BVOps.BVUMulO -> binop_encode bv_umulo + | BVOps.BVSMulO -> binop_encode bv_smulo + | BVOps.BVUAddO -> binop_encode bv_uaddo + | BVOps.BVSAddO -> binop_encode bv_saddo + in + Encoding.native + (Option.map (fun w -> Gil_syntax.Type.BvType w) width + |> Option.value ~default:Gil_syntax.Type.BooleanType) + sexpr + let rec encode_logical_expression ~(gamma : typenv) ~(llen_lvars : SS.t) @@ -744,6 +886,12 @@ let rec encode_logical_expression | PVar _ -> failwith "HORROR: Program variable in pure formula" | UnOp (op, le) -> encode_unop ~llen_lvars ~e:le op (f le) | BinOp (le1, op, le2) -> encode_binop op (f le1) (f le2) + | BVExprIntrinsic (op, es, width) -> + let extracted_bvs, extracted_lits = Expr.partition_bvargs es in + let widths = List.map (fun (_, w) -> w) extracted_bvs in + let>-- les = List.map (fun (e, _) -> f e) extracted_bvs in + List.combine les widths |> List.map (fun (encoded, w) -> get_bv w encoded) + |> fun encodings -> encode_bvop op extracted_lits encodings width | NOp (SetUnion, les) -> let>-- les = List.map f les in les |> List.map get_set |> set_union' Z3 >- SetType @@ -923,6 +1071,25 @@ let reset_solver () = let () = cmd (push 1) in () +let perform_decls _ = + let bv_decl, bv_recogs = BvLiteral.decl_data_type () in + let bv_refined_recogs = Lit_operations.declare_bv_recognizers () in + let () = + L.verbose (fun m -> m "Performing decls %a" Sexplib.Sexp.pp_hum bv_decl) + in + let () = + L.verbose (fun m -> + m "Performing recogs %a" + (Fmt.list ~sep:Fmt.sp Sexplib.Sexp.pp_hum) + bv_recogs) + in + let decls = List.rev !init_decls in + (bv_decl :: bv_recogs) @ decls @ bv_refined_recogs + |> List.iter (fun decl -> + L.verbose (fun m -> + m "Performing decl %s" (Sexplib.Sexp.to_string decl)); + cmd decl) + let exec_sat' (fs : Expr.Set.t) (gamma : typenv) : sexp option = let () = L.verbose (fun m -> @@ -932,7 +1099,8 @@ let exec_sat' (fs : Expr.Set.t) (gamma : typenv) : sexp option = in let () = reset_solver () in let encoded_assertions = encode_assertions fs gamma in - let () = if !Config.dump_smt then Dump.dump fs gamma encoded_assertions in + let () = perform_decls () in + let () = if true then Dump.dump fs gamma encoded_assertions in let () = List.iter cmd !builtin_funcs in let () = List.iter cmd encoded_assertions in L.verbose (fun fmt -> fmt "Reached SMT."); @@ -1011,6 +1179,7 @@ let lift_model (subst_update : string -> Expr.t -> unit) (target_vars : Expr.Set.t) : unit = let () = reset_solver () in + perform_decls (); let model_eval = (model_eval' solver model).eval [] in let get_val x = @@ -1067,7 +1236,4 @@ let lift_model in v |> Option.iter (fun v -> subst_update x (Expr.Lit v))) -let () = - let decls = List.rev !init_decls in - let () = decls |> List.iter cmd in - cmd (push 1) +let () = cmd (push 1) diff --git a/GillianCore/utils/list_utils.ml b/GillianCore/utils/list_utils.ml index 4c3a2b1b9..e591a1af0 100644 --- a/GillianCore/utils/list_utils.ml +++ b/GillianCore/utils/list_utils.ml @@ -251,3 +251,9 @@ let[@tail_mod_cons] rec assoc_replace k v = function | [] -> [ (k, v) ] | (k', _) :: r when k = k' -> (k, v) :: r | x :: r -> x :: assoc_replace k v r + +let rec zip (l1 : 'a list) (l2 : 'b list) : ('a * 'b) list = + match (l1, l2) with + | h1 :: t1, h2 :: t2 -> (h1, h2) :: zip t1 t2 + | [], _ -> [] + | _, [] -> [] diff --git a/dune b/dune index a63b94de7..878996131 100644 --- a/dune +++ b/dune @@ -3,6 +3,7 @@ GillianCore Gillian-JS Gillian-C + Gillian-LLVM Gillian-C2 transformers Gillian-Alcotest-Runner @@ -14,4 +15,4 @@ (:standard -O3))) (_ (flags - (:standard -w -67 -w -69 -w -70)))) + (:standard -w -27 -w -32 -w -33 -w -37 -w -39 -w -67 -w -69 -w -70)))) diff --git a/dune-project b/dune-project index b82e873b2..f8968cfba 100644 --- a/dune-project +++ b/dune-project @@ -93,6 +93,17 @@ dune-site printbox-text)) +(package + (name gillian-llvm) + (sites + (share runtime)) + (synopsis "Gillian instantiation for LLVM") + (depends + (gillian + (= :version)) + dune-site + printbox-text)) + (package (name wisl) (sites diff --git a/gillian-llvm.opam b/gillian-llvm.opam new file mode 100644 index 000000000..a23f9fe16 --- /dev/null +++ b/gillian-llvm.opam @@ -0,0 +1,32 @@ +# This file is generated by dune, edit dune-project instead +opam-version: "2.0" +synopsis: "Gillian instantiation for LLVM" +maintainer: ["The Gillian Team"] +authors: ["The Gillian Team"] +license: "BSD-3-Clause" +homepage: "https://github.com/GillianPlatform/Gillian" +bug-reports: "https://github.com/GillianPlatform/Gillian/issues" +depends: [ + "dune" {>= "3.16"} + "gillian" {= version} + "dune-site" + "printbox-text" + "odoc" {with-doc} +] +build: [ + ["dune" "subst"] {dev} + [ + "dune" + "build" + "-p" + name + "-j" + jobs + "--promote-install-files=false" + "@install" + "@runtest" {with-test} + "@doc" {with-doc} + ] + ["dune" "install" "-p" name "--create-install-files" name] +] +dev-repo: "git+https://github.com/GillianPlatform/Gillian.git" diff --git a/gillian.opam b/gillian.opam index efa697a45..4a2b2bce7 100644 --- a/gillian.opam +++ b/gillian.opam @@ -44,5 +44,5 @@ build: [ ] dev-repo: "git+https://github.com/GillianPlatform/Gillian.git" pin-depends: [ - "simple_smt.~dev" "git+https://github.com/NatKarmios/simple-smt-ocaml#94a891e7fb552ecaff57bbe5b9f4e4e5c1aed145" + "simple_smt.~dev" "git+https://github.com/trail-of-forks/simple-smt-ocaml#8327fce05f8389ac9e3150d4e69a29b7fe6cc899" ] \ No newline at end of file diff --git a/gillian.opam.template b/gillian.opam.template index efa3a385b..b1d1a63a9 100644 --- a/gillian.opam.template +++ b/gillian.opam.template @@ -1,3 +1,3 @@ pin-depends: [ - "simple_smt.~dev" "git+https://github.com/NatKarmios/simple-smt-ocaml#94a891e7fb552ecaff57bbe5b9f4e4e5c1aed145" + "simple_smt.~dev" "git+https://github.com/trail-of-forks/simple-smt-ocaml#8327fce05f8389ac9e3150d4e69a29b7fe6cc899" ] \ No newline at end of file diff --git a/transformers/lib/states/PMap.ml b/transformers/lib/states/PMap.ml index 96dce274d..7c2951aac 100644 --- a/transformers/lib/states/PMap.ml +++ b/transformers/lib/states/PMap.ml @@ -184,7 +184,9 @@ struct let open Delayed.Syntax in let* idx_opt = I.validate_index idx in match idx_opt with - | None -> DR.error (InvalidIndexValue idx) + | None -> + Logging.tmi (fun m -> m "Invalid index value %a in get" Expr.pp idx); + DR.error (InvalidIndexValue idx) | Some idx' -> ( let* res = I.get h idx' in match (res, d) with @@ -219,11 +221,16 @@ struct match (action, args) with | SubAction _, [] -> failwith "Missing index for sub-action" | SubAction action, idx :: args -> + Logging.tmi (fun m -> + m "Executing action in Make %s with args %a and idx %a" + (S.action_to_str action) (Fmt.list Expr.pp) args Expr.pp idx); let** s, idx', ss = get s idx in let* () = Delayed.return ~learned:[ Expr.Infix.(idx == idx') ] () in let+ r = S.execute_action action ss args in let ( let+^ ) = lifting_err idx idx' in let+^ ss', v = r in + Logging.verbose (fun fmt -> + fmt "AFTER EXECUTING ACTION WITH: %a" S.pp ss'); let s' = set ~idx ~idx' ss' s in (s', idx' :: v) | Alloc, args -> @@ -475,10 +482,15 @@ struct match (action, args) with | SubAction _, [] -> failwith "Missing index for sub-action" | SubAction action, idx :: args -> + Logging.tmi (fun m -> + m "Executing action %s with args %a and idx %a" + (S.action_to_str action) (Fmt.list Expr.pp) args Expr.pp idx); let** s, idx', ss = get s idx in let+ r = S.execute_action action ss args in let ( let+^ ) = lifting_err idx idx' in let+^ ss', v = r in + Logging.verbose (fun fmt -> + fmt "AFTER EXECUTING ACTION WITH: %a" S.pp ss'); let s' = set ~idx ~idx' ss' s in (s', idx' :: v) | Alloc, args ->