diff --git a/conf/svcomp-ghost.json b/conf/svcomp-ghost.json new file mode 100644 index 0000000000..d1b4171b2b --- /dev/null +++ b/conf/svcomp-ghost.json @@ -0,0 +1,139 @@ +{ + "ana": { + "sv-comp": { + "enabled": true, + "functions": true + }, + "int": { + "def_exc": true, + "enums": false, + "interval": true + }, + "float": { + "interval": true, + "evaluate_math_functions": true + }, + "activated": [ + "base", + "threadid", + "threadflag", + "threadreturn", + "mallocWrapper", + "mutexEvents", + "mutex", + "access", + "race", + "escape", + "expRelation", + "mhp", + "assert", + "var_eq", + "symb_locks", + "region", + "thread", + "threadJoins", + "abortUnless", + "mutexGhosts", + "pthreadMutexType" + ], + "path_sens": [ + "mutex", + "malloc_null", + "uninit", + "expsplit", + "activeSetjmp", + "memLeak", + "threadflag" + ], + "context": { + "widen": false + }, + "base": { + "arrays": { + "domain": "partitioned" + }, + "invariant": { + "local": false, + "global": true + } + }, + "relation": { + "invariant": { + "local": false, + "global": true, + "one-var": false + } + }, + "apron": { + "invariant": { + "diff-box": true + } + }, + "var_eq": { + "invariant": { + "enabled": false + } + }, + "race": { + "free": false, + "call": false + }, + "autotune": { + "enabled": true, + "activated": [ + "singleThreaded", + "mallocWrappers", + "noRecursiveIntervals", + "enums", + "congruence", + "octagon", + "wideningThresholds", + "loopUnrollHeuristic", + "memsafetySpecification", + "noOverflows", + "termination", + "tmpSpecialAnalysis" + ] + } + }, + "exp": { + "region-offsets": true + }, + "solver": "td3", + "sem": { + "unknown_function": { + "spawn": false + }, + "int": { + "signed_overflow": "assume_none" + }, + "null-pointer": { + "dereference": "assume_none" + } + }, + "witness": { + "graphml": { + "enabled": false + }, + "yaml": { + "enabled": true, + "format-version": "2.1", + "entry-types": [ + "flow_insensitive_invariant", + "ghost_instrumentation" + ] + }, + "invariant": { + "loop-head": true, + "after-lock": true, + "other": true, + "accessed": false, + "exact": true, + "all-locals": false, + "flow_insensitive-as": "invariant_set-location_invariant" + } + }, + "pre": { + "enabled": false + } +} diff --git a/docs/artifact-descriptions/vmcai25.md b/docs/artifact-descriptions/vmcai25.md new file mode 100644 index 0000000000..282be65ff0 --- /dev/null +++ b/docs/artifact-descriptions/vmcai25.md @@ -0,0 +1,298 @@ +# VMCAI '25 Artifact Description +## Correctness Witnesses for Concurrent Programs: Bridging the Semantic Divide with Ghosts + +This is the artifact description for our [VMCAI '25 paper "Correctness Witnesses for Concurrent Programs: Bridging the Semantic Divide with Ghosts"](https://doi.org/10.48550/arXiv.2411.16612). +The artifact is available on [Zenodo](https://doi.org/10.5281/zenodo.13863579). + +**The description here is provided for convenience and not maintained.** +The artifact contains [Goblint at `vmcai25` git tag](https://github.com/goblint/analyzer/releases/tag/vmcai25). + + +## Overview + +This artifact contains the following components: + + Evaluation Results :: The evaluation results, and overview tables (HTML) + generated from the raw data. + Source Code :: Source code for Goblint and Ultimate GemCutter, + the verification tools used in the experiments + for the paper. + Verifier Binaries :: Binaries for Goblint and Ultimate GemCutter. + Benchmark Programs :: Benchmarks used for evaluation of the verifiers. + Benchmark Witnesses :: The witnesses generated by Goblint, as used in the + experiments. + BenchExec Tool :: The BenchExec benchmarking tool can be used + to replicate our results on these benchmarks. + +The next section gives instructions on how to setup and quickly get an overview of the artifact. +The subsequent sections then describe each of these components in detail. +The final section gives information on how to reuse this artifact. + + +## Getting Started + +### 1. Setup + +The artifact is a virtual machine (VM). Follow these steps to set it up: + +* If you have not done so already, install VirtualBox. + () +* Download the artifact. +* Import the artifact via the VirtualBox UI (`File > Import Appliance`) + or by running `VBoxManage import ghost-witnesses.ova`. + +You can then start the VM from the VirtualBox UI. +Login with user `vagrant` and password `vagrant`. +(Note: By default, the user `Ubuntu` may be selected on the login screen. Click on the name and switch to user `vagrant`.) + +You may want to install VirtualBox guest additions (). +If the usual installation does not work, try the following steps: + +* Add a disk drive to the VM in its settings (the VM must be off for this). +* After starting the VM and logging in, select `Devices > Insert Guest Additions CD image` from the VirtualBox menu. +* Run the following in a terminal: + `sudo mount /dev/cdrom /mnt && cd /mnt && sudo ./VBoxLinuxAdditions.run` + +### 2. Inspect the evaluation results + +To extract the table data used in the paper from our raw evaluation results, open a terminal in the VM (`Ctrl+Alt+T`) and run the following commands: + + ~/scripts/analyse-witnesses.py "$HOME/witness-generation/paper-evaluation/goblint.2024-09-02_08-21-23.files" + cd ~/witness-validation/paper-evaluation/ + WITNESS_DIR="$HOME/witness-generation/paper-evaluation/goblint.2024-09-02_08-21-23.files" ~/scripts/analyse-validation.py + +The times for the Table 2 are given first in seconds and then pretty-printed as in the paper. + +For a more detailed inspection and visualization of the data, take a look at the generated HTML report. +Just open the file `~/witness-validation/paper-evaluation/results.2024-09-24_22-00-48.table.html` in firefox. +For detailed information, see the ["Evaluation Results" section](#evaluation-results) below. + +### 3. Quick Test of the Benchmark Setup + +To analyse some programs with Goblint and analyse the generated witnesses with GemCutter, run + + ~/scripts/quick-run.sh + +on a console in the VM. +This will analyse a single program with Goblint and generate witnesses using the four analyses described in the paper. +Subsequently, the script will run GemCutter's verification, witness confirmation and witness validation analyses on the example. + +The whole run should should conclude successfully for all configurations in about 2min. +This is indicated by the benchmark results `true` printed on the console, and the fact that the final output looks roughly like this: + + Table 1: Witness Confirmation + ============================= + correct programs + ----------------------------- + protection-ghost : total= 1 , confirmed= 1 , rejected= 0 , confirmation rate= 100.0 % , resource out= 0 + mutex-meet-ghost : total= 1 , confirmed= 1 , rejected= 0 , confirmation rate= 100.0 % , resource out= 0 + protection-local : total= 1 , confirmed= 1 , rejected= 0 , confirmation rate= 100.0 % , resource out= 0 + mutex-meet-local : total= 1 , confirmed= 1 , rejected= 0 , confirmation rate= 100.0 % , resource out= 0 + + confirmation range: 100.0 % - 100.0 % + + incorrect programs + ----------------------------- + No programs with witnesses found for protection-ghost. Skipping benchmark set... + No programs with witnesses found for mutex-meet-ghost. Skipping benchmark set... + No programs with witnesses found for protection-local. Skipping benchmark set... + No programs with witnesses found for mutex-meet-local. Skipping benchmark set... + + confirmation range: 100.0 % - 0.0 % + + + Table 2: Witness Validation + =========================== + protection-ghost + ---------------- + validation : {'number': 1, 'time': 14, 'time_pretty': 0:00:14} + verification : {'number': 1, 'time': 12, 'time_pretty': 0:00:12} + 0 tasks could be validated but not verified + + mutex-meet-ghost + ---------------- + validation : {'number': 1, 'time': 13, 'time_pretty': 0:00:13} + verification : {'number': 1, 'time': 12, 'time_pretty': 0:00:12} + 0 tasks could be validated but not verified + + protection-local + ---------------- + validation : {'number': 1, 'time': 12, 'time_pretty': 0:00:12} + verification : {'number': 1, 'time': 12, 'time_pretty': 0:00:12} + 0 tasks could be validated but not verified + + mutex-meet-local + ---------------- + validation : {'number': 1, 'time': 13, 'time_pretty': 0:00:13} + verification : {'number': 1, 'time': 12, 'time_pretty': 0:00:12} + 0 tasks could be validated but not verified + + ~ + + =============================================================================== + Completed quick benchmark test run. + + Results of witness generation can be found in: /home/vagrant/witness-generation/2024-10-01_08-57-09 + Generated witnesses are located in: /home/vagrant/witness-generation/2024-10-01_08-57-09/goblint.2024-10-01_08-57-09.files + Results of witness validation can be found in: /home/vagrant/witness-validation/2024-10-01_08-57-09 + =============================================================================== + +For a slightly larger set of experiments, run + + ~/scripts/medium-run.sh + +This will run an entire folder of SV-COMP benchmarks through Goblint and subsequently analyse the generated witness with GemCutter. +The whole run should complete in 3-4h. +(Note: This run uses a smaller timeout and memory limit than the full evaluation used in the paper, so the results for individual benchmarks may differ.) + +#### Troubleshooting +On certain old host machines, GemCutter fails with `ERROR(7)`, and the log files (`/home/vagrant/witness-validation/YYYY-MM-DD_hh-mm-ss/concurrency-witness-validation-gemcutter.YYYY-MM-DD_hh-mm-ss.logfiles/*.log`) contain a message as follows: + + [2024-10-01 22:04:14,025 INFO L327 MonitoredProcess]: [MP /home/vagrant/ultimate/releaseScripts/default/UGemCutter-linux/z3 SMTLIB2_COMPLIANT=true -memory:2024 -smt2 -in -t:2000 (1)] Waiting until timeout for monitored process + [2024-10-01 22:04:14,058 FATAL L? ?]: An unrecoverable error occured during an interaction with an SMT solver: + de.uni_freiburg.informatik.ultimate.logic.SMTLIBException: External (MP /home/vagrant/ultimate/releaseScripts/default/UGemCutter-linux/z3 SMTLIB2_COMPLIANT=true -memory:2024 -smt2 -in -t:2000 (1) with exit command (exit)) Received EOF on stdin. No stderr output. + +This is because the version of Z3 shipped with GemCutter uses certain processor instructions that the host does not support or VirtualBox emulates incorrectly. +In this case, download an official build of Z3 () and replace the file `~/ultimate/releaseScripts/default/UGemCutter-linux/z3` with the corresponding binary from the official ZIP: + + wget https://github.com/Z3Prover/z3/releases/download/z3-4.12.5/z3-4.12.5-x64-glibc-2.31.zip + unzip z3-4.12.5-x64-glibc-2.31.zip + cp z3-4.12.5-x64-glibc-2.31/bin/z3 ~/ultimate/releaseScripts/default/UGemCutter-linux/z3 + +### 4. Running the Full Experiments + +To re-run the full experiments, execute + + ~/scripts/full-run.sh + +This script behaves similarly to the smaller variants in the previous sections. +Note however: + +- By default the experiments require 16 GB of memory per benchmark (this configuration was used for the experiments in the paper). + To reproduce this, you will have to modify the VM's settings in VirtualBox and increase the available memory (shutdown the machine while doing so). + + Alternatively, you can run the experiments with a reduced memory limit. + To do so, modify the environment variable `BENCHMARK_PARAMS`. + For instance, the following allows only 4GB of memory per benchmark: + + BENCHMARK_PARAMS="-M 4GB" ~/scripts/full-run.sh + +- The full evaluation for the paper required around 3 days. + In this evaluation, we used the benchexec tool to run 14 validation tasks in parallel (occupying up to 28 cores at a time). + + By default, the provided script only runs one benchmark at a time. + If you have sufficient cores and memory available (adjust the VM settings accordingly), you can run multiple benchmarks in parallel by setting the environment variable `BENCHEXEC_THREADS`. You may also execute the experiments with a reduced timeout. + For instance, the following command runs 4 benchmarks in parallel at a time (occupying up to 8 cores), and gives each benchmark a 300s timeout and 4GB memory limit: + + BENCHEXEC_THREADS=4 BENCHMARK_PARAMS="-T 300s -M 4GB" ~/scripts/full-run.sh + +Naturally, changes to the timeout or memory are expected to affect the evaluation numbers. + + +## Evaluation Results + +The evaluation results that form the basis for the experimental data in the paper can be found in the directory `~/witness-validation/paper-evaluation/`. +The witnesses generated by Goblint that formed the basis for this evaluation can be found in `~/witness-generation/paper-evaluation/`. +See below for detailed info to reproduce the tables and figures of the paper. + +The file `~/witness-validation/paper-evaluation/` contains an HTML overview page generated by the BenchExec benchmarking tool, which displays individual results, quantile and scatter plots. Through the filtering sidebar (top right corner), detailed analyses can be made. + +The table contains the following configurations : + +* `verify` -- GemCutter verification, without any witness +* `verify+validate-goblint-witnesses-{mutex-meet,protection}-{ghost,local}` -- GemCutter witness validation, applied to the 4 different witness sets generated by Goblint. + In this mode, GemCutter checks if the given witness is valid and the corresponding program is correct. +* `validate-goblint-witnesses-{mutex-meet,protection}-{ghost,local}` -- GemCutter witness _confirmation_, applied to the different witness sets. + In this mode, described in the paper, GemCutter only checks if the given witness' invariants are correct, but does not prove the corresponding program correct. + +The summary table shows how many benchmarks were analysed and the results. + +- The row `correct true` indicates tasks that were successfully verified (for `verify`), or where the witness was confirmed resp. validated (for the other configurations). +- The row `correct false` indicates that a bug was found (for `verify`), resp. that witness validation failed and a witness was rejected. + The latter only happens for programs that are incorrect, hence there can be no valid correctness witness and rejection is expected. + As witness validation is not possible for incorrect programs, this data is not discussed in the paper and only appears here due to the benchmark setup. +- The row `incorrect false` would indicate that GemCutter finds a supposed bug in a correct program (for `verify`). + For witness confirmation configurations, it indicates that GemCutter confirmed the correctness witness given by Goblint, for an incorrect program. + As witness confirmation ignores the program's correctness, these results are expected and do not indicate a problem in one of the tools. + +The *Table* tab gives access to detailed evaluation results for each file. +Clicking on a status shows the complete GemCutter log for the benchmark run. + +> **Note:** If you are trying to view logs for individual runs through the HTML table (by clicking on the evaluation result `true` or `false`), you may encounter a warning because browsers block access to local files. Follow the instructions in the message to enable log viewing. + +As described above (in [section _2. Inspect the evaluation results_](#2-inspect-the-evaluation-results)), the artifact provides python scripts to directly extract the data shown in the paper from the benchmark results. + + +## Source Code + +### GemCutter + +Ultimate GemCutter is developed as part of the Ultimate program analysis framework () and is implemented in Java. The source code for Ultimate at the time of evaluation can be found in this artifact in the `~/ultimate` directory. + +The directory `trunk/source/CACSL2BoogieTranslator/src/de/uni_freiburg/informatik/ultimate/plugins/generator/cacsl2boogietranslator/witness` is of particular interest for the present paper. +The code in this directory handles instrumentation of the program with various witness entries, as part of Ultimate's translation of the original C code to the intermediate verification language Boogie. + +More recent versions of Ultimate can be found at . + +### Goblint + +The Goblint analyzer () is developed by TU Munich and University of Tartu. The source code for Goblint at the time of evaluation can be found in this artifact in the `~/goblint` directory. + +The code for this paper is the following: + +1. `src/witness/witnessGhostVar.ml` and `src/witness/witnessGhost.ml` define the data types for ghost variables. +2. `src/analyses/mutexGhosts.ml` defines the analysis which determines the ghost variables for a specific program and their updates. +3. `src/analyses/basePriv.ml` lines 342-365 define the invariants with mutex ghost variables from non-relational _mutex-meet_ analysis. +4. `src/analyses/apron/relationPriv.apron.ml` lines 717-750 define the invariants with mutex ghost variables from relational _mutex-meet_ analysis. +5. `src/analyses/base.ml` lines 1269-1289 and `src/analyses/apron/relationAnalysis.apron.ml` lines 637-644 define the wrapping of the invariants with multithreaded mode ghost variables. +6. `src/analyses/basePriv.ml` lines 882-909 define the invariants with mutex ghost variables from (non-relational) _protection_ analysis. +7. `src/witness/yamlWitness.ml` lines 398-421 and 589-621 define the YAML output of ghost variables, their updates and the invariants. + +More recent versions of Goblint can be found at . + + +## Verifier Binaries + +A pre-built binary of GemCutter can be found in `~/ultimate/releaseScripts/default/UGemCutter-linux/`. +For information on how to execute GemCutter, consult the `README` in `~/ultimate/releaseScripts/default/UGemCutter-linux/`. +To build Ultimate GemCutter from scratch, go to `~/ultimate/releaseScripts/default/` and run `./makeFresh.sh`. + +A pre-built binary of Goblint is available as `~/goblint/goblint`. +See `~/goblint/README.md` for information on how to run Goblint. +To build Goblint from scratch, run `make setup && make release`. + +Both GemCutter and Goblint can be invoked via the BenchExec benchmarking tool () which is installed in the VM. +For examples, see the benchmark definition files `~/witness-generation/goblint.xml` resp. `~/witness-validation/gemcutter.xml` and the scripts `~/scripts/generate-witnesses.sh` resp. `~/scripts/validate-witnesses.sh`. + + +## Benchmark Programs + +This artifact includes the benchmark programs on which we evaluated the verifiers. +These benchmarks are taken from the publicly available sv-benchmarks set () +and correspond to the _ConcurrencySafety-Main_ category of SV-COMP'24 (). +The benchmarks are written in C and use POSIX threads (`pthreads`) to model concurrency. + + +## Extending & Reusing This Artifact + +* **Building a modified version of the VM:** This VM was created using the `vagrant` tool (). + The `Vagrantfile` used to build the artifact, along with several other files used in the build, is included in the directory `~/artifact`. + This can be used to inspect the setup of the VM, and even build a modified version. + + Note that, to rebuild the VM, some files (e.g. scripts, evaluation results, this README) need to be extracted from the image and placed in a suitable location on your machine. + +* **Adding benchmarks:** You can easily add your own benchmarks programs written in C. + C programs should contain an empty function called `reach_error()`. Goblint and GemCutter then check that this function is never invoked. Certain (gcc) preprocessing steps may be necessary, e.g. to resolve `#include`s. See the SV-COMP benchmarks for examples (the preprocessed files typically have the extension `.i`). + + To run the evaluation on your own programs, you must edit the benchmark definition files `~/witness-generation/goblint.xml.template` resp. `~/witness-validation/gemcutter.xml.template`. + Replace the `` path specified in the task set `minimal` with your own path. + You can then simply run `~/scripts/quick-run.sh`. + +* **Adding more tools:** As described above, you can reuse the `Vagrantfile` for this artifact and extend it with whatever installation measures are necessary for an additional tool. Also note, that in order to run other tools with BenchExec, you must write a *tool info module* in python (). + + Create a new benchmark definition file for your tool (). + The existing files `~/witness-generation/goblint.xml.template` resp. `~/witness-validation/gemcutter.xml.template` can serve as an example. + + If you are planning to support generation or validation of correctness witnesses using the proposed format, take a look at the YAML schema definition for the format linked in the paper. + The schema is also available in this artifact as `~/artifact-files/correctness-witness-schema.yml`. + diff --git a/goblint.opam b/goblint.opam index 9f2b874ff6..219c67d011 100644 --- a/goblint.opam +++ b/goblint.opam @@ -96,14 +96,14 @@ dev-repo: "git+https://github.com/goblint/analyzer.git" # on `dune build` goblint.opam will be generated from goblint.opam.template and dune-project # also remember to generate/adjust goblint.opam.locked! available: os-family != "bsd" & os-distribution != "alpine" & (arch != "arm64" | os = "macos") -# pin-depends: [ - # published goblint-cil 2.0.5 is currently up-to-date, so no pin needed - # [ "goblint-cil.2.0.5" "git+https://github.com/goblint/cil.git#c79208b21ea61d7b72eae29a18c1ddeda4795dfd" ] +pin-depends: [ + # published goblint-cil 2.0.5 is currently up-to-date, but pinned for reproducibility + [ "goblint-cil.2.0.5" "git+https://github.com/goblint/cil.git#c79208b21ea61d7b72eae29a18c1ddeda4795dfd" ] # pinned for stability (https://github.com/goblint/analyzer/issues/1520), remove after new camlidl release - # [ "camlidl.1.12" "git+https://github.com/xavierleroy/camlidl.git#1c1e87e3f56c2c6b3226dd0af3510ef414b462d0" ] + [ "camlidl.1.12" "git+https://github.com/xavierleroy/camlidl.git#1c1e87e3f56c2c6b3226dd0af3510ef414b462d0" ] # pinned for stability (https://github.com/goblint/analyzer/issues/1520), remove after new apron release - # [ "apron.v0.9.15" "git+https://github.com/antoinemine/apron.git#418a217c7a70dae3f422678f3aaba38ae374d91a" ] -# ] + [ "apron.v0.9.15" "git+https://github.com/antoinemine/apron.git#418a217c7a70dae3f422678f3aaba38ae374d91a" ] +] depexts: [ ["libgraph-easy-perl"] {os-distribution = "ubuntu" & with-test} ] diff --git a/goblint.opam.locked b/goblint.opam.locked index 3a7bb1bfa5..e5176b9007 100644 --- a/goblint.opam.locked +++ b/goblint.opam.locked @@ -137,6 +137,20 @@ conflicts: [ post-messages: [ "Do not benchmark Goblint on OCaml 5 (https://goblint.readthedocs.io/en/latest/user-guide/benchmarking/)." {ocaml:version >= "5.0.0"} ] +pin-depends: [ + [ + "goblint-cil.2.0.5" + "git+https://github.com/goblint/cil.git#c79208b21ea61d7b72eae29a18c1ddeda4795dfd" + ] + [ + "camlidl.1.12" + "git+https://github.com/xavierleroy/camlidl.git#1c1e87e3f56c2c6b3226dd0af3510ef414b462d0" + ] + [ + "apron.v0.9.15" + "git+https://github.com/antoinemine/apron.git#418a217c7a70dae3f422678f3aaba38ae374d91a" + ] +] depexts: ["libgraph-easy-perl"] {os-distribution = "ubuntu" & with-test} description: """\ Goblint is a sound static analysis framework for C programs using abstract interpretation. diff --git a/goblint.opam.template b/goblint.opam.template index 8766a89df2..84dcc24d8d 100644 --- a/goblint.opam.template +++ b/goblint.opam.template @@ -1,14 +1,14 @@ # on `dune build` goblint.opam will be generated from goblint.opam.template and dune-project # also remember to generate/adjust goblint.opam.locked! available: os-family != "bsd" & os-distribution != "alpine" & (arch != "arm64" | os = "macos") -# pin-depends: [ - # published goblint-cil 2.0.5 is currently up-to-date, so no pin needed - # [ "goblint-cil.2.0.5" "git+https://github.com/goblint/cil.git#c79208b21ea61d7b72eae29a18c1ddeda4795dfd" ] +pin-depends: [ + # published goblint-cil 2.0.5 is currently up-to-date, but pinned for reproducibility + [ "goblint-cil.2.0.5" "git+https://github.com/goblint/cil.git#c79208b21ea61d7b72eae29a18c1ddeda4795dfd" ] # pinned for stability (https://github.com/goblint/analyzer/issues/1520), remove after new camlidl release - # [ "camlidl.1.12" "git+https://github.com/xavierleroy/camlidl.git#1c1e87e3f56c2c6b3226dd0af3510ef414b462d0" ] + [ "camlidl.1.12" "git+https://github.com/xavierleroy/camlidl.git#1c1e87e3f56c2c6b3226dd0af3510ef414b462d0" ] # pinned for stability (https://github.com/goblint/analyzer/issues/1520), remove after new apron release - # [ "apron.v0.9.15" "git+https://github.com/antoinemine/apron.git#418a217c7a70dae3f422678f3aaba38ae374d91a" ] -# ] + [ "apron.v0.9.15" "git+https://github.com/antoinemine/apron.git#418a217c7a70dae3f422678f3aaba38ae374d91a" ] +] depexts: [ ["libgraph-easy-perl"] {os-distribution = "ubuntu" & with-test} ] diff --git a/gobview b/gobview index 76e42c34d3..f8ae450f2a 160000 --- a/gobview +++ b/gobview @@ -1 +1 @@ -Subproject commit 76e42c34d36bd2ab6900efd661a972ba4824f065 +Subproject commit f8ae450f2ac83f5ccf0ee174d2b7ae8376bb4f76 diff --git a/mkdocs.yml b/mkdocs.yml index a4c4238601..b55787f8da 100644 --- a/mkdocs.yml +++ b/mkdocs.yml @@ -41,3 +41,4 @@ nav: - "🇸 SAS '21": artifact-descriptions/sas21.md - "🇪 ESOP '23": artifact-descriptions/esop23.md - "🇻 VMCAI '24": artifact-descriptions/vmcai24.md + - "🇻 VMCAI '25": artifact-descriptions/vmcai25.md diff --git a/scripts/goblint-lib-modules.py b/scripts/goblint-lib-modules.py index ba25a1403c..90537e57fe 100755 --- a/scripts/goblint-lib-modules.py +++ b/scripts/goblint-lib-modules.py @@ -48,6 +48,13 @@ "MessageCategory", # included in Messages "PreValueDomain", # included in ValueDomain + "IntervalDomain", # included in IntDomain + "IntervalSetDomain", # included in IntDomain + "DefExcDomain", # included in IntDomain + "EnumsDomain", # included in IntDomain + "CongruenceDomain", # included in IntDomain + "IntDomTuple", # included in IntDomain + "WitnessGhostVar", # included in WitnessGhost "ConfigVersion", "ConfigProfile", diff --git a/src/analyses/apron/relationAnalysis.apron.ml b/src/analyses/apron/relationAnalysis.apron.ml index 28e365bd97..df3cf545c5 100644 --- a/src/analyses/apron/relationAnalysis.apron.ml +++ b/src/analyses/apron/relationAnalysis.apron.ml @@ -634,6 +634,15 @@ struct ) |> Enum.fold (fun acc x -> Invariant.(acc && of_exp x)) Invariant.none + let query_invariant_global ctx g = + if GobConfig.get_bool "ana.relation.invariant.global" && ctx.ask (GhostVarAvailable Multithreaded) then ( + let var = WitnessGhost.to_varinfo Multithreaded in + let inv = Priv.invariant_global (Analyses.ask_of_ctx ctx) ctx.global g in + Invariant.(of_exp (UnOp (LNot, Lval (GoblintCil.var var), GoblintCil.intType)) || inv) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) + ) + else + Invariant.none + let query ctx (type a) (q: a Queries.t): a Queries.result = let open Queries in let st = ctx.local in @@ -655,6 +664,9 @@ struct let vf' x = vf (Obj.repr x) in Priv.iter_sys_vars ctx.global vq vf' | Queries.Invariant context -> query_invariant ctx context + | Queries.InvariantGlobal g -> + let g: V.t = Obj.obj g in + query_invariant_global ctx g | _ -> Result.top q diff --git a/src/analyses/apron/relationPriv.apron.ml b/src/analyses/apron/relationPriv.apron.ml index 15df394d54..257bec24d8 100644 --- a/src/analyses/apron/relationPriv.apron.ml +++ b/src/analyses/apron/relationPriv.apron.ml @@ -46,6 +46,9 @@ module type S = val thread_return: Q.ask -> (V.t -> G.t) -> (V.t -> G.t -> unit) -> ThreadIdDomain.Thread.t -> relation_components_t -> relation_components_t val iter_sys_vars: (V.t -> G.t) -> VarQuery.t -> V.t VarQuery.f -> unit (** [Queries.IterSysVars] for apron. *) + val invariant_global: Q.ask -> (V.t -> G.t) -> V.t -> Invariant.t + (** Returns flow-insensitive invariant for global unknown. *) + val invariant_vars: Q.ask -> (V.t -> G.t) -> relation_components_t -> varinfo list (** Returns global variables which are privatized. *) @@ -137,6 +140,7 @@ struct {rel = RD.top (); priv = startstate ()} let iter_sys_vars getg vq vf = () + let invariant_global ask getg g = Invariant.none let invariant_vars ask getg st = [] let init () = () @@ -424,6 +428,7 @@ struct {rel = getg (); priv = startstate ()} let iter_sys_vars getg vq vf = () (* TODO: or report singleton global for any Global query? *) + let invariant_global ask getg g = Invariant.none let invariant_vars ask getg st = protected_vars ask (* TODO: is this right? *) let finalize () = () @@ -708,6 +713,41 @@ struct let init () = () let finalize () = () + + let invariant_global (ask: Q.ask) (getg: V.t -> G.t): V.t -> Invariant.t = function + | `Left m' -> (* mutex *) + let atomic = LockDomain.MustLock.equal m' (LockDomain.MustLock.of_var LibraryFunctions.verifier_atomic_var) in + if atomic || ask.f (GhostVarAvailable (Locked m')) then ( + (* filters like query_invariant *) + let one_var = GobConfig.get_bool "ana.relation.invariant.one-var" in + let exact = GobConfig.get_bool "witness.invariant.exact" in + + let rel = keep_only_protected_globals ask m' (get_m_with_mutex_inits ask getg m') in (* Could be more precise if mutex_inits invariant is added by disjunction instead of joining abstract values. *) + let inv = + RD.invariant rel + |> List.enum + |> Enum.filter_map (fun (lincons1: Apron.Lincons1.t) -> + (* filter one-vars and exact *) + (* TODO: exact filtering doesn't really work with octagon because it returns two SUPEQ constraints instead *) + if (one_var || GobApron.Lincons1.num_vars lincons1 >= 2) && (exact || Apron.Lincons1.get_typ lincons1 <> EQ) then + RD.cil_exp_of_lincons1 lincons1 + |> Option.filter (fun exp -> not (InvariantCil.exp_contains_tmp exp)) + else + None + ) + |> Enum.fold (fun acc x -> Invariant.(acc && of_exp x)) Invariant.none + in + if atomic then + inv + else ( + let var = WitnessGhost.to_varinfo (Locked m') in + Invariant.(of_exp (Lval (GoblintCil.var var)) || inv) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) + ) + ) + else + Invariant.none + | g -> (* global *) + Invariant.none (* Could output unprotected one-variable (so non-relational) invariants, but probably not very useful. [BasePriv] does those anyway. *) end (** May written variables. *) @@ -1275,6 +1315,8 @@ struct | _ -> () let finalize () = () + + let invariant_global ask getg g = Invariant.none end module TracingPriv = functor (Priv: S) -> functor (RD: RelationDomain.RD) -> diff --git a/src/analyses/base.ml b/src/analyses/base.ml index cc0269d648..f6e41361a3 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -1181,6 +1181,9 @@ struct not is_alloc || (is_alloc && not (ctx.ask (Queries.IsHeapVar v))) let query_invariant ctx context = + let keep_local = GobConfig.get_bool "ana.base.invariant.local" in + let keep_global = GobConfig.get_bool "ana.base.invariant.global" in + let cpa = ctx.local.BaseDomain.cpa in let ask = Analyses.ask_of_ctx ctx in @@ -1193,6 +1196,13 @@ struct in let module I = ValueDomain.ValueInvariant (Arg) in + let var_filter v = + if is_global ask v then + keep_global + else + keep_local + in + let var_invariant ?offset v = if not (InvariantCil.var_is_heap v) then I.key_invariant v ?offset (Arg.find v) @@ -1203,14 +1213,23 @@ struct if Lval.Set.is_top context.Invariant.lvals then ( if !earlyglobs || ThreadFlag.has_ever_been_multi ask then ( let cpa_invariant = - CPA.fold (fun k v a -> - if not (is_global ask k) then - Invariant.(a && var_invariant k) - else - a - ) cpa Invariant.none + if keep_local then ( + CPA.fold (fun k v a -> + if not (is_global ask k) then + Invariant.(a && var_invariant k) + else + a + ) cpa Invariant.none + ) + else + Invariant.none + in + let priv_vars = + if keep_global then + Priv.invariant_vars ask (priv_getg ctx.global) ctx.local + else + [] in - let priv_vars = Priv.invariant_vars ask (priv_getg ctx.global) ctx.local in let priv_invariant = List.fold_left (fun acc v -> Invariant.(var_invariant v && acc) @@ -1220,7 +1239,10 @@ struct ) else ( CPA.fold (fun k v a -> - Invariant.(a && var_invariant k) + if var_filter k then + Invariant.(a && var_invariant k) + else + a ) cpa Invariant.none ) ) @@ -1228,7 +1250,7 @@ struct Lval.Set.fold (fun k a -> let i = match k with - | (Var v, offset) when not (InvariantCil.var_is_heap v) -> + | (Var v, offset) when var_filter v && not (InvariantCil.var_is_heap v) -> (try I.key_invariant_lval v ~offset ~lval:k (Arg.find v) with Not_found -> Invariant.none) | _ -> Invariant.none in @@ -1243,13 +1265,23 @@ struct Invariant.none let query_invariant_global ctx g = - if GobConfig.get_bool "ana.base.invariant.enabled" && get_bool "exp.earlyglobs" then ( + if GobConfig.get_bool "ana.base.invariant.enabled" && GobConfig.get_bool "ana.base.invariant.global" then ( (* Currently these global invariants are only sound with earlyglobs enabled for both single- and multi-threaded programs. - Otherwise, the values of globals in single-threaded mode are not accounted for. *) - (* TODO: account for single-threaded values without earlyglobs. *) + Otherwise, the values of globals in single-threaded mode are not accounted for. + They are also made sound without earlyglobs using the multithreaded mode ghost variable. *) match g with | `Left g' -> (* priv *) - Priv.invariant_global (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) g' + let inv = Priv.invariant_global (Analyses.ask_of_ctx ctx) (priv_getg ctx.global) g' in + if get_bool "exp.earlyglobs" then + inv + else ( + if ctx.ask (GhostVarAvailable Multithreaded) then ( + let var = WitnessGhost.to_varinfo Multithreaded in + Invariant.(of_exp (UnOp (LNot, Lval (GoblintCil.var var), GoblintCil.intType)) || inv) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) + ) + else + Invariant.none + ) | `Right _ -> (* thread return *) Invariant.none ) diff --git a/src/analyses/basePriv.ml b/src/analyses/basePriv.ml index e69757c7a8..3afd758daa 100644 --- a/src/analyses/basePriv.ml +++ b/src/analyses/basePriv.ml @@ -250,7 +250,7 @@ struct let invariant_global ask getg = function | `Right g' -> (* global *) - ValueDomain.invariant_global (read_unprotected_global getg) g' + ValueDomain.invariant_global (read_unprotected_global getg) g' (* Could be more precise if mutex_inits invariant is added by disjunction instead of joining abstract values. *) | _ -> (* mutex *) Invariant.none @@ -339,6 +339,31 @@ module PerMutexMeetPrivBase = struct include PerMutexPrivBase + let invariant_global (ask: Q.ask) getg = function + | `Left m' -> (* mutex *) + let atomic = LockDomain.MustLock.equal m' (LockDomain.MustLock.of_var LibraryFunctions.verifier_atomic_var) in + if atomic || ask.f (GhostVarAvailable (Locked m')) then ( + let cpa = get_m_with_mutex_inits ask getg m' in (* Could be more precise if mutex_inits invariant is added by disjunction instead of joining abstract values. *) + let inv = CPA.fold (fun v _ acc -> + if ask.f (MustBeProtectedBy {mutex = m'; global = v; write = true; protection = Strong}) then + let inv = ValueDomain.invariant_global (fun g -> CPA.find g cpa) v in + Invariant.(acc && inv) + else + acc + ) cpa Invariant.none + in + if atomic then + inv + else ( + let var = WitnessGhost.to_varinfo (Locked m') in + Invariant.(of_exp (Lval (GoblintCil.var var)) || inv) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) + ) + ) + else + Invariant.none + | g -> (* global *) + invariant_global ask getg g + let invariant_vars ask getg (st: _ BaseDomain.basecomponents_t) = (* Mutex-meet local states contain precisely the protected global variables, so we can do fewer queries than {!protected_vars}. *) @@ -374,8 +399,11 @@ struct in if not invariant then ( if M.tracing then M.tracel "priv" "WRITE GLOBAL SIDE %a = %a" CilType.Varinfo.pretty x VD.pretty v; - sideg (V.global x) (CPA.singleton x v) - (* Unlock after invariant will still side effect refined value (if protected) from CPA, because cannot distinguish from non-invariant write. *) + let side_cpa = CPA.singleton x v in + sideg (V.global x) side_cpa; + if !earlyglobs && not (ThreadFlag.is_currently_multi ask) then + sideg V.mutex_inits side_cpa (* Also side to inits because with earlyglobs enter_multithreaded does not side everything to inits *) + (* Unlock after invariant will still side effect refined value (if protected) from CPA, because cannot distinguish from non-invariant write. *) ); {st with cpa = cpa'} (* let write_global ask getg sideg cpa x v = @@ -676,7 +704,7 @@ struct let invariant_global ask getg = function | `Middle g -> (* global *) - ValueDomain.invariant_global (read_unprotected_global getg) g + ValueDomain.invariant_global (read_unprotected_global getg) g (* Could be more precise if mutex_inits invariant is added by disjunction instead of joining abstract values. *) | `Left _ | `Right _ -> (* mutex or thread *) Invariant.none @@ -749,8 +777,8 @@ struct if not invariant then ( if not (Param.handle_atomic && ask.f MustBeAtomic) then sideg (V.unprotected x) v; (* Delay publishing unprotected write in the atomic section. *) - if !earlyglobs then (* earlyglobs workaround for 13/60 *) - sideg (V.protected x) v + if !earlyglobs && not (ThreadFlag.is_currently_multi ask) then (* earlyglobs workaround for 13/60 *) + sideg (V.protected x) v (* Also side to protected because with earlyglobs enter_multithreaded does not side everything to protected *) (* Unlock after invariant will still side effect refined value (if protected) from CPA, because cannot distinguish from non-invariant write since W is implicit. *) ); if Param.handle_atomic && ask.f MustBeAtomic then @@ -851,13 +879,37 @@ struct vf (V.protected g); | _ -> () - let invariant_global ask getg g = + let invariant_global (ask: Q.ask) getg g = let getg = Wrapper.getg ask getg in match g with | `Left g' -> (* unprotected *) ValueDomain.invariant_global (fun g -> getg (V.unprotected g)) g' - | `Right g -> (* protected *) - Invariant.none + | `Right g' -> (* protected *) + let locks = ask.f (Q.MustProtectingLocks g') in + if LockDomain.MustLockset.is_all locks || LockDomain.MustLockset.is_empty locks then + Invariant.none + else if VD.equal (getg (V.protected g')) (getg (V.unprotected g')) then + Invariant.none (* don't output protected invariant because it's the same as unprotected *) + else ( + (* Only read g' as protected, everything else (e.g. pointed to variables) may be unprotected. + See 56-witness/69-ghost-ptr-protection and https://github.com/goblint/analyzer/pull/1394#discussion_r1698136411. *) + let read_global g = getg (if CilType.Varinfo.equal g g' then V.protected g else V.unprotected g) in + let inv = ValueDomain.invariant_global read_global g' in + (* Very conservative about multiple (write-)protecting mutexes: invariant is not claimed when any of them is held. + It should be possible to be more precise because writes only happen with all of them held, + but conjunction is unsound when one of the mutexes is temporarily unlocked. + Hypothetical read-protection is also somehow relevant. *) + LockDomain.MustLockset.fold (fun m acc -> + if LockDomain.MustLock.equal m (LockDomain.MustLock.of_var LibraryFunctions.verifier_atomic_var) then + acc + else if ask.f (GhostVarAvailable (Locked m)) then ( + let var = WitnessGhost.to_varinfo (Locked m) in + Invariant.(of_exp (Lval (GoblintCil.var var)) || acc) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) + ) + else + Invariant.none + ) locks inv + ) let invariant_vars ask getg st = protected_vars ask end @@ -998,7 +1050,7 @@ struct (* sync: M -> (2^M -> (G -> D)) *) include AbstractLockCenteredBase (ThreadMap) (LockCenteredBase.CPA) - let global_init_thread = RichVarinfo.single ~name:"global_init" + let global_init_thread = RichVarinfo.single ~name:"global_init" ~typ:GoblintCil.voidType let current_thread (ask: Q.ask): Thread.t = if !AnalysisState.global_initialization then ThreadIdDomain.Thread.threadinit (global_init_thread ()) ~multiple:false @@ -1902,6 +1954,17 @@ struct if M.tracing then M.traceu "priv" "-> %a" BaseComponents.pretty r; r + let invariant_global ask getg g = + if M.tracing then M.traceli "priv" "invariant_global %a" V.pretty g; + let getg x = + let r = getg x in + if M.tracing then M.trace "priv" "getg %a -> %a" V.pretty x G.pretty r; + r + in + let r = invariant_global ask getg g in + if M.tracing then M.traceu "priv" "-> %a" Invariant.pretty r; + r + end let priv_module: (module S) Lazy.t = diff --git a/src/analyses/mCP.ml b/src/analyses/mCP.ml index 742e796fbd..f2f36b1360 100644 --- a/src/analyses/mCP.ml +++ b/src/analyses/mCP.ml @@ -303,6 +303,10 @@ struct (* InvariantGlobal is special: it only goes to corresponding analysis and the argument variant is unlifted for it *) let (n, g): V.t = Obj.obj g in f ~q:(InvariantGlobal (Obj.repr g)) (Result.top ()) (n, spec n, assoc n ctx.local) + | Queries.YamlEntryGlobal (g, task) -> + (* YamlEntryGlobal is special: it only goes to corresponding analysis and the argument variant is unlifted for it *) + let (n, g): V.t = Obj.obj g in + f ~q:(YamlEntryGlobal (Obj.repr g, task)) (Result.top ()) (n, spec n, assoc n ctx.local) | Queries.PartAccess a -> Obj.repr (access ctx a) | Queries.IterSysVars (vq, fi) -> diff --git a/src/analyses/mutexAnalysis.ml b/src/analyses/mutexAnalysis.ml index 9b6aa4f4ca..3710d2db9c 100644 --- a/src/analyses/mutexAnalysis.ml +++ b/src/analyses/mutexAnalysis.ml @@ -121,14 +121,17 @@ struct let add ctx ((addr, rw): AddrRW.t): D.t = match addr with - | Addr mv -> + | Addr ((v, o) as mv) -> let (s, m) = ctx.local in let s' = MustLocksetRW.add_mval_rw (mv, rw) s in let m' = - if MutexTypeAnalysis.must_be_recursive ctx mv then - MustMultiplicity.increment mv m - else + match ctx.ask (Queries.MutexType (v, Offset.Unit.of_offs o)) with + | `Lifted Recursive -> MustMultiplicity.increment mv m + | `Lifted NonRec -> + if MustLocksetRW.mem_mval mv s then + M.error ~category:M.Category.Behavior.Undefined.double_locking "Acquiring a non-recursive mutex that is already held"; m + | `Bot | `Top -> m in (s', m') | NullPtr -> @@ -223,6 +226,8 @@ struct true else *) MustLockset.mem ml protecting + | Queries.MustProtectingLocks g -> + protecting ~write:true Strong g | Queries.MustLockset -> let held_locks = MustLocksetRW.to_must_lockset (MustLocksetRW.filter snd ls) in held_locks diff --git a/src/analyses/mutexGhosts.ml b/src/analyses/mutexGhosts.ml new file mode 100644 index 0000000000..3deec3ef59 --- /dev/null +++ b/src/analyses/mutexGhosts.ml @@ -0,0 +1,191 @@ +(** Analysis for generating ghost variables corresponding to mutexes ([mutexGhosts]). *) + +open Analyses + +module NodeSet = Queries.NS + + +module Spec = +struct + include UnitAnalysis.Spec + let name () = "mutexGhosts" + + module V = + struct + include Printable.Either3 (Node) (LockDomain.MustLock) (BoolDomain.Bool) + let node x = `Left x + let lock x = `Middle x + let threadcreate = `Right false + let update = `Right true + let is_write_only = function + | `Left _ -> false + | `Middle _ -> true + | `Right false -> false + | `Right true -> true + end + + module Locked = + struct + include LockDomain.MayLocksetNoRW + let name () = "locked" + end + module Unlocked = + struct + include LockDomain.MayLocksetNoRW + let name () = "unlocked" + end + module MultiThread = + struct + include BoolDomain.MayBool + let name () = "multithread" + end + module G = + struct + include Lattice.Lift2 (Lattice.Prod3 (Locked) (Unlocked) (MultiThread)) (Lattice.Lift2 (BoolDomain.MayBool) (NodeSet)) + let node = function + | `Bot -> (Locked.bot (), Unlocked.bot (), MultiThread.bot ()) + | `Lifted1 x -> x + | _ -> failwith "MutexGhosts.node" + let lock = function + | `Bot -> BoolDomain.MayBool.bot () + | `Lifted2 (`Lifted1 x) -> x + | _ -> failwith "MutexGhosts.lock" + let threadcreate = function + | `Bot -> NodeSet.bot () + | `Lifted2 (`Lifted2 x) -> x + | _ -> failwith "MutexGhosts.threadcreate" + let update = threadcreate + let create_node node = `Lifted1 node + let create_lock lock = `Lifted2 (`Lifted1 lock) + let create_threadcreate threadcreate = `Lifted2 (`Lifted2 threadcreate) + let create_update = create_threadcreate + end + + let mustlock_of_addr (addr: LockDomain.Addr.t): LockDomain.MustLock.t option = + match addr with + | Addr mv when LockDomain.Mval.is_definite mv -> Some (LockDomain.MustLock.of_mval mv) + | _ -> None + + let event ctx e octx = + let verifier_atomic_addr = LockDomain.Addr.of_var LibraryFunctions.verifier_atomic_var in + begin match e with + | Events.Lock (l, _) when not (LockDomain.Addr.equal l verifier_atomic_addr) -> + ctx.sideg (V.node ctx.prev_node) (G.create_node (Locked.singleton l, Unlocked.bot (), MultiThread.bot ())); + if !AnalysisState.postsolving then ( + ctx.sideg V.update (G.create_update (NodeSet.singleton ctx.prev_node)); + let (locked, _, _) = G.node (ctx.global (V.node ctx.prev_node)) in + if Locked.cardinal locked > 1 then ( + Locked.iter (fun lock -> + Option.iter (fun lock -> + ctx.sideg (V.lock lock) (G.create_lock true) + ) (mustlock_of_addr lock) + ) locked + ); + ) + | Events.Unlock l when not (LockDomain.Addr.equal l verifier_atomic_addr) -> + ctx.sideg (V.node ctx.prev_node) (G.create_node (Locked.bot (), Unlocked.singleton l, MultiThread.bot ())); + if !AnalysisState.postsolving then ( + ctx.sideg V.update (G.create_update (NodeSet.singleton ctx.prev_node)); + let (_, unlocked, _) = G.node (ctx.global (V.node ctx.prev_node)) in + if Locked.cardinal unlocked > 1 then ( + Locked.iter (fun lock -> + Option.iter (fun lock -> + ctx.sideg (V.lock lock) (G.create_lock true) + ) (mustlock_of_addr lock) + ) unlocked + ); + ) + | Events.EnterMultiThreaded -> + ctx.sideg (V.node ctx.prev_node) (G.create_node (Locked.bot (), Unlocked.bot (), true)); + if !AnalysisState.postsolving then + ctx.sideg V.update (G.create_update (NodeSet.singleton ctx.prev_node)); + | _ -> () + end; + ctx.local + + let threadspawn ctx ~multiple lval f args octx = + ctx.sideg V.threadcreate (G.create_threadcreate (NodeSet.singleton ctx.node)); + ctx.local + + let ghost_var_available ctx = function + | WitnessGhost.Var.Locked ((v, o) as lock) -> not (Offset.Z.contains_index o) && not (G.lock (ctx.global (V.lock lock))) + | Multithreaded -> true + + let ghost_var_available ctx v = + WitnessGhost.enabled () && ghost_var_available ctx v + + module VariableSet = Set.Make (YamlWitnessType.GhostInstrumentation.Variable) + + let query ctx (type a) (q: a Queries.t): a Queries.result = + match q with + | GhostVarAvailable v -> ghost_var_available ctx v + | YamlEntryGlobal (g, task) -> + let g: V.t = Obj.obj g in + begin match g with + | `Right true when YamlWitness.entry_type_enabled YamlWitnessType.GhostInstrumentation.entry_type -> + let nodes = G.update (ctx.global g) in + let (variables, location_updates) = NodeSet.fold (fun node (variables, location_updates) -> + let (locked, unlocked, multithread) = G.node (ctx.global (V.node node)) in + let variables' = + Locked.fold (fun l acc -> + match mustlock_of_addr l with + | Some l when ghost_var_available ctx (Locked l) -> + let variable = WitnessGhost.variable' (Locked l) in + VariableSet.add variable acc + | _ -> + acc + ) (Locked.union locked unlocked) variables + in + let updates = + Locked.fold (fun l acc -> + match mustlock_of_addr l with + | Some l when ghost_var_available ctx (Locked l) -> + let update = WitnessGhost.update' (Locked l) GoblintCil.one in + update :: acc + | _ -> + acc + ) locked [] + in + let updates = + Unlocked.fold (fun l acc -> + match mustlock_of_addr l with + | Some l when ghost_var_available ctx (Locked l) -> + let update = WitnessGhost.update' (Locked l) GoblintCil.zero in + update :: acc + | _ -> + acc + ) unlocked updates + in + let (variables', updates) = + if not (GobConfig.get_bool "exp.earlyglobs") && multithread then ( + if ghost_var_available ctx Multithreaded then ( + let variable = WitnessGhost.variable' Multithreaded in + let update = WitnessGhost.update' Multithreaded GoblintCil.one in + let variables' = VariableSet.add variable variables' in + (variables', update :: updates) + ) + else + (variables', updates) + ) + else + (variables', updates) + in + match updates with + | [] -> (variables', location_updates) (* don't add location_update with no updates *) + | _ -> + let location_update = WitnessGhost.location_update' ~node ~updates in + (variables', location_update :: location_updates) + ) nodes (VariableSet.empty, []) + in + let entry = WitnessGhost.instrumentation_entry ~task ~variables:(VariableSet.elements variables) ~location_updates in + Queries.YS.singleton entry + | `Left _ -> Queries.Result.top q + | `Middle _ -> Queries.Result.top q + | `Right _ -> Queries.Result.top q + end + | InvariantGlobalNodes -> (G.threadcreate (ctx.global V.threadcreate): NodeSet.t) + | _ -> Queries.Result.top q +end + +let _ = + MCP.register_analysis ~dep:["mutexEvents"] (module Spec : MCPSpec) diff --git a/src/analyses/unassumeAnalysis.ml b/src/analyses/unassumeAnalysis.ml index 707e0f4820..1b430e651a 100644 --- a/src/analyses/unassumeAnalysis.ml +++ b/src/analyses/unassumeAnalysis.ml @@ -239,13 +239,13 @@ struct | false, (LocationInvariant _ | LoopInvariant _ | PreconditionLoopInvariant _ | InvariantSet _) -> M.info_noloc ~category:Witness "disabled entry of type %s" target_type | _ -> - M.info_noloc ~category:Witness "cannot unassume entry of type %s" target_type + M.warn_noloc ~category:Witness "cannot unassume entry of type %s" target_type in List.iter (fun yaml_entry -> match YamlWitnessType.Entry.of_yaml yaml_entry with | Ok entry -> unassume_entry entry - | Error (`Msg e) -> M.info_noloc ~category:Witness "couldn't parse entry: %s" e + | Error (`Msg e) -> M.error_noloc ~category:Witness "couldn't parse entry: %s" e ) yaml_entries let emit_unassume ctx = diff --git a/src/analyses/varEq.ml b/src/analyses/varEq.ml index 78013ec21d..b220afc0d9 100644 --- a/src/analyses/varEq.ml +++ b/src/analyses/varEq.ml @@ -562,7 +562,7 @@ struct let r = eq_set_clos e ctx.local in if M.tracing then M.tracel "var_eq" "equalset %a = %a" d_plainexp e Queries.ES.pretty r; r - | Queries.Invariant context when GobConfig.get_bool "witness.invariant.exact" -> (* only exact equalities here *) + | Queries.Invariant context when GobConfig.get_bool "ana.var_eq.invariant.enabled" && GobConfig.get_bool "witness.invariant.exact" -> (* only exact equalities here *) let scope = Node.find_fundec ctx.node in D.invariant ~scope ctx.local | _ -> Queries.Result.top x diff --git a/src/analyses/wrapperFunctionAnalysis.ml b/src/analyses/wrapperFunctionAnalysis.ml index eb9ec6ce02..32ca234e70 100644 --- a/src/analyses/wrapperFunctionAnalysis.ml +++ b/src/analyses/wrapperFunctionAnalysis.ml @@ -144,6 +144,8 @@ module MallocWrapper : MCPSpec = struct Format.dprintf "@tid:%s" (ThreadLifted.show t) in Format.asprintf "(alloc@sid:%s%t%t)" (Node.show_id node) tid uniq_count + + let typ _ = GoblintCil.voidType end module NodeVarinfoMap = RichVarinfo.BiVarinfoMap.Make(ThreadNode) diff --git a/src/build-info/build_info_dune/dune b/src/build-info/build_info_dune/dune deleted file mode 100644 index ec46f4b3d1..0000000000 --- a/src/build-info/build_info_dune/dune +++ /dev/null @@ -1,6 +0,0 @@ -; goblint.build-info implementation which properly uses dune-build-info -(library - (name goblint_build_info_dune) - (public_name goblint.build-info.dune) - (implements goblint.build-info) - (libraries dune-build-info)) diff --git a/src/build-info/build_info_js/dune b/src/build-info/build_info_js/dune deleted file mode 100644 index 9400f564ff..0000000000 --- a/src/build-info/build_info_js/dune +++ /dev/null @@ -1,5 +0,0 @@ -; goblint.build-info implementation which works with js_of_ocaml and doesn't use dune-build-info -(library - (name goblint_build_info_js) - (public_name goblint.build-info.js) - (implements goblint.build-info)) diff --git a/src/build-info/build_info_js/dune_build_info.ml b/src/build-info/build_info_js/dune_build_info.ml deleted file mode 100644 index 002015cd31..0000000000 --- a/src/build-info/build_info_js/dune_build_info.ml +++ /dev/null @@ -1 +0,0 @@ -let statically_linked_libraries = [] diff --git a/src/build-info/dune b/src/build-info/dune index 1dd74c192c..085660531e 100644 --- a/src/build-info/dune +++ b/src/build-info/dune @@ -1,14 +1,9 @@ (include_subdirs no) -; virtual library to allow js build (for gobview) without dune-build-info -; dune-build-info seems to be incompatible with js_of_ocaml -; File "gobview/src/.App.eobjs/build_info_data.ml-gen", line 1: -; Error: Could not find the .cmi file for interface -; gobview/src/.App.eobjs/build_info_data.ml-gen. (library (name goblint_build_info) (public_name goblint.build-info) - (virtual_modules dune_build_info)) + (libraries dune-build-info)) (rule (target configVersion.ml) diff --git a/src/build-info/build_info_dune/dune_build_info.ml b/src/build-info/dune_build_info.ml similarity index 100% rename from src/build-info/build_info_dune/dune_build_info.ml rename to src/build-info/dune_build_info.ml diff --git a/src/cdomain/value/cdomains/int/congruenceDomain.ml b/src/cdomain/value/cdomains/int/congruenceDomain.ml new file mode 100644 index 0000000000..003e33a624 --- /dev/null +++ b/src/cdomain/value/cdomains/int/congruenceDomain.ml @@ -0,0 +1,496 @@ +open IntDomain0 +open GoblintCil + + +module Congruence : S with type int_t = Z.t and type t = (Z.t * Z.t) option = +struct + let name () = "congruences" + type int_t = Z.t + + (* represents congruence class of c mod m, None is bot *) + type t = (Z.t * Z.t) option [@@deriving eq, ord, hash] + + let ( *: ) = Z.mul + let (+:) = Z.add + let (-:) = Z.sub + let (%:) = Z.rem + let (/:) = Z.div + let (=:) = Z.equal + let (<:) x y = Z.compare x y < 0 + let (>:) x y = Z.compare x y > 0 + let (<=:) x y = Z.compare x y <= 0 + let (>=:) x y = Z.compare x y >= 0 + (* a divides b *) + let ( |: ) a b = + if a =: Z.zero then false else (b %: a) =: Z.zero + + let normalize ik x = + match x with + | None -> None + | Some (c, m) -> + if m =: Z.zero then + if should_wrap ik then + Some (Size.cast ik c, m) + else + Some (c, m) + else + let m' = Z.abs m in + let c' = c %: m' in + if c' <: Z.zero then + Some (c' +: m', m') + else + Some (c' %: m', m') + + let range ik = Size.range ik + + let top () = Some (Z.zero, Z.one) + let top_of ik = Some (Z.zero, Z.one) + let bot () = None + let bot_of ik = bot () + + let show = function ik -> match ik with + | None -> "⟂" + | Some (c, m) when (c, m) = (Z.zero, Z.zero) -> Z.to_string c + | Some (c, m) -> + let a = if c =: Z.zero then "" else Z.to_string c in + let b = if m =: Z.zero then "" else if m = Z.one then "ℤ" else Z.to_string m^"ℤ" in + let c = if a = "" || b = "" then "" else "+" in + a^c^b + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let is_top x = x = top () + + let equal_to i = function + | None -> failwith "unsupported: equal_to with bottom" + | Some (a, b) when b =: Z.zero -> if a =: i then `Eq else `Neq + | Some (a, b) -> if i %: b =: a then `Top else `Neq + + let leq (x:t) (y:t) = + match x, y with + | None, _ -> true + | Some _, None -> false + | Some (c1,m1), Some (c2,m2) when m2 =: Z.zero && m1 =: Z.zero -> c1 =: c2 + | Some (c1,m1), Some (c2,m2) when m2 =: Z.zero -> c1 =: c2 && m1 =: Z.zero + | Some (c1,m1), Some (c2,m2) -> m2 |: Z.gcd (c1 -: c2) m1 + (* Typo in original equation of P. Granger (m2 instead of m1): gcd (c1 -: c2) m2 + Reference: https://doi.org/10.1080/00207168908803778 Page 171 corollary 3.3*) + + let leq x y = + let res = leq x y in + if M.tracing then M.trace "congruence" "leq %a %a -> %a " pretty x pretty y pretty (Some (Z.of_int (Bool.to_int res), Z.zero)) ; + res + + let join ik (x:t) y = + match x, y with + | None, z | z, None -> z + | Some (c1,m1), Some (c2,m2) -> + let m3 = Z.gcd m1 (Z.gcd m2 (c1 -: c2)) in + normalize ik (Some (c1, m3)) + + let join ik (x:t) y = + let res = join ik x y in + if M.tracing then M.trace "congruence" "join %a %a -> %a" pretty x pretty y pretty res; + res + + + let meet ik x y = + (* if it exists, c2/a2 is solution to a*x ≡ c (mod m) *) + let congruence_series a c m = + let rec next a1 c1 a2 c2 = + if a2 |: a1 then (a2, c2) + else next a2 c2 (a1 %: a2) (c1 -: (c2 *: (a1 /: a2))) + in next m Z.zero a c + in + let simple_case i c m = + if m |: (i -: c) + then Some (i, Z.zero) else None + in + match x, y with + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero -> if c1 =: c2 then Some (c1, Z.zero) else None + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero -> simple_case c1 c2 m2 + | Some (c1, m1), Some (c2, m2) when m2 =: Z.zero -> simple_case c2 c1 m1 + | Some (c1, m1), Some (c2, m2) when (Z.gcd m1 m2) |: (c1 -: c2) -> + let (c, m) = congruence_series m1 (c2 -: c1 ) m2 in + normalize ik (Some(c1 +: (m1 *: (m /: c)), m1 *: (m2 /: c))) + | _ -> None + + let meet ik x y = + let res = meet ik x y in + if M.tracing then M.trace "congruence" "meet %a %a -> %a" pretty x pretty y pretty res; + res + + let to_int = function Some (c, m) when m =: Z.zero -> Some c | _ -> None + let of_int ik (x: int_t) = normalize ik @@ Some (x, Z.zero) + let zero = Some (Z.zero, Z.zero) + let one = Some (Z.one, Z.zero) + let top_bool = top() + + let of_bool _ik = function true -> one | false -> zero + + let to_bool (a: t) = match a with + | None -> None + | x when equal zero x -> Some false + | x -> if leq zero x then None else Some true + + let starting ?(suppress_ovwarn=false) ik n = top() + + let ending = starting + + let of_congruence ik (c,m) = normalize ik @@ Some(c,m) + + let maximal t = match t with + | Some (x, y) when y =: Z.zero -> Some x + | _ -> None + + let minimal t = match t with + | Some (x,y) when y =: Z.zero -> Some x + | _ -> None + + (* cast from original type to ikind, set to top if the value doesn't fit into the new type *) + let cast_to ?(suppress_ovwarn=false) ?torg ?(no_ov=false) t x = + match x with + | None -> None + | Some (c, m) when m =: Z.zero -> + let c' = Size.cast t c in + (* When casting into a signed type and the result does not fit, the behavior is implementation-defined. (C90 6.2.1.2, C99 and C11 6.3.1.3) *) + (* We go with GCC behavior here: *) + (* For conversion to a type of width N, the value is reduced modulo 2^N to be within range of the type; no signal is raised. *) + (* (https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html) *) + (* Clang behaves the same but they never document that anywhere *) + Some (c', m) + | _ -> + let (min_t, max_t) = range t in + let p ikorg = + let (min_ikorg, max_ikorg) = range ikorg in + ikorg = t || (max_t >=: max_ikorg && min_t <=: min_ikorg) + in + match torg with + | Some (Cil.TInt (ikorg, _)) when p ikorg -> + if M.tracing then M.trace "cong-cast" "some case"; + x + | _ -> top () + + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov (t : Cil.ikind) x = + let pretty_bool _ x = Pretty.text (string_of_bool x) in + let res = cast_to ?torg ?no_ov t x in + if M.tracing then M.trace "cong-cast" "Cast %a to %a (no_ov: %a) = %a" pretty x Cil.d_ikind t (Pretty.docOpt (pretty_bool ())) no_ov pretty res; + res + + let widen = join + + let widen ik x y = + let res = widen ik x y in + if M.tracing then M.trace "congruence" "widen %a %a -> %a" pretty x pretty y pretty res; + res + + let narrow = meet + + let log f ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> bot_of ik + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_bool i1, to_bool i2 with + | Some x, Some y -> of_bool ik (f x y) + | _ -> top_of ik + + let c_logor = log (||) + let c_logand = log (&&) + + let log1 f ik i1 = + if is_bot i1 then + bot_of ik + else + match to_bool i1 with + | Some x -> of_bool ik (f ik x) + | _ -> top_of ik + + let c_lognot = log1 (fun _ik -> not) + + let shift_right _ _ _ = top() + + let shift_right ik x y = + let res = shift_right ik x y in + if M.tracing then M.trace "congruence" "shift_right : %a %a becomes %a " pretty x pretty y pretty res; + res + + let shift_left ik x y = + (* Naive primality test *) + (* let is_prime n = + let n = Z.abs n in + let rec is_prime' d = + (d *: d >: n) || ((not ((n %: d) =: Z.zero)) && (is_prime' [@tailcall]) (d +: Z.one)) + in + not (n =: Z.one) && is_prime' (Z.of_int 2) + in *) + match x, y with + | None, None -> None + | None, _ + | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c, m), Some (c', m') when Cil.isSigned ik || c <: Z.zero || c' <: Z.zero -> top_of ik + | Some (c, m), Some (c', m') -> + let (_, max_ik) = range ik in + if m =: Z.zero && m' =: Z.zero then + normalize ik @@ Some (Z.logand max_ik (Z.shift_left c (Z.to_int c')), Z.zero) + else + let x = Z.logand max_ik (Z.shift_left Z.one (Z.to_int c')) in (* 2^c' *) + (* TODO: commented out because fails test with _Bool *) + (* if is_prime (m' +: Z.one) then + normalize ik @@ Some (x *: c, Z.gcd (x *: m) ((c *: x) *: (m' +: Z.one))) + else *) + normalize ik @@ Some (x *: c, Z.gcd (x *: m) (c *: x)) + + let shift_left ik x y = + let res = shift_left ik x y in + if M.tracing then M.trace "congruence" "shift_left : %a %a becomes %a " pretty x pretty y pretty res; + res + + (* Handle unsigned overflows. + From n === k mod (2^a * b), we conclude n === k mod 2^a, for a <= bitwidth. + The congruence modulo b may not persist on an overflow. *) + let handle_overflow ik (c, m) = + if m =: Z.zero then + normalize ik (Some (c, m)) + else + (* Find largest m'=2^k (for some k) such that m is divisible by m' *) + let tz = Z.trailing_zeros m in + let m' = Z.shift_left Z.one tz in + + let max = (snd (Size.range ik)) +: Z.one in + if m' >=: max then + (* if m' >= 2 ^ {bitlength}, there is only one value in range *) + let c' = c %: max in + Some (c', Z.zero) + else + normalize ik (Some (c, m')) + + let mul ?(no_ov=false) ik x y = + let no_ov_case (c1, m1) (c2, m2) = + c1 *: c2, Z.gcd (c1 *: m2) (Z.gcd (m1 *: c2) (m1 *: m2)) + in + match x, y with + | None, None -> bot () + | None, _ | _, None -> + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c1, m1), Some (c2, m2) when no_ov -> + Some (no_ov_case (c1, m1) (c2, m2)) + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero && not (Cil.isSigned ik) -> + let (_, max_ik) = range ik in + Some ((c1 *: c2) %: (max_ik +: Z.one), Z.zero) + | Some a, Some b when not (Cil.isSigned ik) -> + handle_overflow ik (no_ov_case a b ) + | _ -> top () + + let mul ?no_ov ik x y = + let res = mul ?no_ov ik x y in + if M.tracing then M.trace "congruence" "mul : %a %a -> %a " pretty x pretty y pretty res; + res + + let neg ?(no_ov=false) ik x = + match x with + | None -> bot() + | Some _ -> mul ~no_ov ik (of_int ik (Z.of_int (-1))) x + + let add ?(no_ov=false) ik x y = + let no_ov_case (c1, m1) (c2, m2) = + c1 +: c2, Z.gcd m1 m2 + in + match (x, y) with + | None, None -> bot () + | None, _ | _, None -> + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some a, Some b when no_ov -> + normalize ik (Some (no_ov_case a b)) + | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero && not (Cil.isSigned ik) -> + let (_, max_ik) = range ik in + Some((c1 +: c2) %: (max_ik +: Z.one), Z.zero) + | Some a, Some b when not (Cil.isSigned ik) -> + handle_overflow ik (no_ov_case a b) + | _ -> top () + + + let add ?no_ov ik x y = + let res = add ?no_ov ik x y in + if M.tracing then + M.trace "congruence" "add : %a %a -> %a" pretty x pretty y + pretty res ; + res + + let sub ?(no_ov=false) ik x y = add ~no_ov ik x (neg ~no_ov ik y) + + + let sub ?no_ov ik x y = + let res = sub ?no_ov ik x y in + if M.tracing then + M.trace "congruence" "sub : %a %a -> %a" pretty x pretty y + pretty res ; + res + + let lognot ik x = match x with + | None -> None + | Some (c, m) -> + if (Cil.isSigned ik) then + sub ik (neg ik x) one + else + let (_, max_ik) = range ik in + Some (Z.sub max_ik c, m) + + (** The implementation of the bit operations could be improved based on the master’s thesis + 'Abstract Interpretation and Abstract Domains' written by Stefan Bygde. + see: http://www.es.mdh.se/pdf_publications/948.pdf *) + let bit2 f ik x y = match x, y with + | None, None -> None + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c, m), Some (c', m') -> + if m =: Z.zero && m' =: Z.zero then Some (f c c', Z.zero) + else top () + + let logor ik x y = bit2 Z.logor ik x y + + let logand ik x y = match x, y with + | None, None -> None + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c, m), Some (c', m') -> + if m =: Z.zero && m' =: Z.zero then + (* both arguments constant *) + Some (Z.logand c c', Z.zero) + else if m' =: Z.zero && c' =: Z.one && Z.rem m (Z.of_int 2) =: Z.zero then + (* x & 1 and x == c (mod 2*z) *) + (* Value is equal to LSB of c *) + Some (Z.logand c c', Z.zero) + else + top () + + let logxor ik x y = bit2 Z.logxor ik x y + + let rem ik x y = + match x, y with + | None, None -> bot() + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c1, m1), Some(c2, m2) -> + if m2 =: Z.zero then + if (c2 |: m1) && (c1 %: c2 =: Z.zero || m1 =: Z.zero || not (Cil.isSigned ik)) then + Some (c1 %: c2, Z.zero) + else + normalize ik (Some (c1, (Z.gcd m1 c2))) + else + normalize ik (Some (c1, Z.gcd m1 (Z.gcd c2 m2))) + + let rem ik x y = let res = rem ik x y in + if M.tracing then M.trace "congruence" "rem : %a %a -> %a " pretty x pretty y pretty res; + res + + let div ?(no_ov=false) ik x y = + match x,y with + | None, None -> bot () + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | _, x when leq zero x -> top () + | Some(c1, m1), Some(c2, m2) when not no_ov && m2 =: Z.zero && c2 =: Z.neg Z.one -> top () + | Some(c1, m1), Some(c2, m2) when m1 =: Z.zero && m2 =: Z.zero -> Some (c1 /: c2, Z.zero) + | Some(c1, m1), Some(c2, m2) when m2 =: Z.zero && c2 |: m1 && c2 |: c1 -> Some (c1 /: c2, m1 /: c2) + | _, _ -> top () + + + let div ?no_ov ik x y = + let res = div ?no_ov ik x y in + if M.tracing then + M.trace "congruence" "div : %a %a -> %a" pretty x pretty y pretty + res ; + res + + let ne ik (x: t) (y: t) = match x, y with + | Some (c1, m1), Some (c2, m2) when (m1 =: Z.zero) && (m2 =: Z.zero) -> of_bool ik (not (c1 =: c2 )) + | x, y -> if meet ik x y = None then of_bool ik true else top_bool + + let eq ik (x: t) (y: t) = match x, y with + | Some (c1, m1), Some (c2, m2) when (m1 =: Z.zero) && (m2 =: Z.zero) -> of_bool ik (c1 =: c2) + | x, y -> if meet ik x y <> None then top_bool else of_bool ik false + + let comparison ik op x y = match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (c1, m1), Some (c2, m2) -> + if m1 =: Z.zero && m2 =: Z.zero then + if op c1 c2 then of_bool ik true else of_bool ik false + else + top_bool + + let ge ik x y = comparison ik (>=:) x y + + let ge ik x y = + let res = ge ik x y in + if M.tracing then M.trace "congruence" "greater or equal : %a %a -> %a " pretty x pretty y pretty res; + res + + let le ik x y = comparison ik (<=:) x y + + let le ik x y = + let res = le ik x y in + if M.tracing then M.trace "congruence" "less or equal : %a %a -> %a " pretty x pretty y pretty res; + res + + let gt ik x y = comparison ik (>:) x y + + + let gt ik x y = + let res = gt ik x y in + if M.tracing then M.trace "congruence" "greater than : %a %a -> %a " pretty x pretty y pretty res; + res + + let lt ik x y = comparison ik (<:) x y + + let lt ik x y = + let res = lt ik x y in + if M.tracing then M.trace "congruence" "less than : %a %a -> %a " pretty x pretty y pretty res; + res + + let invariant_ikind e ik x = + match x with + | x when is_top x -> Invariant.top () + | Some (c, m) when m =: Z.zero -> + IntInvariant.of_int e ik c + | Some (c, m) -> + let open Cil in + let (c, m) = BatTuple.Tuple2.mapn (fun a -> kintegerCilint ik a) (c, m) in + Invariant.of_exp (BinOp (Eq, (BinOp (Mod, e, m, TInt(ik,[]))), c, intType)) + | None -> Invariant.none + + let arbitrary ik = + let open QCheck in + let int_arb = map ~rev:Z.to_int64 Z.of_int64 GobQCheck.Arbitrary.int64 in + let cong_arb = pair int_arb int_arb in + let of_pair ik p = normalize ik (Some p) in + let to_pair = Option.get in + set_print show (map ~rev:to_pair (of_pair ik) cong_arb) + + let refine_with_interval ik (cong : t) (intv : (int_t * int_t ) option) : t = + match intv, cong with + | Some (x, y), Some (c, m) -> + if m =: Z.zero then + if c <: x || c >: y then None else Some (c, Z.zero) + else + let rcx = x +: ((c -: x) %: Z.abs m) in + let lcy = y -: ((y -: c) %: Z.abs m) in + if rcx >: lcy then None + else if rcx =: lcy then Some (rcx, Z.zero) + else cong + | _ -> None + + let refine_with_interval ik (cong : t) (intv : (int_t * int_t) option) : t = + let pretty_intv _ i = + match i with + | Some (l, u) -> Pretty.dprintf "[%a,%a]" GobZ.pretty l GobZ.pretty u + | _ -> Pretty.text ("Display Error") in + let refn = refine_with_interval ik cong intv in + if M.tracing then M.trace "refine" "cong_refine_with_interval %a %a -> %a" pretty cong pretty_intv intv pretty refn; + refn + + let refine_with_congruence ik a b = meet ik a b + let refine_with_excl_list ik a b = a + let refine_with_incl_list ik a b = a + + let project ik p t = t +end diff --git a/src/cdomain/value/cdomains/int/defExcDomain.ml b/src/cdomain/value/cdomains/int/defExcDomain.ml new file mode 100644 index 0000000000..89e4b399aa --- /dev/null +++ b/src/cdomain/value/cdomains/int/defExcDomain.ml @@ -0,0 +1,542 @@ +open IntDomain0 +open IntervalDomain +open GoblintCil + + +module BISet = struct + include SetDomain.Make (IntOps.BigIntOps) + let is_singleton s = cardinal s = 1 +end + +(* The module [Exclusion] constains common functionality about handling of exclusion sets between [DefExc] and [Enums] *) +module Exclusion = +struct + module R = Interval32 + (* We use these types for the functions in this module to make the intended meaning more explicit *) + type t = Exc of BISet.t * Interval32.t + type inc = Inc of BISet.t [@@unboxed] + let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) + let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) + let cardinality_of_range r = Z.succ (Z.add (Z.neg (min_of_range r)) (max_of_range r)) + + let cardinality_BISet s = + Z.of_int (BISet.cardinal s) + + let leq_excl_incl (Exc (xs, r)) (Inc ys) = + (* For a <= b to hold, the cardinalities must fit, i.e. |a| <= |b|, which implies |min_r, max_r| - |xs| <= |ys|. We check this first. *) + let lower_bound_cardinality_a = Z.sub (cardinality_of_range r) (cardinality_BISet xs) in + let card_b = cardinality_BISet ys in + if Z.compare lower_bound_cardinality_a card_b > 0 then + false + else (* The cardinality did fit, so we check for all elements that are represented by range r, whether they are in (xs union ys) *) + let min_a = min_of_range r in + let max_a = max_of_range r in + GobZ.for_all_range (fun el -> BISet.mem el xs || BISet.mem el ys) (min_a, max_a) + + let leq (Exc (xs, r)) (Exc (ys, s)) = + let min_a, max_a = min_of_range r, max_of_range r in + let excluded_check = BISet.for_all (fun y -> BISet.mem y xs || Z.compare y min_a < 0 || Z.compare y max_a > 0) ys in (* if true, then the values ys, that are not in b, also do not occur in a *) + if not excluded_check + then false + else begin (* Check whether all elements that are in the range r, but not in s, are in xs, i.e. excluded. *) + if R.leq r s then true + else begin if Z.compare (cardinality_BISet xs) (Z.sub (cardinality_of_range r) (cardinality_of_range s)) >= 0 (* Check whether the number of excluded elements in a is as least as big as |min_r, max_r| - |min_s, max_s| *) + then + let min_b, max_b = min_of_range s, max_of_range s in + let leq1 = (* check whether the elements in [r_l; s_l-1] are all in xs, i.e. excluded *) + if Z.compare min_a min_b < 0 then + GobZ.for_all_range (fun x -> BISet.mem x xs) (min_a, Z.pred min_b) + else + true + in + let leq2 () = (* check whether the elements in [s_u+1; r_u] are all in xs, i.e. excluded *) + if Z.compare max_b max_a < 0 then + GobZ.for_all_range (fun x -> BISet.mem x xs) (Z.succ max_b, max_a) + else + true + in + leq1 && (leq2 ()) + else + false + end + end +end + +module DefExc : S with type int_t = Z.t = (* definite or set of excluded values *) +struct + module S = BISet + module R = Interval32 (* range for exclusion *) + + (* Ikind used for intervals representing the domain *) + let range_ikind = Cil.IInt + let size t = R.of_interval range_ikind (let a,b = Size.bits_i64 t in Int64.neg a,b) + + + type t = [ + | `Excluded of S.t * R.t + | `Definite of Z.t + | `Bot + ] [@@deriving eq, ord, hash] + type int_t = Z.t + let name () = "def_exc" + + + let top_range = R.of_interval range_ikind (-99L, 99L) (* Since there is no top ikind we use a range that includes both ILongLong [-63,63] and IULongLong [0,64]. Only needed for intermediate range computation on longs. Correct range is set by cast. *) + let top () = `Excluded (S.empty (), top_range) + let bot () = `Bot + let top_of ik = `Excluded (S.empty (), size ik) + let bot_of ik = bot () + + let show x = + let short_size x = "("^R.show x^")" in + match x with + | `Bot -> "Error int" + | `Definite x -> Z.to_string x + (* Print the empty exclusion as if it was a distinct top element: *) + | `Excluded (s,l) when S.is_empty s -> "Unknown int" ^ short_size l + (* Prepend the exclusion sets with something: *) + | `Excluded (s,l) -> "Not " ^ S.show s ^ short_size l + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let maximal = function + | `Definite x -> Some x + | `Excluded (s,r) -> Some (Exclusion.max_of_range r) + | `Bot -> None + + let minimal = function + | `Definite x -> Some x + | `Excluded (s,r) -> Some (Exclusion.min_of_range r) + | `Bot -> None + + let in_range r i = + if Z.compare i Z.zero < 0 then + let lowerb = Exclusion.min_of_range r in + Z.compare lowerb i <= 0 + else + let upperb = Exclusion.max_of_range r in + Z.compare i upperb <= 0 + + let is_top x = x = top () + + let equal_to i = function + | `Bot -> failwith "unsupported: equal_to with bottom" + | `Definite x -> if i = x then `Eq else `Neq + | `Excluded (s,r) -> if S.mem i s then `Neq else `Top + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik = function + | `Excluded (s,r) -> + let r' = size ik in + if R.leq r r' then (* upcast -> no change *) + `Excluded (s, r) + else if ik = IBool then (* downcast to bool *) + if S.mem Z.zero s then + `Definite Z.one + else + `Excluded (S.empty(), r') + else + (* downcast: may overflow *) + (* let s' = S.map (Size.cast ik) s in *) + (* We want to filter out all i in s' where (t)x with x in r could be i. *) + (* Since this is hard to compute, we just keep all i in s' which overflowed, since those are safe - all i which did not overflow may now be possible due to overflow of r. *) + (* S.diff s' s, r' *) + (* The above is needed for test 21/03, but not sound! See example https://github.com/goblint/analyzer/pull/95#discussion_r483023140 *) + `Excluded (S.empty (), r') + | `Definite x -> `Definite (Size.cast ik x) + | `Bot -> `Bot + + (* Wraps definite values and excluded values according to the ikind. + * For an `Excluded s,r , assumes that r is already an overapproximation of the range of possible values. + * r might be larger than the possible range of this type; the range of the returned `Excluded set will be within the bounds of the ikind. + *) + let norm ik v = + match v with + | `Excluded (s, r) -> + let possibly_overflowed = not (R.leq r (size ik)) || not (S.for_all (in_range (size ik)) s) in + (* If no overflow occurred, just return x *) + if not possibly_overflowed then ( + v + ) + (* Else, if an overflow might have occurred but we should just ignore it *) + else if should_ignore_overflow ik then ( + let r = size ik in + (* filter out excluded elements that are not in the range *) + let mapped_excl = S.filter (in_range r) s in + `Excluded (mapped_excl, r) + ) + (* Else, if an overflow occurred that we should not treat with wrap-around, go to top *) + else if not (should_wrap ik) then ( + top_of ik + ) else ( + (* Else an overflow occurred that we should treat with wrap-around *) + let r = size ik in + (* Perform a wrap-around for unsigned values and for signed values (if configured). *) + let mapped_excl = S.map (fun excl -> Size.cast ik excl) s in + match ik with + | IBool -> + begin match S.mem Z.zero mapped_excl, S.mem Z.one mapped_excl with + | false, false -> `Excluded (mapped_excl, r) (* Not {} -> Not {} *) + | true, false -> `Definite Z.one (* Not {0} -> 1 *) + | false, true -> `Definite Z.zero (* Not {1} -> 0 *) + | true, true -> `Bot (* Not {0, 1} -> bot *) + end + | ik -> + `Excluded (mapped_excl, r) + ) + | `Definite x -> + let min, max = Size.range ik in + (* Perform a wrap-around for unsigned values and for signed values (if configured). *) + if should_wrap ik then ( + cast_to ik v + ) + else if Z.compare min x <= 0 && Z.compare x max <= 0 then ( + v + ) + else if should_ignore_overflow ik then ( + M.warn ~category:M.Category.Integer.overflow "DefExc: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Bot"; + `Bot + ) + else ( + top_of ik + ) + | `Bot -> `Bot + + let leq x y = match (x,y) with + (* `Bot <= x is always true *) + | `Bot, _ -> true + (* Anything except bot <= bot is always false *) + | _, `Bot -> false + (* Two known values are leq whenever equal *) + | `Definite (x: int_t), `Definite y -> x = y + (* A definite value is leq all exclusion sets that don't contain it *) + | `Definite x, `Excluded (s,r) -> in_range r x && not (S.mem x s) + (* No finite exclusion set can be leq than a definite value *) + | `Excluded (xs, xr), `Definite d -> + Exclusion.(leq_excl_incl (Exc (xs, xr)) (Inc (S.singleton d))) + | `Excluded (xs,xr), `Excluded (ys,yr) -> + Exclusion.(leq (Exc (xs,xr)) (Exc (ys, yr))) + + let join' ?range ik x y = + match (x,y) with + (* The least upper bound with the bottom element: *) + | `Bot, x -> x + | x, `Bot -> x + (* The case for two known values: *) + | `Definite (x: int_t), `Definite y -> + (* If they're equal, it's just THAT value *) + if x = y then `Definite x + (* Unless one of them is zero, we can exclude it: *) + else + let a,b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in + let r = R.join (R.of_interval range_ikind a) (R.of_interval range_ikind b) in + `Excluded ((if Z.equal x Z.zero || Z.equal y Z.zero then S.empty () else S.singleton Z.zero), r) + (* A known value and an exclusion set... the definite value should no + * longer be excluded: *) + | `Excluded (s,r), `Definite x + | `Definite x, `Excluded (s,r) -> + if not (in_range r x) then + let a = R.of_interval range_ikind (Size.min_range_sign_agnostic x) in + `Excluded (S.remove x s, R.join a r) + else + `Excluded (S.remove x s, r) + (* For two exclusion sets, only their intersection can be excluded: *) + | `Excluded (x,wx), `Excluded (y,wy) -> `Excluded (S.inter x y, range |? R.join wx wy) + + let join ik = join' ik + + + let widen ik x y = + if get_def_exc_widen_by_join () then + join' ik x y + else if equal x y then + x + else + join' ~range:(size ik) ik x y + + + let meet ik x y = + match (x,y) with + (* Greatest LOWER bound with the least element is trivial: *) + | `Bot, _ -> `Bot + | _, `Bot -> `Bot + (* Definite elements are either equal or the glb is bottom *) + | `Definite x, `Definite y -> if x = y then `Definite x else `Bot + (* The glb of a definite element and an exclusion set is either bottom or + * just the element itself, if it isn't in the exclusion set *) + | `Excluded (s,r), `Definite x + | `Definite x, `Excluded (s,r) -> if S.mem x s || not (in_range r x) then `Bot else `Definite x + (* The greatest lower bound of two exclusion sets is their union, this is + * just DeMorgans Law *) + | `Excluded (x,r1), `Excluded (y,r2) -> + let r' = R.meet r1 r2 in + let s' = S.union x y |> S.filter (in_range r') in + `Excluded (s', r') + + let narrow ik x y = x + + let of_int ik x = norm ik @@ `Definite x + let to_int x = match x with + | `Definite x -> Some x + | _ -> None + + let from_excl ikind (s: S.t) = norm ikind @@ `Excluded (s, size ikind) + + let of_bool_cmp ik x = of_int ik (if x then Z.one else Z.zero) + let of_bool = of_bool_cmp + let to_bool x = + match x with + | `Definite x -> Some (IntOps.BigIntOps.to_bool x) + | `Excluded (s,r) when S.mem Z.zero s -> Some true + | _ -> None + let top_bool = `Excluded (S.empty (), R.of_interval range_ikind (0L, 1L)) + + let of_interval ?(suppress_ovwarn=false) ik (x,y) = + if Z.compare x y = 0 then + of_int ik x + else + let a, b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in + let r = R.join (R.of_interval ~suppress_ovwarn range_ikind a) (R.of_interval ~suppress_ovwarn range_ikind b) in + let ex = if Z.gt x Z.zero || Z.lt y Z.zero then S.singleton Z.zero else S.empty () in + norm ik @@ (`Excluded (ex, r)) + + let starting ?(suppress_ovwarn=false) ikind x = + let _,u_ik = Size.range ikind in + of_interval ~suppress_ovwarn ikind (x, u_ik) + + let ending ?(suppress_ovwarn=false) ikind x = + let l_ik,_ = Size.range ikind in + of_interval ~suppress_ovwarn ikind (l_ik, x) + + let of_excl_list t l = + let r = size t in (* elements in l are excluded from the full range of t! *) + `Excluded (List.fold_right S.add l (S.empty ()), r) + let is_excl_list l = match l with `Excluded _ -> true | _ -> false + let to_excl_list (x:t) = match x with + | `Definite _ -> None + | `Excluded (s,r) -> Some (S.elements s, (Option.get (R.minimal r), Option.get (R.maximal r))) + | `Bot -> None + + let to_incl_list x = match x with + | `Definite x -> Some [x] + | `Excluded _ -> None + | `Bot -> None + + let apply_range f r = (* apply f to the min/max of the old range r to get a new range *) + (* If the Int64 might overflow on us during computation, we instead go to top_range *) + match R.minimal r, R.maximal r with + | _ -> + let rf m = (size % Size.min_for % f) (m r) in + let r1, r2 = rf Exclusion.min_of_range, rf Exclusion.max_of_range in + R.join r1 r2 + + (* Default behaviour for unary operators, simply maps the function to the + * DefExc data structure. *) + let lift1 f ik x = norm ik @@ match x with + | `Excluded (s,r) -> + let s' = S.map f s in + `Excluded (s', apply_range f r) + | `Definite x -> `Definite (f x) + | `Bot -> `Bot + + let lift2 f ik x y = norm ik (match x,y with + (* We don't bother with exclusion sets: *) + | `Excluded _, `Definite _ + | `Definite _, `Excluded _ + | `Excluded _, `Excluded _ -> top () + (* The good case: *) + | `Definite x, `Definite y -> + (try `Definite (f x y) with | Division_by_zero -> top ()) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y)))) + + (* Default behaviour for binary operators that are injective in either + * argument, so that Exclusion Sets can be used: *) + let lift2_inj f ik x y = + let def_exc f x s r = `Excluded (S.map (f x) s, apply_range (f x) r) in + norm ik @@ + match x,y with + (* If both are exclusion sets, there isn't anything we can do: *) + | `Excluded _, `Excluded _ -> top () + (* A definite value should be applied to all members of the exclusion set *) + | `Definite x, `Excluded (s,r) -> def_exc f x s r + (* Same thing here, but we should flip the operator to map it properly *) + | `Excluded (s,r), `Definite x -> def_exc (Batteries.flip f) x s r + (* The good case: *) + | `Definite x, `Definite y -> `Definite (f x y) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + + (* The equality check: *) + let eq ik x y = match x,y with + (* Not much to do with two exclusion sets: *) + | `Excluded _, `Excluded _ -> top () + (* Is x equal to an exclusion set, if it is a member then NO otherwise we + * don't know: *) + | `Definite x, `Excluded (s,r) -> if S.mem x s then of_bool IInt false else top () + | `Excluded (s,r), `Definite x -> if S.mem x s then of_bool IInt false else top () + (* The good case: *) + | `Definite x, `Definite y -> of_bool IInt (x = y) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + + (* The inequality check: *) + let ne ik x y = match x,y with + (* Not much to do with two exclusion sets: *) + | `Excluded _, `Excluded _ -> top () + (* Is x unequal to an exclusion set, if it is a member then Yes otherwise we + * don't know: *) + | `Definite x, `Excluded (s,r) -> if S.mem x s then of_bool IInt true else top () + | `Excluded (s,r), `Definite x -> if S.mem x s then of_bool IInt true else top () + (* The good case: *) + | `Definite x, `Definite y -> of_bool IInt (x <> y) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + + let neg ?no_ov ik (x :t) = norm ik @@ lift1 Z.neg ik x + let add ?no_ov ik x y = norm ik @@ lift2_inj Z.add ik x y + + let sub ?no_ov ik x y = norm ik @@ lift2_inj Z.sub ik x y + let mul ?no_ov ik x y = norm ik @@ match x, y with + | `Definite z, (`Excluded _ | `Definite _) when Z.equal z Z.zero -> x + | (`Excluded _ | `Definite _), `Definite z when Z.equal z Z.zero -> y + | `Definite a, `Excluded (s,r) + (* Integer multiplication with even numbers is not injective. *) + (* Thus we cannot exclude the values to which the exclusion set would be mapped to. *) + | `Excluded (s,r),`Definite a when Z.equal (Z.rem a (Z.of_int 2)) Z.zero -> `Excluded (S.empty (), apply_range (Z.mul a) r) + | _ -> lift2_inj Z.mul ik x y + let div ?no_ov ik x y = lift2 Z.div ik x y + let rem ik x y = lift2 Z.rem ik x y + + (* Comparison handling copied from Enums. *) + let handle_bot x y f = match x, y with + | `Bot, `Bot -> `Bot + | `Bot, _ + | _, `Bot -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | _, _ -> f () + + let lt ik x y = + handle_bot x y (fun () -> + match minimal x, maximal x, minimal y, maximal y with + | _, Some x2, Some y1, _ when Z.compare x2 y1 < 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 >= 0 -> of_bool ik false + | _, _, _, _ -> top_bool) + + let gt ik x y = lt ik y x + + let le ik x y = + handle_bot x y (fun () -> + match minimal x, maximal x, minimal y, maximal y with + | _, Some x2, Some y1, _ when Z.compare x2 y1 <= 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 > 0 -> of_bool ik false + | _, _, _, _ -> top_bool) + + let ge ik x y = le ik y x + + let lognot = lift1 Z.lognot + + let logand ik x y = norm ik (match x,y with + (* We don't bother with exclusion sets: *) + | `Excluded _, `Definite i -> + (* Except in two special cases *) + if Z.equal i Z.zero then + `Definite Z.zero + else if Z.equal i Z.one then + of_interval IBool (Z.zero, Z.one) + else + top () + | `Definite _, `Excluded _ + | `Excluded _, `Excluded _ -> top () + (* The good case: *) + | `Definite x, `Definite y -> + (try `Definite (Z.logand x y) with | Division_by_zero -> top ()) + | `Bot, `Bot -> `Bot + | _ -> + (* If only one of them is bottom, we raise an exception that eval_rv will catch *) + raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y)))) + + + let logor = lift2 Z.logor + let logxor = lift2 Z.logxor + + let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = + (* BigInt only accepts int as second argument for shifts; perform conversion here *) + let shift_op_big_int a (b: int_t) = + let (b : int) = Z.to_int b in + shift_op a b + in + (* If one of the parameters of the shift is negative, the result is undefined *) + let is_negative = GobOption.for_all (fun x -> Z.lt x Z.zero) in + if is_negative (minimal x) || is_negative (minimal y) then + top_of ik + else + norm ik @@ lift2 shift_op_big_int ik x y + + let shift_left = + shift Z.shift_left + + let shift_right = + shift Z.shift_right + (* TODO: lift does not treat Not {0} as true. *) + let c_logand ik x y = + match to_bool x, to_bool y with + | Some false, _ + | _, Some false -> + of_bool ik false + | _, _ -> + lift2 IntOps.BigIntOps.c_logand ik x y + let c_logor ik x y = + match to_bool x, to_bool y with + | Some true, _ + | _, Some true -> + of_bool ik true + | _, _ -> + lift2 IntOps.BigIntOps.c_logor ik x y + let c_lognot ik = eq ik (of_int ik Z.zero) + + let invariant_ikind e ik (x:t) = + match x with + | `Definite x -> + IntInvariant.of_int e ik x + | `Excluded (s, r) -> + (* Emit range invariant if tighter than ikind bounds. + This can be more precise than interval, which has been widened. *) + let (rmin, rmax) = (Exclusion.min_of_range r, Exclusion.max_of_range r) in + let ri = IntInvariant.of_interval e ik (rmin, rmax) in + let si = IntInvariant.of_excl_list e ik (S.elements s) in + Invariant.(ri && si) + | `Bot -> Invariant.none + + let arbitrary ik = + let open QCheck.Iter in + let excluded s = from_excl ik s in + let definite x = of_int ik x in + let shrink = function + | `Excluded (s, _) -> GobQCheck.shrink (S.arbitrary ()) s >|= excluded (* S TODO: possibly shrink excluded to definite *) + | `Definite x -> (return `Bot) <+> (GobQCheck.shrink (IntOps.BigIntOps.arbitrary ()) x >|= definite) + | `Bot -> empty + in + QCheck.frequency ~shrink ~print:show [ + 20, QCheck.map excluded (S.arbitrary ()); + 10, QCheck.map definite (IntOps.BigIntOps.arbitrary ()); + 1, QCheck.always `Bot + ] (* S TODO: decide frequencies *) + + let refine_with_congruence ik a b = a + let refine_with_interval ik a b = match a, b with + | x, Some(i) -> meet ik x (of_interval ik i) + | _ -> a + let refine_with_excl_list ik a b = match a, b with + | `Excluded (s, r), Some(ls, _) -> meet ik (`Excluded (s, r)) (of_excl_list ik ls) (* TODO: refine with excl range? *) + | _ -> a + let refine_with_incl_list ik a b = a + + let project ik p t = t +end diff --git a/src/cdomain/value/cdomains/int/enumsDomain.ml b/src/cdomain/value/cdomains/int/enumsDomain.ml new file mode 100644 index 0000000000..d1020cfe2d --- /dev/null +++ b/src/cdomain/value/cdomains/int/enumsDomain.ml @@ -0,0 +1,372 @@ +open IntDomain0 +open IntervalDomain +open DefExcDomain +open GoblintCil + + +(* Inclusion/Exclusion sets. Go to top on arithmetic operations (except for some easy cases, e.g. multiplication with 0). Joins on widen, i.e. precise integers as long as not derived from arithmetic expressions. *) +module Enums : S with type int_t = Z.t = struct + module R = Interval32 (* range for exclusion *) + + let range_ikind = Cil.IInt + let size t = R.of_interval range_ikind (let a,b = Size.bits_i64 t in Int64.neg a,b) + + type t = Inc of BISet.t | Exc of BISet.t * R.t [@@deriving eq, ord, hash] (* inclusion/exclusion set *) + + type int_t = Z.t + let name () = "enums" + let bot () = failwith "bot () not implemented for Enums" + let top () = failwith "top () not implemented for Enums" + let bot_of ik = Inc (BISet.empty ()) + let top_bool = Inc (BISet.of_list [Z.zero; Z.one]) + let top_of ik = + match ik with + | IBool -> top_bool + | _ -> Exc (BISet.empty (), size ik) + + let range ik = Size.range ik + +(* + let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) + let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) + let cardinality_of_range r = Z.add (Z.neg (min_of_range r)) (max_of_range r) *) + let value_in_range (min, max) v = Z.compare min v <= 0 && Z.compare v max <= 0 + + let show = function + | Inc xs when BISet.is_empty xs -> "bot" + | Inc xs -> "{" ^ (String.concat ", " (List.map Z.to_string (BISet.elements xs))) ^ "}" + | Exc (xs,r) -> "not {" ^ (String.concat ", " (List.map Z.to_string (BISet.elements xs))) ^ "} " ^ "("^R.show r^")" + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + (* Normalization function for enums, that handles overflows for Inc. + As we do not compute on Excl, we do not have to perform any overflow handling for it. *) + let norm ikind v = + let min, max = range ikind in + (* Whether the value v lies within the values of the specified ikind. *) + let value_in_ikind v = + Z.compare min v <= 0 && Z.compare v max <= 0 + in + match v with + | Inc xs when BISet.for_all value_in_ikind xs -> v + | Inc xs -> + if should_wrap ikind then + Inc (BISet.map (Size.cast ikind) xs) + else if should_ignore_overflow ikind then + Inc (BISet.filter value_in_ikind xs) + else + top_of ikind + | Exc (xs, r) -> + (* The following assert should hold for Exc, therefore we do not have to overflow handling / normalization for it: + let range_in_ikind r = + R.leq r (size ikind) + in + let r_min, r_max = min_of_range r, max_of_range r in + assert (range_in_ikind r && BISet.for_all (value_in_range (r_min, r_max)) xs); *) + begin match ikind with + | IBool -> + begin match BISet.mem Z.zero xs, BISet.mem Z.one xs with + | false, false -> top_bool (* Not {} -> {0, 1} *) + | true, false -> Inc (BISet.singleton Z.one) (* Not {0} -> {1} *) + | false, true -> Inc (BISet.singleton Z.zero) (* Not {1} -> {0} *) + | true, true -> bot_of ikind (* Not {0, 1} -> bot *) + end + | _ -> + v + end + + + let equal_to i = function + | Inc x -> + if BISet.mem i x then + if BISet.is_singleton x then `Eq + else `Top + else `Neq + | Exc (x, r) -> + if BISet.mem i x then `Neq + else `Top + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik v = norm ik @@ match v with + | Exc (s,r) -> + let r' = size ik in + if R.leq r r' then (* upcast -> no change *) + Exc (s, r) + else if ik = IBool then (* downcast to bool *) + if BISet.mem Z.zero s then + Inc (BISet.singleton Z.one) + else + Exc (BISet.empty(), r') + else (* downcast: may overflow *) + Exc ((BISet.empty ()), r') + | Inc xs -> + let casted_xs = BISet.map (Size.cast ik) xs in + if Cil.isSigned ik && not (BISet.equal xs casted_xs) + then top_of ik (* When casting into a signed type and the result does not fit, the behavior is implementation-defined *) + else Inc casted_xs + + let of_int ikind x = cast_to ikind (Inc (BISet.singleton x)) + + let of_interval ?(suppress_ovwarn=false) ik (x, y) = + if Z.compare x y = 0 then + of_int ik x + else + let a, b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in + let r = R.join (R.of_interval ~suppress_ovwarn range_ikind a) (R.of_interval ~suppress_ovwarn range_ikind b) in + let ex = if Z.gt x Z.zero || Z.lt y Z.zero then BISet.singleton Z.zero else BISet.empty () in + norm ik @@ (Exc (ex, r)) + + let join _ x y = + match x, y with + | Inc x, Inc y -> Inc (BISet.union x y) + | Exc (x,r1), Exc (y,r2) -> Exc (BISet.inter x y, R.join r1 r2) + | Exc (x,r), Inc y + | Inc y, Exc (x,r) -> + let r = if BISet.is_empty y + then r + else + let (min_el_range, max_el_range) = Batteries.Tuple2.mapn (fun x -> R.of_interval range_ikind (Size.min_range_sign_agnostic x)) (BISet.min_elt y, BISet.max_elt y) in + let range = R.join min_el_range max_el_range in + R.join r range + in + Exc (BISet.diff x y, r) + + let meet _ x y = + match x, y with + | Inc x, Inc y -> Inc (BISet.inter x y) + | Exc (x,r1), Exc (y,r2) -> + let r = R.meet r1 r2 in + let r_min, r_max = Exclusion.min_of_range r, Exclusion.max_of_range r in + let filter_by_range = BISet.filter (value_in_range (r_min, r_max)) in + (* We remove those elements from the exclusion set that do not fit in the range anyway *) + let excl = BISet.union (filter_by_range x) (filter_by_range y) in + Exc (excl, r) + | Inc x, Exc (y,r) + | Exc (y,r), Inc x -> Inc (BISet.diff x y) + + let widen = join + let narrow = meet + let leq a b = + match a, b with + | Inc xs, Exc (ys, r) -> + if BISet.is_empty xs + then true + else + let min_b, max_b = Exclusion.min_of_range r, Exclusion.max_of_range r in + let min_a, max_a = BISet.min_elt xs, BISet.max_elt xs in + (* Check that the xs fit into the range r *) + Z.compare min_b min_a <= 0 && Z.compare max_a max_b <= 0 && + (* && check that none of the values contained in xs is excluded, i.e. contained in ys. *) + BISet.for_all (fun x -> not (BISet.mem x ys)) xs + | Inc xs, Inc ys -> + BISet.subset xs ys + | Exc (xs, r), Exc (ys, s) -> + Exclusion.(leq (Exc (xs, r)) (Exc (ys, s))) + | Exc (xs, r), Inc ys -> + Exclusion.(leq_excl_incl (Exc (xs, r)) (Inc ys)) + + let handle_bot x y f = match is_bot x, is_bot y with + | false, false -> f () + | true, false + | false, true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | true, true -> Inc (BISet.empty ()) + + let lift1 f ikind v = norm ikind @@ match v with + | Inc x when BISet.is_empty x -> v (* Return bottom when value is bottom *) + | Inc x when BISet.is_singleton x -> Inc (BISet.singleton (f (BISet.choose x))) + | _ -> top_of ikind + + let lift2 f (ikind: Cil.ikind) u v = + handle_bot u v (fun () -> + norm ikind @@ match u, v with + | Inc x,Inc y when BISet.is_singleton x && BISet.is_singleton y -> Inc (BISet.singleton (f (BISet.choose x) (BISet.choose y))) + | _,_ -> top_of ikind) + + let lift2 f ikind a b = + try lift2 f ikind a b with Division_by_zero -> top_of ikind + + let neg ?no_ov = lift1 Z.neg + let add ?no_ov ikind a b = + match a, b with + | Inc z,x when BISet.is_singleton z && BISet.choose z = Z.zero -> x + | x,Inc z when BISet.is_singleton z && BISet.choose z = Z.zero -> x + | x,y -> lift2 Z.add ikind x y + let sub ?no_ov = lift2 Z.sub + let mul ?no_ov ikind a b = + match a, b with + | Inc one,x when BISet.is_singleton one && BISet.choose one = Z.one -> x + | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x + | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a + | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> b + | x,y -> lift2 Z.mul ikind x y + + let div ?no_ov ikind a b = match a, b with + | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x + | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> top_of ikind + | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a + | x,y -> lift2 Z.div ikind x y + + let rem = lift2 Z.rem + + let lognot = lift1 Z.lognot + let logand = lift2 Z.logand + let logor = lift2 Z.logor + let logxor = lift2 Z.logxor + + let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = + handle_bot x y (fun () -> + (* BigInt only accepts int as second argument for shifts; perform conversion here *) + let shift_op_big_int a (b: int_t) = + let (b : int) = Z.to_int b in + shift_op a b + in + (* If one of the parameters of the shift is negative, the result is undefined *) + let is_negative = GobOption.for_all (fun x -> Z.lt x Z.zero) in + if is_negative (minimal x) || is_negative (minimal y) then + top_of ik + else + lift2 shift_op_big_int ik x y) + + let shift_left = + shift Z.shift_left + + let shift_right = + shift Z.shift_right + + let of_bool ikind x = Inc (BISet.singleton (if x then Z.one else Z.zero)) + let to_bool = function + | Inc e when BISet.is_empty e -> None + | Exc (e,_) when BISet.is_empty e -> None + | Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> Some false + | Inc xs when BISet.for_all ((<>) Z.zero) xs -> Some true + | Exc (xs,_) when BISet.exists ((=) Z.zero) xs -> Some true + | _ -> None + let to_int = function Inc x when BISet.is_singleton x -> Some (BISet.choose x) | _ -> None + + let to_excl_list = function Exc (x,r) when not (BISet.is_empty x) -> Some (BISet.elements x, (Option.get (R.minimal r), Option.get (R.maximal r))) | _ -> None + let of_excl_list ik xs = + let min_ik, max_ik = Size.range ik in + let exc = BISet.of_list @@ List.filter (value_in_range (min_ik, max_ik)) xs in + norm ik @@ Exc (exc, size ik) + let is_excl_list = BatOption.is_some % to_excl_list + let to_incl_list = function Inc s when not (BISet.is_empty s) -> Some (BISet.elements s) | _ -> None + + let starting ?(suppress_ovwarn=false) ikind x = + let _,u_ik = Size.range ikind in + of_interval ~suppress_ovwarn ikind (x, u_ik) + + let ending ?(suppress_ovwarn=false) ikind x = + let l_ik,_ = Size.range ikind in + of_interval ~suppress_ovwarn ikind (l_ik, x) + + let c_lognot ik x = + if is_bot x + then x + else + match to_bool x with + | Some b -> of_bool ik (not b) + | None -> top_bool + + let c_logand = lift2 IntOps.BigIntOps.c_logand + let c_logor = lift2 IntOps.BigIntOps.c_logor + let maximal = function + | Inc xs when not (BISet.is_empty xs) -> Some (BISet.max_elt xs) + | Exc (excl,r) -> + let rec decrement_while_contained v = + if BISet.mem v excl + then decrement_while_contained (Z.pred v) + else v + in + let range_max = Exclusion.max_of_range r in + Some (decrement_while_contained range_max) + | _ (* bottom case *) -> None + + let minimal = function + | Inc xs when not (BISet.is_empty xs) -> Some (BISet.min_elt xs) + | Exc (excl,r) -> + let rec increment_while_contained v = + if BISet.mem v excl + then increment_while_contained (Z.succ v) + else v + in + let range_min = Exclusion.min_of_range r in + Some (increment_while_contained range_min) + | _ (* bottom case *) -> None + + let lt ik x y = + handle_bot x y (fun () -> + match minimal x, maximal x, minimal y, maximal y with + | _, Some x2, Some y1, _ when Z.compare x2 y1 < 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 >= 0 -> of_bool ik false + | _, _, _, _ -> top_bool) + + let gt ik x y = lt ik y x + + let le ik x y = + handle_bot x y (fun () -> + match minimal x, maximal x, minimal y, maximal y with + | _, Some x2, Some y1, _ when Z.compare x2 y1 <= 0 -> of_bool ik true + | Some x1, _, _, Some y2 when Z.compare x1 y2 > 0 -> of_bool ik false + | _, _, _, _ -> top_bool) + + let ge ik x y = le ik y x + + let eq ik x y = + handle_bot x y (fun () -> + match x, y with + | Inc xs, Inc ys when BISet.is_singleton xs && BISet.is_singleton ys -> of_bool ik (Z.equal (BISet.choose xs) (BISet.choose ys)) + | _, _ -> + if is_bot (meet ik x y) then + (* If the meet is empty, there is no chance that concrete values are equal *) + of_bool ik false + else + top_bool) + + let ne ik x y = c_lognot ik (eq ik x y) + + let invariant_ikind e ik x = + match x with + | Inc ps -> + IntInvariant.of_incl_list e ik (BISet.elements ps) + | Exc (ns, r) -> + (* Emit range invariant if tighter than ikind bounds. + This can be more precise than interval, which has been widened. *) + let (rmin, rmax) = (Exclusion.min_of_range r, Exclusion.max_of_range r) in + let ri = IntInvariant.of_interval e ik (rmin, rmax) in + let nsi = IntInvariant.of_excl_list e ik (BISet.elements ns) in + Invariant.(ri && nsi) + + + let arbitrary ik = + let open QCheck.Iter in + let neg s = of_excl_list ik (BISet.elements s) in + let pos s = norm ik (Inc s) in + let shrink = function + | Exc (s, _) -> GobQCheck.shrink (BISet.arbitrary ()) s >|= neg (* S TODO: possibly shrink neg to pos *) + | Inc s -> GobQCheck.shrink (BISet.arbitrary ()) s >|= pos + in + QCheck.frequency ~shrink ~print:show [ + 20, QCheck.map neg (BISet.arbitrary ()); + 10, QCheck.map pos (BISet.arbitrary ()); + ] (* S TODO: decide frequencies *) + + let refine_with_congruence ik a b = + let contains c m x = if Z.equal m Z.zero then Z.equal c x else Z.equal (Z.rem (Z.sub x c) m) Z.zero in + match a, b with + | Inc e, None -> bot_of ik + | Inc e, Some (c, m) -> Inc (BISet.filter (contains c m) e) + | _ -> a + + let refine_with_interval ik a b = a (* TODO: refine inclusion (exclusion?) set *) + + let refine_with_excl_list ik a b = + match b with + | Some (ls, _) -> meet ik a (of_excl_list ik ls) (* TODO: refine with excl range? *) + | _ -> a + + let refine_with_incl_list ik a b = + match a, b with + | Inc x, Some (ls) -> meet ik (Inc x) (Inc (BISet.of_list ls)) + | _ -> a + + let project ik p t = t +end diff --git a/src/cdomain/value/cdomains/int/intDomTuple.ml b/src/cdomain/value/cdomains/int/intDomTuple.ml new file mode 100644 index 0000000000..34647795d8 --- /dev/null +++ b/src/cdomain/value/cdomains/int/intDomTuple.ml @@ -0,0 +1,524 @@ +open IntDomain0 +open IntervalDomain +open IntervalSetDomain +open DefExcDomain +open EnumsDomain +open CongruenceDomain +open GoblintCil +open Pretty +open PrecisionUtil + + +(* The old IntDomList had too much boilerplate since we had to edit every function in S when adding a new domain. With the following, we only have to edit the places where fn are applied, i.e., create, mapp, map, map2. You can search for I3 below to see where you need to extend. *) +(* discussion: https://github.com/goblint/analyzer/pull/188#issuecomment-818928540 *) +module IntDomTupleImpl = struct + include Printable.Std (* for default invariant, tag, ... *) + + open Batteries + type int_t = Z.t + module I1 = SOverflowLifter (DefExc) + module I2 = Interval + module I3 = SOverflowLifter (Enums) + module I4 = SOverflowLifter (Congruence) + module I5 = IntervalSetFunctor (IntOps.BigIntOps) + + type t = I1.t option * I2.t option * I3.t option * I4.t option * I5.t option + [@@deriving eq, ord, hash] + + let name () = "intdomtuple" + + (* The Interval domain can lead to too many contexts for recursive functions (top is [min,max]), but we don't want to drop all ints as with `ana.base.context.int`. TODO better solution? *) + let no_interval = Tuple5.map2 (const None) + let no_intervalSet = Tuple5.map5 (const None) + + type 'a m = (module SOverflow with type t = 'a) + type 'a m2 = (module SOverflow with type t = 'a and type int_t = int_t ) + + (* only first-order polymorphism on functions -> use records to get around monomorphism restriction on arguments *) + type 'b poly_in = { fi : 'a. 'a m -> 'b -> 'a } [@@unboxed] (* inject *) + type 'b poly2_in = { fi2 : 'a. 'a m2 -> 'b -> 'a } [@@unboxed] (* inject for functions that depend on int_t *) + type 'b poly2_in_ovc = { fi2_ovc : 'a. 'a m2 -> 'b -> 'a * overflow_info} [@@unboxed] (* inject for functions that depend on int_t *) + + type 'b poly_pr = { fp : 'a. 'a m -> 'a -> 'b } [@@unboxed] (* project *) + type 'b poly_pr2 = { fp2 : 'a. 'a m2 -> 'a -> 'b } [@@unboxed] (* project for functions that depend on int_t *) + type 'b poly2_pr = {f2p: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'b} [@@unboxed] + type poly1 = {f1: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a} [@@unboxed] (* needed b/c above 'b must be different from 'a *) + type poly1_ovc = {f1_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a * overflow_info } [@@unboxed] (* needed b/c above 'b must be different from 'a *) + type poly2 = {f2: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a} [@@unboxed] + type poly2_ovc = {f2_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a * overflow_info } [@@unboxed] + type 'b poly3 = { f3: 'a. 'a m -> 'a option } [@@unboxed] (* used for projection to given precision *) + let create r x ((p1, p2, p3, p4, p5): int_precision) = + let f b g = if b then Some (g x) else None in + f p1 @@ r.fi (module I1), f p2 @@ r.fi (module I2), f p3 @@ r.fi (module I3), f p4 @@ r.fi (module I4), f p5 @@ r.fi (module I5) + let create r x = (* use where values are introduced *) + create r x (int_precision_from_node_or_config ()) + let create2 r x ((p1, p2, p3, p4, p5): int_precision) = + let f b g = if b then Some (g x) else None in + f p1 @@ r.fi2 (module I1), f p2 @@ r.fi2 (module I2), f p3 @@ r.fi2 (module I3), f p4 @@ r.fi2 (module I4), f p5 @@ r.fi2 (module I5) + let create2 r x = (* use where values are introduced *) + create2 r x (int_precision_from_node_or_config ()) + + let no_overflow ik = function + | Some(_, {underflow; overflow}) -> not (underflow || overflow) + | _ -> false + + let check_ov ?(suppress_ovwarn = false) ~cast ik intv intv_set = + let no_ov = (no_overflow ik intv) || (no_overflow ik intv_set) in + if not no_ov && not suppress_ovwarn && ( BatOption.is_some intv || BatOption.is_some intv_set) then ( + let (_,{underflow=underflow_intv; overflow=overflow_intv}) = match intv with None -> (I2.bot (), {underflow= true; overflow = true}) | Some x -> x in + let (_,{underflow=underflow_intv_set; overflow=overflow_intv_set}) = match intv_set with None -> (I5.bot (), {underflow= true; overflow = true}) | Some x -> x in + let underflow = underflow_intv && underflow_intv_set in + let overflow = overflow_intv && overflow_intv_set in + set_overflow_flag ~cast ~underflow ~overflow ik; + ); + no_ov + + let create2_ovc ik r x ((p1, p2, p3, p4, p5): int_precision) = + let f b g = if b then Some (g x) else None in + let map x = Option.map fst x in + let intv = f p2 @@ r.fi2_ovc (module I2) in + let intv_set = f p5 @@ r.fi2_ovc (module I5) in + ignore (check_ov ~cast:false ik intv intv_set); + map @@ f p1 @@ r.fi2_ovc (module I1), map @@ f p2 @@ r.fi2_ovc (module I2), map @@ f p3 @@ r.fi2_ovc (module I3), map @@ f p4 @@ r.fi2_ovc (module I4), map @@ f p5 @@ r.fi2_ovc (module I5) + + let create2_ovc ik r x = (* use where values are introduced *) + create2_ovc ik r x (int_precision_from_node_or_config ()) + + + let opt_map2 f ?no_ov = + curry @@ function Some x, Some y -> Some (f ?no_ov x y) | _ -> None + + let to_list x = Tuple5.enum x |> List.of_enum |> List.filter_map identity (* contains only the values of activated domains *) + let to_list_some x = List.filter_map identity @@ to_list x (* contains only the Some-values of activated domains *) + + let exists = function + | (Some true, _, _, _, _) + | (_, Some true, _, _, _) + | (_, _, Some true, _, _) + | (_, _, _, Some true, _) + | (_, _, _, _, Some true) -> + true + | _ -> + false + + let for_all = function + | (Some false, _, _, _, _) + | (_, Some false, _, _, _) + | (_, _, Some false, _, _) + | (_, _, _, Some false, _) + | (_, _, _, _, Some false) -> + false + | _ -> + true + + (* f0: constructors *) + let top () = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.top } () + let bot () = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.bot } () + let top_of = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.top_of } + let bot_of = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.bot_of } + let of_bool ik = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.of_bool ik } + let of_excl_list ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_excl_list ik} + let of_int ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_int ik } + let starting ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.starting ~suppress_ovwarn ik } + let ending ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.ending ~suppress_ovwarn ik } + let of_interval ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_interval ~suppress_ovwarn ik } + let of_congruence ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_congruence ik } + + let refine_with_congruence ik ((a, b, c, d, e) : t) (cong : (int_t * int_t) option) : t= + let opt f a = + curry @@ function Some x, y -> Some (f a x y) | _ -> None + in + ( opt I1.refine_with_congruence ik a cong + , opt I2.refine_with_congruence ik b cong + , opt I3.refine_with_congruence ik c cong + , opt I4.refine_with_congruence ik d cong + , opt I5.refine_with_congruence ik e cong) + + let refine_with_interval ik (a, b, c, d, e) intv = + let opt f a = + curry @@ function Some x, y -> Some (f a x y) | _ -> None + in + ( opt I1.refine_with_interval ik a intv + , opt I2.refine_with_interval ik b intv + , opt I3.refine_with_interval ik c intv + , opt I4.refine_with_interval ik d intv + , opt I5.refine_with_interval ik e intv ) + + let refine_with_excl_list ik (a, b, c, d, e) excl = + let opt f a = + curry @@ function Some x, y -> Some (f a x y) | _ -> None + in + ( opt I1.refine_with_excl_list ik a excl + , opt I2.refine_with_excl_list ik b excl + , opt I3.refine_with_excl_list ik c excl + , opt I4.refine_with_excl_list ik d excl + , opt I5.refine_with_excl_list ik e excl ) + + let refine_with_incl_list ik (a, b, c, d, e) incl = + let opt f a = + curry @@ function Some x, y -> Some (f a x y) | _ -> None + in + ( opt I1.refine_with_incl_list ik a incl + , opt I2.refine_with_incl_list ik b incl + , opt I3.refine_with_incl_list ik c incl + , opt I4.refine_with_incl_list ik d incl + , opt I5.refine_with_incl_list ik e incl ) + + + let mapp r (a, b, c, d, e) = + let map = BatOption.map in + ( map (r.fp (module I1)) a + , map (r.fp (module I2)) b + , map (r.fp (module I3)) c + , map (r.fp (module I4)) d + , map (r.fp (module I5)) e) + + + let mapp2 r (a, b, c, d, e) = + BatOption. + ( map (r.fp2 (module I1)) a + , map (r.fp2 (module I2)) b + , map (r.fp2 (module I3)) c + , map (r.fp2 (module I4)) d + , map (r.fp2 (module I5)) e) + + + (* exists/for_all *) + let is_bot = exists % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_bot } + let is_top = for_all % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_top } + let is_top_of ik = for_all % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_top_of ik } + let is_excl_list = exists % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_excl_list } + + let map2p r (xa, xb, xc, xd, xe) (ya, yb, yc, yd, ye) = + ( opt_map2 (r.f2p (module I1)) xa ya + , opt_map2 (r.f2p (module I2)) xb yb + , opt_map2 (r.f2p (module I3)) xc yc + , opt_map2 (r.f2p (module I4)) xd yd + , opt_map2 (r.f2p (module I5)) xe ye) + + (* f2p: binary projections *) + let (%%) f g x = f % (g x) (* composition for binary function g *) + + let leq = + for_all + %% map2p {f2p= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.leq)} + + let flat f x = match to_list_some x with [] -> None | xs -> Some (f xs) + + let to_excl_list x = + let merge ps = + let (vs, rs) = List.split ps in + let (mins, maxs) = List.split rs in + (List.concat vs |> List.sort_uniq Z.compare, (List.min mins, List.max maxs)) + in + mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_excl_list } x |> flat merge + + let to_incl_list x = + let hd l = match l with h::t -> h | _ -> [] in + let tl l = match l with h::t -> t | _ -> [] in + let a y = BatSet.of_list (hd y) in + let b y = BatList.map BatSet.of_list (tl y) in + let merge y = BatSet.elements @@ BatList.fold BatSet.intersect (a y) (b y) + in + mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_incl_list } x |> flat merge + + let same show x = let xs = to_list_some x in let us = List.unique xs in let n = List.length us in + if n = 1 then Some (List.hd xs) + else ( + if n>1 then Messages.info ~category:Unsound "Inconsistent state! %a" (Pretty.docList ~sep:(Pretty.text ",") (Pretty.text % show)) us; (* do not want to abort *) + None + ) + let to_int = same Z.to_string % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_int } + + let pretty () x = + match to_int x with + | Some v when not (GobConfig.get_bool "dbg.full-output") -> Pretty.text (Z.to_string v) + | _ -> + mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> (* assert sf==I.short; *) I.pretty () } x + |> to_list + |> (fun xs -> + text "(" ++ ( + try + List.reduce (fun a b -> a ++ text "," ++ b) xs + with Invalid_argument _ -> + nil) + ++ text ")") (* NOTE: the version above does something else. also, we ignore the sf-argument here. *) + + let refine_functions ik : (t -> t) list = + let maybe reffun ik domtup dom = + match dom with Some y -> reffun ik domtup y | _ -> domtup + in + [(fun (a, b, c, d, e) -> refine_with_excl_list ik (a, b, c, d, e) (to_excl_list (a, b, c, d, e))); + (fun (a, b, c, d, e) -> refine_with_incl_list ik (a, b, c, d, e) (to_incl_list (a, b, c, d, e))); + (fun (a, b, c, d, e) -> maybe refine_with_interval ik (a, b, c, d, e) b); (* TODO: get interval across all domains with minimal and maximal *) + (fun (a, b, c, d, e) -> maybe refine_with_congruence ik (a, b, c, d, e) d)] + + let refine ik ((a, b, c, d, e) : t ) : t = + let dt = ref (a, b, c, d, e) in + (match get_refinement () with + | "never" -> () + | "once" -> + List.iter (fun f -> dt := f !dt) (refine_functions ik); + | "fixpoint" -> + let quit_loop = ref false in + while not !quit_loop do + let old_dt = !dt in + List.iter (fun f -> dt := f !dt) (refine_functions ik); + quit_loop := equal old_dt !dt; + if is_bot !dt then dt := bot_of ik; quit_loop := true; + if M.tracing then M.trace "cong-refine-loop" "old: %a, new: %a" pretty old_dt pretty !dt; + done; + | _ -> () + ); !dt + + + (* map with overflow check *) + let mapovc ?(suppress_ovwarn=false) ?(cast=false) ik r (a, b, c, d, e) = + let map f ?no_ov = function Some x -> Some (f ?no_ov x) | _ -> None in + let intv = map (r.f1_ovc (module I2)) b in + let intv_set = map (r.f1_ovc (module I5)) e in + let no_ov = check_ov ~suppress_ovwarn ~cast ik intv intv_set in + let no_ov = no_ov || should_ignore_overflow ik in + refine ik + ( map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I1) x |> fst) a + , BatOption.map fst intv + , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I3) x |> fst) c + , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I4) x |> fst) ~no_ov d + , BatOption.map fst intv_set ) + + (* map2 with overflow check *) + let map2ovc ?(cast=false) ik r (xa, xb, xc, xd, xe) (ya, yb, yc, yd, ye) = + let intv = opt_map2 (r.f2_ovc (module I2)) xb yb in + let intv_set = opt_map2 (r.f2_ovc (module I5)) xe ye in + let no_ov = check_ov ~cast ik intv intv_set in + let no_ov = no_ov || should_ignore_overflow ik in + refine ik + ( opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I1) x y |> fst) xa ya + , BatOption.map fst intv + , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I3) x y |> fst) xc yc + , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I4) x y |> fst) ~no_ov:no_ov xd yd + , BatOption.map fst intv_set ) + + let map ik r (a, b, c, d, e) = + refine ik + BatOption. + ( map (r.f1 (module I1)) a + , map (r.f1 (module I2)) b + , map (r.f1 (module I3)) c + , map (r.f1 (module I4)) d + , map (r.f1 (module I5)) e) + + let map2 ?(norefine=false) ik r (xa, xb, xc, xd, xe) (ya, yb, yc, yd, ye) = + let r = + ( opt_map2 (r.f2 (module I1)) xa ya + , opt_map2 (r.f2 (module I2)) xb yb + , opt_map2 (r.f2 (module I3)) xc yc + , opt_map2 (r.f2 (module I4)) xd yd + , opt_map2 (r.f2 (module I5)) xe ye) + in + if norefine then r else refine ik r + + + (* f1: unary ops *) + let neg ?no_ov ik = + mapovc ik {f1_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.neg ?no_ov ik)} + + let lognot ik = + map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.lognot ik)} + + let c_lognot ik = + map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_lognot ik)} + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = + mapovc ~suppress_ovwarn ~cast:true t {f1_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.cast_to ?torg ?no_ov t)} + + (* fp: projections *) + let equal_to i x = + let xs = mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.equal_to i } x |> Tuple5.enum |> List.of_enum |> List.filter_map identity in + if List.mem `Eq xs then `Eq else + if List.mem `Neq xs then `Neq else + `Top + + let to_bool = same string_of_bool % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.to_bool } + let minimal = flat (List.max ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.minimal } + let maximal = flat (List.min ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.maximal } + (* others *) + let show x = + match to_int x with + | Some v when not (GobConfig.get_bool "dbg.full-output") -> Z.to_string v + | _ -> mapp { fp = fun (type a) (module I:SOverflow with type t = a) x -> I.name () ^ ":" ^ (I.show x) } x + |> to_list + |> String.concat "; " + let to_yojson = [%to_yojson: Yojson.Safe.t list] % to_list % mapp { fp = fun (type a) (module I:SOverflow with type t = a) x -> I.to_yojson x } + + (* `map/opt_map` are used by `project` *) + let opt_map b f = + curry @@ function None, true -> f | x, y when y || b -> x | _ -> None + let map ~keep r (i1, i2, i3, i4, i5) (b1, b2, b3, b4, b5) = + ( opt_map keep (r.f3 (module I1)) i1 b1 + , opt_map keep (r.f3 (module I2)) i2 b2 + , opt_map keep (r.f3 (module I3)) i3 b3 + , opt_map keep (r.f3 (module I4)) i4 b4 + , opt_map keep (r.f3 (module I5)) i5 b5 ) + + (** Project tuple t to precision p + * We have to deactivate IntDomains after the refinement, since we might + * lose information if we do it before. E.g. only "Interval" is active + * and shall be projected to only "Def_Exc". By seting "Interval" to None + * before refinement we have no information for "Def_Exc". + * + * Thus we have 3 Steps: + * 1. Add padding to t by setting `None` to `I.top_of ik` if p is true for this element + * 2. Refine the padded t + * 3. Set elements of t to `None` if p is false for this element + * + * Side Note: + * ~keep is used to reuse `map/opt_map` for Step 1 and 3. + * ~keep:true will keep elements that are `Some x` but should be set to `None` by p. + * This way we won't loose any information for the refinement. + * ~keep:false will set the elements to `None` as defined by p *) + let project ik (p: int_precision) t = + let t_padded = map ~keep:true { f3 = fun (type a) (module I:SOverflow with type t = a) -> Some (I.top_of ik) } t p in + let t_refined = refine ik t_padded in + map ~keep:false { f3 = fun (type a) (module I:SOverflow with type t = a) -> None } t_refined p + + + (* f2: binary ops *) + let join ik = + map2 ~norefine:true ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.join ik)} + + let meet ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.meet ik)} + + let widen ik = + map2 ~norefine:true ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.widen ik)} + + let narrow ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.narrow ik)} + + let add ?no_ov ik = + map2ovc ik + {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.add ?no_ov ik)} + + let sub ?no_ov ik = + map2ovc ik + {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.sub ?no_ov ik)} + + let mul ?no_ov ik = + map2ovc ik + {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.mul ?no_ov ik)} + + let div ?no_ov ik = + map2ovc ik + {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.div ?no_ov ik)} + + let rem ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.rem ik)} + + let lt ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.lt ik)} + + let gt ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.gt ik)} + + let le ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.le ik)} + + let ge ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.ge ik)} + + let eq ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.eq ik)} + + let ne ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.ne ik)} + + let logand ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logand ik)} + + let logor ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logor ik)} + + let logxor ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logxor ik)} + + let shift_left ik = + map2ovc ik {f2_ovc= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.shift_left ik)} + + let shift_right ik = + map2ovc ik {f2_ovc= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.shift_right ik)} + + let c_logand ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_logand ik)} + + let c_logor ik = + map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_logor ik)} + + + (* printing boilerplate *) + let pretty_diff () (x,y) = dprintf "%a instead of %a" pretty x pretty y + let printXml f x = + match to_int x with + | Some v when not (GobConfig.get_bool "dbg.full-output") -> BatPrintf.fprintf f "\n\n%s\n\n\n" (Z.to_string v) + | _ -> BatPrintf.fprintf f "\n\n%s\n\n\n" (show x) + + let invariant_ikind e ik ((_, _, _, x_cong, x_intset) as x) = + (* TODO: do refinement before to ensure incl_list being more precise than intervals, etc (https://github.com/goblint/analyzer/pull/1517#discussion_r1693998515), requires refine functions to actually refine that *) + let simplify_int fallback = + match to_int x with + | Some v -> + (* If definite, output single equality instead of every subdomain repeating same equality (or something less precise). *) + IntInvariant.of_int e ik v + | None -> + fallback () + in + let simplify_all () = + match to_incl_list x with + | Some ps -> + (* If inclusion set, output disjunction of equalities because it subsumes interval(s), exclusion set and congruence. *) + IntInvariant.of_incl_list e ik ps + | None -> + (* Get interval bounds from all domains (intervals and exclusion set ranges). *) + let min = minimal x in + let max = maximal x in + let ns = Option.map fst (to_excl_list x) |? [] in (* Ignore exclusion set bit range, known via interval bounds already. *) + (* "Refine" out-of-bounds exclusions for simpler output. *) + let ns = Option.map_default (fun min -> List.filter (Z.leq min) ns) ns min in + let ns = Option.map_default (fun max -> List.filter (Z.geq max) ns) ns max in + Invariant.( + IntInvariant.of_interval_opt e ik (min, max) && (* Output best interval bounds once instead of multiple subdomains repeating them (or less precise ones). *) + IntInvariant.of_excl_list e ik ns && + Option.map_default (I4.invariant_ikind e ik) Invariant.none x_cong && (* Output congruence as is. *) + Option.map_default (I5.invariant_ikind e ik) Invariant.none x_intset (* Output interval sets as is. *) + ) + in + let simplify_none () = + let is = to_list (mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.invariant_ikind e ik } x) in + List.fold_left (fun a i -> + Invariant.(a && i) + ) (Invariant.top ()) is + in + match GobConfig.get_string "ana.base.invariant.int.simplify" with + | "none" -> simplify_none () + | "int" -> simplify_int simplify_none + | "all" -> simplify_int simplify_all + | _ -> assert false + + let arbitrary ik = QCheck.(set_print show @@ tup5 (option (I1.arbitrary ik)) (option (I2.arbitrary ik)) (option (I3.arbitrary ik)) (option (I4.arbitrary ik)) (option (I5.arbitrary ik))) + + let relift (a, b, c, d, e) = + (Option.map I1.relift a, Option.map I2.relift b, Option.map I3.relift c, Option.map I4.relift d, Option.map I5.relift e) +end + +module IntDomTuple = +struct + module I = IntDomLifter (IntDomTupleImpl) + include I + + let top () = failwith "top in IntDomTuple not supported. Use top_of instead." + let no_interval (x: I.t) = {x with v = IntDomTupleImpl.no_interval x.v} + + let no_intervalSet (x: I.t) = {x with v = IntDomTupleImpl.no_intervalSet x.v} +end + +let of_const (i, ik, str) = IntDomTuple.of_int ik i diff --git a/src/cdomain/value/cdomains/int/intervalDomain.ml b/src/cdomain/value/cdomains/int/intervalDomain.ml new file mode 100644 index 0000000000..7d7329e76a --- /dev/null +++ b/src/cdomain/value/cdomains/int/intervalDomain.ml @@ -0,0 +1,417 @@ +open IntDomain0 + + +module IntervalFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) option = +struct + let name () = "intervals" + type int_t = Ints_t.t + type t = (Ints_t.t * Ints_t.t) option [@@deriving eq, ord, hash] + module IArith = IntervalArith (Ints_t) + + let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) + + let top () = failwith @@ "top () not implemented for " ^ (name ()) + let top_of ik = Some (range ik) + let bot () = None + let bot_of ik = bot () (* TODO: improve *) + + let show = function None -> "bottom" | Some (x,y) -> "["^Ints_t.to_string x^","^Ints_t.to_string y^"]" + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let equal_to i = function + | None -> failwith "unsupported: equal_to with bottom" + | Some (a, b) -> + if a = b && b = i then `Eq else if Ints_t.compare a i <= 0 && Ints_t.compare i b <=0 then `Top else `Neq + + let norm ?(suppress_ovwarn=false) ?(cast=false) ik : (t -> t * overflow_info) = function None -> (None, {underflow=false; overflow=false}) | Some (x,y) -> + if Ints_t.compare x y > 0 then + (None,{underflow=false; overflow=false}) + else ( + let (min_ik, max_ik) = range ik in + let underflow = Ints_t.compare min_ik x > 0 in + let overflow = Ints_t.compare max_ik y < 0 in + let ov_info = { underflow = underflow && not suppress_ovwarn; overflow = overflow && not suppress_ovwarn } in + let v = + if underflow || overflow then + if should_wrap ik then (* could add [|| cast], but that's GCC implementation-defined behavior: https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html#Integers-implementation *) + (* We can only soundly wrap if at most one overflow occurred, otherwise the minimal and maximal values of the interval *) + (* on Z will not safely contain the minimal and maximal elements after the cast *) + let diff = Ints_t.abs (Ints_t.sub max_ik min_ik) in + let resdiff = Ints_t.abs (Ints_t.sub y x) in + if Ints_t.compare resdiff diff > 0 then + top_of ik + else + let l = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint x) in + let u = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint y) in + if Ints_t.compare l u <= 0 then + Some (l, u) + else + (* Interval that wraps around (begins to the right of its end). We can not represent such intervals *) + top_of ik + else if not cast && should_ignore_overflow ik then + let tl, tu = BatOption.get @@ top_of ik in + Some (Ints_t.max tl x, Ints_t.min tu y) + else + top_of ik + else + Some (x,y) + in + (v, ov_info) + ) + + let leq (x:t) (y:t) = + match x, y with + | None, _ -> true + | Some _, None -> false + | Some (x1,x2), Some (y1,y2) -> Ints_t.compare x1 y1 >= 0 && Ints_t.compare x2 y2 <= 0 + + let join ik (x:t) y = + match x, y with + | None, z | z, None -> z + | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.min x1 y1, Ints_t.max x2 y2) |> fst + + let meet ik (x:t) y = + match x, y with + | None, z | z, None -> None + | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.max x1 y1, Ints_t.min x2 y2) |> fst + + (* TODO: change to_int signature so it returns a big_int *) + let to_int x = Option.bind x (IArith.to_int) + let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm ~suppress_ovwarn ik @@ Some (x,y) + let of_int ik (x: int_t) = of_interval ik (x,x) + let zero = Some IArith.zero + let one = Some IArith.one + let top_bool = Some IArith.top_bool + + let of_bool _ik = function true -> one | false -> zero + let to_bool (a: t) = match a with + | None -> None + | Some (l, u) when Ints_t.compare l Ints_t.zero = 0 && Ints_t.compare u Ints_t.zero = 0 -> Some false + | x -> if leq zero x then None else Some true + + let starting ?(suppress_ovwarn=false) ik n = + norm ~suppress_ovwarn ik @@ Some (n, snd (range ik)) + + let ending ?(suppress_ovwarn=false) ik n = + norm ~suppress_ovwarn ik @@ Some (fst (range ik), n) + + (* TODO: change signature of maximal, minimal to return big_int*) + let maximal = function None -> None | Some (x,y) -> Some y + let minimal = function None -> None | Some (x,y) -> Some x + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~cast:true t (* norm does all overflow handling *) + + let widen ik x y = + match x, y with + | None, z | z, None -> z + | Some (l0,u0), Some (l1,u1) -> + let (min_ik, max_ik) = range ik in + let threshold = get_interval_threshold_widening () in + let l2 = + if Ints_t.compare l0 l1 = 0 then l0 + else if threshold then IArith.lower_threshold l1 min_ik + else min_ik + in + let u2 = + if Ints_t.compare u0 u1 = 0 then u0 + else if threshold then IArith.upper_threshold u1 max_ik + else max_ik + in + norm ik @@ Some (l2,u2) |> fst + let widen ik x y = + let r = widen ik x y in + if M.tracing && not (equal x y) then M.tracel "int" "interval widen %a %a -> %a" pretty x pretty y pretty r; + assert (leq x y); (* TODO: remove for performance reasons? *) + r + + let narrow ik x y = + match x, y with + | _,None | None, _ -> None + | Some (x1,x2), Some (y1,y2) -> + let threshold = get_interval_threshold_widening () in + let (min_ik, max_ik) = range ik in + let lr = if Ints_t.compare min_ik x1 = 0 || threshold && Ints_t.compare y1 x1 > 0 && IArith.is_lower_threshold x1 then y1 else x1 in + let ur = if Ints_t.compare max_ik x2 = 0 || threshold && Ints_t.compare y2 x2 < 0 && IArith.is_upper_threshold x2 then y2 else x2 in + norm ik @@ Some (lr,ur) |> fst + + + let narrow ik x y = + if get_interval_narrow_by_meet () then + meet ik x y + else + narrow ik x y + + let log f ~annihilator ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> bot_of ik + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_bool i1, to_bool i2 with + | Some x, _ when x = annihilator -> of_bool ik annihilator + | _, Some y when y = annihilator -> of_bool ik annihilator + | Some x, Some y -> of_bool ik (f x y) + | _ -> top_of ik + + let c_logor = log (||) ~annihilator:true + let c_logand = log (&&) ~annihilator:false + + let log1 f ik i1 = + if is_bot i1 then + bot_of ik + else + match to_bool i1 with + | Some x -> of_bool ik (f ik x) + | _ -> top_of ik + + let c_lognot = log1 (fun _ik -> not) + + let bit f ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> bot_of ik + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_int i1, to_int i2 with + | Some x, Some y -> (try of_int ik (f ik x y) |> fst with Division_by_zero -> top_of ik) + | _ -> top_of ik + + let bitcomp f ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> (bot_of ik,{underflow=false; overflow=false}) + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_int i1, to_int i2 with + | Some x, Some y -> (try of_int ik (f ik x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{underflow=false; overflow=false})) + | _ -> (top_of ik,{underflow=true; overflow=true}) + + let logxor = bit (fun _ik -> Ints_t.logxor) + + let logand ik i1 i2 = + match is_bot i1, is_bot i2 with + | true, true -> bot_of ik + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) + | _ -> + match to_int i1, to_int i2 with + | Some x, Some y -> (try of_int ik (Ints_t.logand x y) |> fst with Division_by_zero -> top_of ik) + | _, Some y when Ints_t.equal y Ints_t.zero -> of_int ik Ints_t.zero |> fst + | _, Some y when Ints_t.equal y Ints_t.one -> of_interval ik (Ints_t.zero, Ints_t.one) |> fst + | _ -> top_of ik + + let logor = bit (fun _ik -> Ints_t.logor) + + let bit1 f ik i1 = + if is_bot i1 then + bot_of ik + else + match to_int i1 with + | Some x -> of_int ik (f ik x) |> fst + | _ -> top_of ik + + let lognot = bit1 (fun _ik -> Ints_t.lognot) + let shift_right = bitcomp (fun _ik x y -> Ints_t.shift_right x (Ints_t.to_int y)) + + let neg ?no_ov ik = function None -> (None,{underflow=false; overflow=false}) | Some x -> norm ik @@ Some (IArith.neg x) + + let binary_op_with_norm ?no_ov op ik x y = match x, y with + | None, None -> (None, {overflow=false; underflow= false}) + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some x, Some y -> norm ik @@ Some (op x y) + + let add ?no_ov = binary_op_with_norm IArith.add + let mul ?no_ov = binary_op_with_norm IArith.mul + let sub ?no_ov = binary_op_with_norm IArith.sub + + let shift_left ik a b = + match is_bot a, is_bot b with + | true, true -> (bot_of ik,{underflow=false; overflow=false}) + | true, _ + | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show a) (show b))) + | _ -> + match a, minimal b, maximal b with + | Some a, Some bl, Some bu when (Ints_t.compare bl Ints_t.zero >= 0) -> + (try + let r = IArith.shift_left a (Ints_t.to_int bl, Ints_t.to_int bu) in + norm ik @@ Some r + with Z.Overflow -> (top_of ik,{underflow=false; overflow=true})) + | _ -> (top_of ik,{underflow=true; overflow=true}) + + let rem ik x y = match x, y with + | None, None -> None + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (xl, xu), Some (yl, yu) -> + if is_top_of ik x && is_top_of ik y then + (* This is needed to preserve soundness also on things bigger than int32 e.g. *) + (* x: 3803957176L -> T in Interval32 *) + (* y: 4209861404L -> T in Interval32 *) + (* x % y: 3803957176L -> T in Interval32 *) + (* T in Interval32 is [-2147483648,2147483647] *) + (* the code below computes [-2147483647,2147483647] for this though which is unsound *) + top_of ik + else + (* If we have definite values, Ints_t.rem will give a definite result. + * Otherwise we meet with a [range] the result can be in. + * This range is [0, min xu b] if x is positive, and [max xl -b, min xu b] if x can be negative. + * The precise bound b is one smaller than the maximum bound. Negative y give the same result as positive. *) + let pos x = if Ints_t.compare x Ints_t.zero < 0 then Ints_t.neg x else x in + let b = Ints_t.sub (Ints_t.max (pos yl) (pos yu)) Ints_t.one in + let range = if Ints_t.compare xl Ints_t.zero>= 0 then Some (Ints_t.zero, Ints_t.min xu b) else Some (Ints_t.max xl (Ints_t.neg b), Ints_t.min (Ints_t.max (pos xl) (pos xu)) b) in + meet ik (bit (fun _ik -> Ints_t.rem) ik x y) range + + let rec div ?no_ov ik x y = + match x, y with + | None, None -> (bot (),{underflow=false; overflow=false}) + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | (Some (x1,x2) as x), (Some (y1,y2) as y) -> + begin + let is_zero v = Ints_t.compare v Ints_t.zero = 0 in + match y1, y2 with + | l, u when is_zero l && is_zero u -> (top_of ik,{underflow=false; overflow=false}) (* TODO warn about undefined behavior *) + | l, _ when is_zero l -> div ik (Some (x1,x2)) (Some (Ints_t.one,y2)) + | _, u when is_zero u -> div ik (Some (x1,x2)) (Some (y1, Ints_t.(neg one))) + | _ when leq (of_int ik (Ints_t.zero) |> fst) (Some (y1,y2)) -> (top_of ik,{underflow=false; overflow=false}) + | _ -> binary_op_with_norm IArith.div ik x y + end + + let ne ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then + of_bool ik true + else if Ints_t.compare x2 y1 <= 0 && Ints_t.compare y2 x1 <= 0 then + of_bool ik false + else top_bool + + let eq ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 <= 0 && Ints_t.compare x2 y1 <= 0 then + of_bool ik true + else if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then + of_bool ik false + else top_bool + + let ge ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 <= 0 then of_bool ik true + else if Ints_t.compare x2 y1 < 0 then of_bool ik false + else top_bool + + let le ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare x2 y1 <= 0 then of_bool ik true + else if Ints_t.compare y2 x1 < 0 then of_bool ik false + else top_bool + + let gt ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare y2 x1 < 0 then of_bool ik true + else if Ints_t.compare x2 y1 <= 0 then of_bool ik false + else top_bool + + let lt ik x y = + match x, y with + | None, None -> bot_of ik + | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | Some (x1,x2), Some (y1,y2) -> + if Ints_t.compare x2 y1 < 0 then of_bool ik true + else if Ints_t.compare y2 x1 <= 0 then of_bool ik false + else top_bool + + let invariant_ikind e ik = function + | Some (x1, x2) -> + let (x1', x2') = BatTuple.Tuple2.mapn Ints_t.to_bigint (x1, x2) in + IntInvariant.of_interval e ik (x1', x2') + | None -> Invariant.none + + let arbitrary ik = + let open QCheck.Iter in + (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint GobQCheck.Arbitrary.big_int in *) + (* TODO: apparently bigints are really slow compared to int64 for domaintest *) + let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let pair_arb = QCheck.pair int_arb int_arb in + let shrink = function + | Some (l, u) -> (return None) <+> (GobQCheck.shrink pair_arb (l, u) >|= of_interval ik >|= fst) + | None -> empty + in + QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) (fun x -> of_interval ik x |> fst ) pair_arb) + + let modulo n k = + let result = Ints_t.rem n k in + if Ints_t.compare result Ints_t.zero >= 0 then result + else Ints_t.add result k + + let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = + match intv, cong with + | Some (x, y), Some (c, m) -> + if Ints_t.equal m Ints_t.zero && (Ints_t.compare c x < 0 || Ints_t.compare c y > 0) then None + else if Ints_t.equal m Ints_t.zero then + Some (c, c) + else + let (min_ik, max_ik) = range ik in + let rcx = + if Ints_t.equal x min_ik then x else + Ints_t.add x (modulo (Ints_t.sub c x) (Ints_t.abs m)) in + let lcy = + if Ints_t.equal y max_ik then y else + Ints_t.sub y (modulo (Ints_t.sub y c) (Ints_t.abs m)) in + if Ints_t.compare rcx lcy > 0 then None + else if Ints_t.equal rcx lcy then norm ik @@ Some (rcx, rcx) |> fst + else norm ik @@ Some (rcx, lcy) |> fst + | _ -> None + + let refine_with_congruence ik x y = + let refn = refine_with_congruence ik x y in + if M.tracing then M.trace "refine" "int_refine_with_congruence %a %a -> %a" pretty x pretty y pretty refn; + refn + + let refine_with_interval ik a b = meet ik a b + + let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = + match intv, excl with + | None, _ | _, None -> intv + | Some(l, u), Some(ls, (rl, rh)) -> + let rec shrink op b = + let new_b = (op b (Ints_t.of_int(Bool.to_int(BatList.mem_cmp Ints_t.compare b ls)))) in + if not (Ints_t.equal b new_b) then shrink op new_b else new_b + in + let (min_ik, max_ik) = range ik in + let l' = if Ints_t.equal l min_ik then l else shrink Ints_t.add l in + let u' = if Ints_t.equal u max_ik then u else shrink Ints_t.sub u in + let intv' = norm ik @@ Some (l', u') |> fst in + let range = norm ~suppress_ovwarn:true ik (Some (Ints_t.of_bigint (Size.min_from_bit_range rl), Ints_t.of_bigint (Size.max_from_bit_range rh))) |> fst in + meet ik intv' range + + let refine_with_incl_list ik (intv: t) (incl : (int_t list) option) : t = + match intv, incl with + | None, _ | _, None -> intv + | Some(l, u), Some(ls) -> + let rec min m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with + | None -> min (Some x) xs | Some m -> if Ints_t.compare m x < 0 then min (Some m) xs else min (Some x) xs in + let rec max m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with + | None -> max (Some x) xs | Some m -> if Ints_t.compare m x > 0 then max (Some m) xs else max (Some x) xs in + match min None ls, max None ls with + | Some m1, Some m2 -> refine_with_interval ik (Some(l, u)) (Some (m1, m2)) + | _, _-> intv + + let project ik p t = t +end + +module Interval = IntervalFunctor (IntOps.BigIntOps) +module Interval32 = IntDomWithDefaultIkind (IntDomLifter (SOverflowUnlifter (IntervalFunctor (IntOps.Int64Ops)))) (IntIkind) diff --git a/src/cdomain/value/cdomains/int/intervalSetDomain.ml b/src/cdomain/value/cdomains/int/intervalSetDomain.ml new file mode 100644 index 0000000000..3e2bc847ee --- /dev/null +++ b/src/cdomain/value/cdomains/int/intervalSetDomain.ml @@ -0,0 +1,541 @@ +open IntDomain0 +open IntervalDomain +open GoblintCil + + +(** IntervalSetFunctor that is not just disjunctive completion of intervals, but attempts to be precise for wraparound arithmetic for unsigned types *) +module IntervalSetFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) list = +struct + + module Interval = IntervalFunctor (Ints_t) + module IArith = IntervalArith (Ints_t) + + + let name () = "interval_sets" + + type int_t = Ints_t.t + + let (>.) a b = Ints_t.compare a b > 0 + let (=.) a b = Ints_t.compare a b = 0 + let (<.) a b = Ints_t.compare a b < 0 + let (>=.) a b = Ints_t.compare a b >= 0 + let (<=.) a b = Ints_t.compare a b <= 0 + let (+.) a b = Ints_t.add a b + let (-.) a b = Ints_t.sub a b + + (* + Each domain's element is guaranteed to be in canonical form. That is, each interval contained + inside the set does not overlap with each other and they are not adjacent. + *) + type t = (Ints_t.t * Ints_t.t) list [@@deriving eq, hash, ord] + + let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) + + let top () = failwith @@ "top () not implemented for " ^ (name ()) + + let top_of ik = [range ik] + + let bot () = [] + + let bot_of ik = bot () + + let show (x: t) = + let show_interval i = Printf.sprintf "[%s, %s]" (Ints_t.to_string (fst i)) (Ints_t.to_string (snd i)) in + List.fold_left (fun acc i -> (show_interval i) :: acc) [] x |> List.rev |> String.concat ", " |> Printf.sprintf "[%s]" + + (* New type definition for the sweeping line algorithm used for implementing join/meet functions. *) + type event = Enter of Ints_t.t | Exit of Ints_t.t + + let unbox_event = function Enter x -> x | Exit x -> x + + let cmp_events x y = + (* Deliberately comparing ints first => Cannot be derived *) + let res = Ints_t.compare (unbox_event x) (unbox_event y) in + if res <> 0 then res + else + begin + match (x, y) with + | (Enter _, Exit _) -> -1 + | (Exit _, Enter _) -> 1 + | (_, _) -> 0 + end + + let interval_set_to_events (xs: t) = + List.concat_map (fun (a, b) -> [Enter a; Exit b]) xs + + let two_interval_sets_to_events (xs: t) (ys: t) = + let xs = interval_set_to_events xs in + let ys = interval_set_to_events ys in + List.merge cmp_events xs ys + + (* Using the sweeping line algorithm, combined_event_list returns a new event list representing the intervals in which at least n intervals in xs overlap + This function is used for both join and meet operations with different parameter n: 1 for join, 2 for meet *) + let combined_event_list lattice_op (xs:event list) = + let l = match lattice_op with `Join -> 1 | `Meet -> 2 in + let aux (interval_count, acc) = function + | Enter x -> (interval_count + 1, if (interval_count + 1) >= l && interval_count < l then (Enter x)::acc else acc) + | Exit x -> (interval_count - 1, if interval_count >= l && (interval_count - 1) < l then (Exit x)::acc else acc) + in + List.fold_left aux (0, []) xs |> snd |> List.rev + + let rec events_to_intervals = function + | [] -> [] + | (Enter x)::(Exit y)::xs -> (x, y)::(events_to_intervals xs) + | _ -> failwith "Invalid events list" + + let remove_empty_gaps (xs: t) = + let aux acc (l, r) = match acc with + | ((a, b)::acc') when (b +. Ints_t.one) >=. l -> (a, r)::acc' + | _ -> (l, r)::acc + in + List.fold_left aux [] xs |> List.rev + + let canonize (xs: t) = + interval_set_to_events xs |> + List.sort cmp_events |> + combined_event_list `Join |> + events_to_intervals |> + remove_empty_gaps + + let unop (x: t) op = match x with + | [] -> [] + | _ -> canonize @@ List.concat_map op x + + let binop (x: t) (y: t) op : t = match x, y with + | [], _ -> [] + | _, [] -> [] + | _, _ -> canonize @@ List.concat_map op (BatList.cartesian_product x y) + + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + + let minimal = function + | [] -> None + | (x, _)::_ -> Some x + + let maximal = function + | [] -> None + | xs -> Some (BatList.last xs |> snd) + + let equal_to_interval i (a, b) = + if a =. b && b =. i then + `Eq + else if a <=. i && i <=. b then + `Top + else + `Neq + + let equal_to i xs = match List.map (equal_to_interval i) xs with + | [] -> failwith "unsupported: equal_to with bottom" + | [`Eq] -> `Eq + | ys when List.for_all ((=) `Neq) ys -> `Neq + | _ -> `Top + + let norm_interval ?(suppress_ovwarn=false) ?(cast=false) ik (x,y) : t*overflow_info = + if x >. y then + ([],{underflow=false; overflow=false}) + else + let (min_ik, max_ik) = range ik in + let underflow = min_ik >. x in + let overflow = max_ik <. y in + let v = if underflow || overflow then + begin + if should_wrap ik then (* could add [|| cast], but that's GCC implementation-defined behavior: https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html#Integers-implementation *) + (* We can only soundly wrap if at most one overflow occurred, otherwise the minimal and maximal values of the interval *) + (* on Z will not safely contain the minimal and maximal elements after the cast *) + let diff = Ints_t.abs (max_ik -. min_ik) in + let resdiff = Ints_t.abs (y -. x) in + if resdiff >. diff then + [range ik] + else + let l = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint x) in + let u = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint y) in + if l <=. u then + [(l, u)] + else + (* Interval that wraps around (begins to the right of its end). We CAN represent such intervals *) + [(min_ik, u); (l, max_ik)] + else if not cast && should_ignore_overflow ik then + [Ints_t.max min_ik x, Ints_t.min max_ik y] + else + [range ik] + end + else + [(x,y)] + in + if suppress_ovwarn then (v, {underflow=false; overflow=false}) else (v, {underflow; overflow}) + + let norm_intvs ?(suppress_ovwarn=false) ?(cast=false) (ik:ikind) (xs: t) : t*overflow_info = + let res = List.map (norm_interval ~suppress_ovwarn ~cast ik) xs in + let intvs = List.concat_map fst res in + let underflow = List.exists (fun (_,{underflow; _}) -> underflow) res in + let overflow = List.exists (fun (_,{overflow; _}) -> underflow) res in + (canonize intvs,{underflow; overflow}) + + let binary_op_with_norm op (ik:ikind) (x: t) (y: t) : t*overflow_info = match x, y with + | [], _ -> ([],{overflow=false; underflow=false}) + | _, [] -> ([],{overflow=false; underflow=false}) + | _, _ -> norm_intvs ik @@ List.concat_map (fun (x,y) -> [op x y]) (BatList.cartesian_product x y) + + let binary_op_with_ovc (x: t) (y: t) op : t*overflow_info = match x, y with + | [], _ -> ([],{overflow=false; underflow=false}) + | _, [] -> ([],{overflow=false; underflow=false}) + | _, _ -> + let res = List.map op (BatList.cartesian_product x y) in + let intvs = List.concat_map fst res in + let underflow = List.exists (fun (_,{underflow; _}) -> underflow) res in + let overflow = List.exists (fun (_,{overflow; _}) -> underflow) res in + (canonize intvs,{underflow; overflow}) + + let unary_op_with_norm op (ik:ikind) (x: t) = match x with + | [] -> ([],{overflow=false; underflow=false}) + | _ -> norm_intvs ik @@ List.concat_map (fun x -> [op x]) x + + let rec leq (xs: t) (ys: t) = + let leq_interval (al, au) (bl, bu) = al >=. bl && au <=. bu in + match xs, ys with + | [], _ -> true + | _, [] -> false + | (xl,xr)::xs', (yl,yr)::ys' -> + if leq_interval (xl,xr) (yl,yr) then + leq xs' ys + else if xr <. yl then + false + else + leq xs ys' + + let join ik (x: t) (y: t): t = + two_interval_sets_to_events x y |> + combined_event_list `Join |> + events_to_intervals |> + remove_empty_gaps + + let meet ik (x: t) (y: t): t = + two_interval_sets_to_events x y |> + combined_event_list `Meet |> + events_to_intervals + + let to_int = function + | [x] -> IArith.to_int x + | _ -> None + + let zero = [IArith.zero] + let one = [IArith.one] + let top_bool = [IArith.top_bool] + + let not_bool (x:t) = + let is_false x = equal x zero in + let is_true x = equal x one in + if is_true x then zero else if is_false x then one else top_bool + + let to_bool = function + | [(l,u)] when l =. Ints_t.zero && u =. Ints_t.zero -> Some false + | x -> if leq zero x then None else Some true + + let of_bool _ = function true -> one | false -> zero + + let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm_interval ~suppress_ovwarn ~cast:false ik (x,y) + + let of_int ik (x: int_t) = of_interval ik (x, x) + + let lt ik x y = + match x, y with + | [], [] -> bot_of ik + | [], _ | _, [] -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | _, _ -> + let (max_x, min_y) = (maximal x |> Option.get, minimal y |> Option.get) in + let (min_x, max_y) = (minimal x |> Option.get, maximal y |> Option.get) in + if max_x <. min_y then + of_bool ik true + else if min_x >=. max_y then + of_bool ik false + else + top_bool + + let le ik x y = + match x, y with + | [], [] -> bot_of ik + | [], _ | _, [] -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) + | _, _ -> + let (max_x, min_y) = (maximal x |> Option.get, minimal y |> Option.get) in + let (min_x, max_y) = (minimal x |> Option.get, maximal y |> Option.get) in + if max_x <=. min_y then + of_bool ik true + else if min_x >. max_y then + of_bool ik false + else + top_bool + + let gt ik x y = not_bool @@ le ik x y + + let ge ik x y = not_bool @@ lt ik x y + + let eq ik x y = match x, y with + | (a, b)::[], (c, d)::[] when a =. b && c =. d && a =. c -> + one + | _ -> + if is_bot (meet ik x y) then + zero + else + top_bool + + let ne ik x y = not_bool @@ eq ik x y + let interval_to_int i = Interval.to_int (Some i) + let interval_to_bool i = Interval.to_bool (Some i) + + let log f ik (i1, i2) = + match (interval_to_bool i1, interval_to_bool i2) with + | Some x, Some y -> of_bool ik (f x y) + | _ -> top_of ik + + + let bit f ik (i1, i2) = + match (interval_to_int i1), (interval_to_int i2) with + | Some x, Some y -> (try of_int ik (f x y) |> fst with Division_by_zero -> top_of ik) + | _ -> top_of ik + + + let bitcomp f ik (i1, i2) = + match (interval_to_int i1, interval_to_int i2) with + | Some x, Some y -> (try of_int ik (f x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{overflow=false; underflow=false})) + | _, _ -> (top_of ik,{overflow=false; underflow=false}) + + let logand ik x y = + let interval_logand = bit Ints_t.logand ik in + binop x y interval_logand + + let logor ik x y = + let interval_logor = bit Ints_t.logor ik in + binop x y interval_logor + + let logxor ik x y = + let interval_logxor = bit Ints_t.logxor ik in + binop x y interval_logxor + + let lognot ik x = + let interval_lognot i = + match interval_to_int i with + | Some x -> of_int ik (Ints_t.lognot x) |> fst + | _ -> top_of ik + in + unop x interval_lognot + + let shift_left ik x y = + let interval_shiftleft = bitcomp (fun x y -> Ints_t.shift_left x (Ints_t.to_int y)) ik in + binary_op_with_ovc x y interval_shiftleft + + let shift_right ik x y = + let interval_shiftright = bitcomp (fun x y -> Ints_t.shift_right x (Ints_t.to_int y)) ik in + binary_op_with_ovc x y interval_shiftright + + let c_lognot ik x = + let log1 f ik i1 = + match interval_to_bool i1 with + | Some x -> of_bool ik (f x) + | _ -> top_of ik + in + let interval_lognot = log1 not ik in + unop x interval_lognot + + let c_logand ik x y = + let interval_logand = log (&&) ik in + binop x y interval_logand + + let c_logor ik x y = + let interval_logor = log (||) ik in + binop x y interval_logor + + let add ?no_ov = binary_op_with_norm IArith.add + let sub ?no_ov = binary_op_with_norm IArith.sub + let mul ?no_ov = binary_op_with_norm IArith.mul + let neg ?no_ov = unary_op_with_norm IArith.neg + + let div ?no_ov ik x y = + let rec interval_div x (y1, y2) = begin + let top_of ik = top_of ik |> List.hd in + let is_zero v = v =. Ints_t.zero in + match y1, y2 with + | l, u when is_zero l && is_zero u -> top_of ik (* TODO warn about undefined behavior *) + | l, _ when is_zero l -> interval_div x (Ints_t.one,y2) + | _, u when is_zero u -> interval_div x (y1, Ints_t.(neg one)) + | _ when leq (of_int ik (Ints_t.zero) |> fst) ([(y1,y2)]) -> top_of ik + | _ -> IArith.div x (y1, y2) + end + in binary_op_with_norm interval_div ik x y + + let rem ik x y = + let interval_rem (x, y) = + if Interval.is_top_of ik (Some x) && Interval.is_top_of ik (Some y) then + top_of ik + else + let (xl, xu) = x in let (yl, yu) = y in + let pos x = if x <. Ints_t.zero then Ints_t.neg x else x in + let b = (Ints_t.max (pos yl) (pos yu)) -. Ints_t.one in + let range = if xl >=. Ints_t.zero then (Ints_t.zero, Ints_t.min xu b) else (Ints_t.max xl (Ints_t.neg b), Ints_t.min (Ints_t.max (pos xl) (pos xu)) b) in + meet ik (bit Ints_t.rem ik (x, y)) [range] + in + binop x y interval_rem + + let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik x = norm_intvs ~cast:true ik x + + (* + narrows down the extremeties of xs if they are equal to boundary values of the ikind with (possibly) narrower values from ys + *) + let narrow ik xs ys = match xs ,ys with + | [], _ -> [] | _ ,[] -> xs + | _, _ -> + let min_xs = minimal xs |> Option.get in + let max_xs = maximal xs |> Option.get in + let min_ys = minimal ys |> Option.get in + let max_ys = maximal ys |> Option.get in + let min_range,max_range = range ik in + let threshold = get_interval_threshold_widening () in + let min = if min_xs =. min_range || threshold && min_ys >. min_xs && IArith.is_lower_threshold min_xs then min_ys else min_xs in + let max = if max_xs =. max_range || threshold && max_ys <. max_xs && IArith.is_upper_threshold max_xs then max_ys else max_xs in + xs + |> (function (_, y)::z -> (min, y)::z | _ -> []) + |> List.rev + |> (function (x, _)::z -> (x, max)::z | _ -> []) + |> List.rev + + (* + 1. partitions the intervals of xs by assigning each of them to the an interval in ys that includes it. + and joins all intervals in xs assigned to the same interval in ys as one interval. + 2. checks for every pair of adjacent pairs whether the pairs did approach (if you compare the intervals from xs and ys) and merges them if it is the case. + 3. checks whether partitions at the extremeties are approaching infinity (and expands them to infinity. in that case) + + The expansion (between a pair of adjacent partitions or at extremeties ) stops at a threshold. + *) + let widen ik xs ys = + let (min_ik,max_ik) = range ik in + let threshold = GobConfig.get_bool "ana.int.interval_threshold_widening" in + let upper_threshold (_,u) = IArith.upper_threshold u max_ik in + let lower_threshold (l,_) = IArith.lower_threshold l min_ik in + (*obtain partitioning of xs intervals according to the ys interval that includes them*) + let rec interval_sets_to_partitions (ik: ikind) (acc : (int_t * int_t) option) (xs: t) (ys: t)= + match xs,ys with + | _, [] -> [] + | [], (y::ys) -> (acc,y):: interval_sets_to_partitions ik None [] ys + | (x::xs), (y::ys) when Interval.leq (Some x) (Some y) -> interval_sets_to_partitions ik (Interval.join ik acc (Some x)) xs (y::ys) + | (x::xs), (y::ys) -> (acc,y) :: interval_sets_to_partitions ik None (x::xs) ys + in + let interval_sets_to_partitions ik xs ys = interval_sets_to_partitions ik None xs ys in + (*merge a pair of adjacent partitions*) + let merge_pair ik (a,b) (c,d) = + let new_a = function + | None -> Some (upper_threshold b, upper_threshold b) + | Some (ax,ay) -> Some (ax, upper_threshold b) + in + let new_c = function + | None -> Some (lower_threshold d, lower_threshold d) + | Some (cx,cy) -> Some (lower_threshold d, cy) + in + if threshold && (lower_threshold d +. Ints_t.one) >. (upper_threshold b) then + [(new_a a,(fst b, upper_threshold b)); (new_c c, (lower_threshold d, snd d))] + else + [(Interval.join ik a c, (Interval.join ik (Some b) (Some d) |> Option.get))] + in + let partitions_are_approaching part_left part_right = match part_left, part_right with + | (Some (_, left_x), (_, left_y)), (Some (right_x, _), (right_y, _)) -> (right_x -. left_x) >. (right_y -. left_y) + | _,_ -> false + in + (*merge all approaching pairs of adjacent partitions*) + let rec merge_list ik = function + | [] -> [] + | x::y::xs when partitions_are_approaching x y -> merge_list ik ((merge_pair ik x y) @ xs) + | x::xs -> x :: merge_list ik xs + in + (*expands left extremity*) + let widen_left = function + | [] -> [] + | (None,(lb,rb))::ts -> let lt = if threshold then lower_threshold (lb,lb) else min_ik in (None, (lt,rb))::ts + | (Some (la,ra), (lb,rb))::ts when lb <. la -> let lt = if threshold then lower_threshold (lb,lb) else min_ik in (Some (la,ra),(lt,rb))::ts + | x -> x + in + (*expands right extremity*) + let widen_right x = + let map_rightmost = function + | [] -> [] + | (None,(lb,rb))::ts -> let ut = if threshold then upper_threshold (rb,rb) else max_ik in (None, (lb,ut))::ts + | (Some (la,ra), (lb,rb))::ts when ra <. rb -> let ut = if threshold then upper_threshold (rb,rb) else max_ik in (Some (la,ra),(lb,ut))::ts + | x -> x + in + List.rev x |> map_rightmost |> List.rev + in + interval_sets_to_partitions ik xs ys |> merge_list ik |> widen_left |> widen_right |> List.map snd + + let starting ?(suppress_ovwarn=false) ik n = norm_interval ik ~suppress_ovwarn (n, snd (range ik)) + + let ending ?(suppress_ovwarn=false) ik n = norm_interval ik ~suppress_ovwarn (fst (range ik), n) + + let invariant_ikind e ik xs = + List.map (fun x -> Interval.invariant_ikind e ik (Some x)) xs |> + let open Invariant in List.fold_left (||) (bot ()) + + let modulo n k = + let result = Ints_t.rem n k in + if result >=. Ints_t.zero then result + else result +. k + + let refine_with_congruence ik (intvs: t) (cong: (int_t * int_t ) option): t = + let refine_with_congruence_interval ik (cong : (int_t * int_t ) option) (intv : (int_t * int_t ) option): t = + match intv, cong with + | Some (x, y), Some (c, m) -> + if m =. Ints_t.zero && (c <. x || c >. y) then [] + else if m =. Ints_t.zero then + [(c, c)] + else + let (min_ik, max_ik) = range ik in + let rcx = + if x =. min_ik then x else + x +. (modulo (c -. x) (Ints_t.abs m)) in + let lcy = + if y =. max_ik then y else + y -. (modulo (y -. c) (Ints_t.abs m)) in + if rcx >. lcy then [] + else if rcx =. lcy then norm_interval ik (rcx, rcx) |> fst + else norm_interval ik (rcx, lcy) |> fst + | _ -> [] + in + List.concat_map (fun x -> refine_with_congruence_interval ik cong (Some x)) intvs + + let refine_with_interval ik xs = function None -> [] | Some (a,b) -> meet ik xs [(a,b)] + + let refine_with_incl_list ik intvs = function + | None -> intvs + | Some xs -> meet ik intvs (List.map (fun x -> (x,x)) xs) + + let excl_range_to_intervalset (ik: ikind) ((min, max): int_t * int_t) (excl: int_t): t = + let intv1 = (min, excl -. Ints_t.one) in + let intv2 = (excl +. Ints_t.one, max) in + norm_intvs ik ~suppress_ovwarn:true [intv1 ; intv2] |> fst + + let of_excl_list ik (excls: int_t list) = + let excl_list = List.map (excl_range_to_intervalset ik (range ik)) excls in + let res = List.fold_left (meet ik) (top_of ik) excl_list in + res + + let refine_with_excl_list ik (intv : t) = function + | None -> intv + | Some (xs, range) -> + let excl_to_intervalset (ik: ikind) ((rl, rh): (int64 * int64)) (excl: int_t): t = + excl_range_to_intervalset ik (Ints_t.of_bigint (Size.min_from_bit_range rl),Ints_t.of_bigint (Size.max_from_bit_range rh)) excl + in + let excl_list = List.map (excl_to_intervalset ik range) xs in + List.fold_left (meet ik) intv excl_list + + let project ik p t = t + + let arbitrary ik = + let open QCheck.Iter in + (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint GobQCheck.Arbitrary.big_int in *) + (* TODO: apparently bigints are really slow compared to int64 for domaintest *) + let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in + let pair_arb = QCheck.pair int_arb int_arb in + let list_pair_arb = QCheck.small_list pair_arb in + let canonize_randomly_generated_list = (fun x -> norm_intvs ik x |> fst) in + let shrink xs = GobQCheck.shrink list_pair_arb xs >|= canonize_randomly_generated_list + in QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) canonize_randomly_generated_list list_pair_arb) +end + +module IntervalSet = IntervalSetFunctor (IntOps.BigIntOps) diff --git a/src/cdomain/value/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml index e50b3f26cc..c53367d278 100644 --- a/src/cdomain/value/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -1,3785 +1,8 @@ -open GobConfig -open GoblintCil -open Pretty -open PrecisionUtil - -module M = Messages - -let (%) = Batteries.(%) -let (|?) = Batteries.(|?) - -exception IncompatibleIKinds of string -exception Unknown -exception Error -exception ArithmeticOnIntegerBot of string - - - - -(** Define records that hold mutable variables representing different Configuration values. - * These values are used to keep track of whether or not the corresponding Config values are en-/disabled *) -type ana_int_config_values = { - mutable interval_threshold_widening : bool option; - mutable interval_narrow_by_meet : bool option; - mutable def_exc_widen_by_join : bool option; - mutable interval_threshold_widening_constants : string option; - mutable refinement : string option; -} - -let ana_int_config: ana_int_config_values = { - interval_threshold_widening = None; - interval_narrow_by_meet = None; - def_exc_widen_by_join = None; - interval_threshold_widening_constants = None; - refinement = None; -} - -let get_interval_threshold_widening () = - if ana_int_config.interval_threshold_widening = None then - ana_int_config.interval_threshold_widening <- Some (get_bool "ana.int.interval_threshold_widening"); - Option.get ana_int_config.interval_threshold_widening - -let get_interval_narrow_by_meet () = - if ana_int_config.interval_narrow_by_meet = None then - ana_int_config.interval_narrow_by_meet <- Some (get_bool "ana.int.interval_narrow_by_meet"); - Option.get ana_int_config.interval_narrow_by_meet - -let get_def_exc_widen_by_join () = - if ana_int_config.def_exc_widen_by_join = None then - ana_int_config.def_exc_widen_by_join <- Some (get_bool "ana.int.def_exc_widen_by_join"); - Option.get ana_int_config.def_exc_widen_by_join - -let get_interval_threshold_widening_constants () = - if ana_int_config.interval_threshold_widening_constants = None then - ana_int_config.interval_threshold_widening_constants <- Some (get_string "ana.int.interval_threshold_widening_constants"); - Option.get ana_int_config.interval_threshold_widening_constants - -let get_refinement () = - if ana_int_config.refinement = None then - ana_int_config.refinement <- Some (get_string "ana.int.refinement"); - Option.get ana_int_config.refinement - - - -(** Whether for a given ikind, we should compute with wrap-around arithmetic. - * Always for unsigned types, for signed types if 'sem.int.signed_overflow' is 'assume_wraparound' *) -let should_wrap ik = not (Cil.isSigned ik) || get_string "sem.int.signed_overflow" = "assume_wraparound" - -(** Whether for a given ikind, we should assume there are no overflows. - * Always false for unsigned types, true for signed types if 'sem.int.signed_overflow' is 'assume_none' *) -let should_ignore_overflow ik = Cil.isSigned ik && get_string "sem.int.signed_overflow" = "assume_none" - -let widening_thresholds = ResettableLazy.from_fun WideningThresholds.thresholds -let widening_thresholds_desc = ResettableLazy.from_fun (List.rev % WideningThresholds.thresholds) - -type overflow_info = { overflow: bool; underflow: bool;} - -let set_overflow_flag ~cast ~underflow ~overflow ik = - if !AnalysisState.executing_speculative_computations then - (* Do not produce warnings when the operations are not actually happening in code *) - () - else - let signed = Cil.isSigned ik in - if !AnalysisState.postsolving && signed && not cast then - AnalysisState.svcomp_may_overflow := true; - let sign = if signed then "Signed" else "Unsigned" in - match underflow, overflow with - | true, true -> - M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 190; CWE 191] "%s integer overflow and underflow" sign - | true, false -> - M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 191] "%s integer underflow" sign - | false, true -> - M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 190] "%s integer overflow" sign - | false, false -> assert false - -let reset_lazy () = - ResettableLazy.reset widening_thresholds; - ResettableLazy.reset widening_thresholds_desc; - ana_int_config.interval_threshold_widening <- None; - ana_int_config.interval_narrow_by_meet <- None; - ana_int_config.def_exc_widen_by_join <- None; - ana_int_config.interval_threshold_widening_constants <- None; - ana_int_config.refinement <- None - -module type Arith = -sig - type t - val neg: t -> t - val add: t -> t -> t - val sub: t -> t -> t - val mul: t -> t -> t - val div: t -> t -> t - val rem: t -> t -> t - - val lt: t -> t -> t - val gt: t -> t -> t - val le: t -> t -> t - val ge: t -> t -> t - val eq: t -> t -> t - val ne: t -> t -> t - - val lognot: t -> t - val logand: t -> t -> t - val logor : t -> t -> t - val logxor: t -> t -> t - - val shift_left : t -> t -> t - val shift_right: t -> t -> t - - val c_lognot: t -> t - val c_logand: t -> t -> t - val c_logor : t -> t -> t - -end - -module type ArithIkind = -sig - type t - val neg: Cil.ikind -> t -> t - val add: Cil.ikind -> t -> t -> t - val sub: Cil.ikind -> t -> t -> t - val mul: Cil.ikind -> t -> t -> t - val div: Cil.ikind -> t -> t -> t - val rem: Cil.ikind -> t -> t -> t - - val lt: Cil.ikind -> t -> t -> t - val gt: Cil.ikind -> t -> t -> t - val le: Cil.ikind -> t -> t -> t - val ge: Cil.ikind -> t -> t -> t - val eq: Cil.ikind -> t -> t -> t - val ne: Cil.ikind -> t -> t -> t - - val lognot: Cil.ikind -> t -> t - val logand: Cil.ikind -> t -> t -> t - val logor : Cil.ikind -> t -> t -> t - val logxor: Cil.ikind -> t -> t -> t - - val shift_left : Cil.ikind -> t -> t -> t - val shift_right: Cil.ikind -> t -> t -> t - - val c_lognot: Cil.ikind -> t -> t - val c_logand: Cil.ikind -> t -> t -> t - val c_logor : Cil.ikind -> t -> t -> t - -end - -(* Shared functions between S and Z *) -module type B = -sig - include Lattice.S - type int_t - val bot_of: Cil.ikind -> t - val top_of: Cil.ikind -> t - val to_int: t -> int_t option - val equal_to: int_t -> t -> [`Eq | `Neq | `Top] - - val to_bool: t -> bool option - val to_excl_list: t -> (int_t list * (int64 * int64)) option - val of_excl_list: Cil.ikind -> int_t list -> t - val is_excl_list: t -> bool - - val to_incl_list: t -> int_t list option - - val maximal : t -> int_t option - val minimal : t -> int_t option - - val cast_to: ?suppress_ovwarn:bool -> ?torg:Cil.typ -> Cil.ikind -> t -> t -end - -(** Interface of IntDomain implementations that do not take ikinds for arithmetic operations yet. TODO: Should be ported to S in the future. *) -module type IkindUnawareS = -sig - include B - include Arith with type t := t - val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val of_int: int_t -> t - val of_bool: bool -> t - val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t - val of_congruence: Cil.ikind -> int_t * int_t -> t - val arbitrary: unit -> t QCheck.arbitrary - val invariant: Cil.exp -> t -> Invariant.t -end - -(** Interface of IntDomain implementations taking an ikind for arithmetic operations *) -module type S = -sig - include B - include ArithIkind with type t:= t - - val add : ?no_ov:bool -> Cil.ikind -> t -> t -> t - val sub : ?no_ov:bool -> Cil.ikind -> t -> t -> t - val mul : ?no_ov:bool -> Cil.ikind -> t -> t -> t - val div : ?no_ov:bool -> Cil.ikind -> t -> t -> t - val neg : ?no_ov:bool -> Cil.ikind -> t -> t - val cast_to : ?suppress_ovwarn:bool -> ?torg:Cil.typ -> ?no_ov:bool -> Cil.ikind -> t -> t - - val join: Cil.ikind -> t -> t -> t - val meet: Cil.ikind -> t -> t -> t - val narrow: Cil.ikind -> t -> t -> t - val widen: Cil.ikind -> t -> t -> t - val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val of_int: Cil.ikind -> int_t -> t - val of_bool: Cil.ikind -> bool -> t - val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t - val of_congruence: Cil.ikind -> int_t * int_t -> t - val is_top_of: Cil.ikind -> t -> bool - val invariant_ikind : Cil.exp -> Cil.ikind -> t -> Invariant.t - - val refine_with_congruence: Cil.ikind -> t -> (int_t * int_t) option -> t - val refine_with_interval: Cil.ikind -> t -> (int_t * int_t) option -> t - val refine_with_excl_list: Cil.ikind -> t -> (int_t list * (int64 * int64)) option -> t - val refine_with_incl_list: Cil.ikind -> t -> int_t list option -> t - - val project: Cil.ikind -> int_precision -> t -> t - val arbitrary: Cil.ikind -> t QCheck.arbitrary -end - -module type SOverflow = -sig - - include S - - val add : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info - - val sub : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info - - val mul : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info - - val div : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info - - val neg : ?no_ov:bool -> Cil.ikind -> t -> t * overflow_info - - val cast_to : ?suppress_ovwarn:bool -> ?torg:Cil.typ -> ?no_ov:bool -> Cil.ikind -> t -> t * overflow_info - - val of_int : Cil.ikind -> int_t -> t * overflow_info - - val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t * overflow_info - - val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t * overflow_info - val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t * overflow_info - - val shift_left : Cil.ikind -> t -> t -> t * overflow_info - - val shift_right : Cil.ikind -> t -> t -> t * overflow_info -end - -module type Y = -sig - (* include B *) - include B - include Arith with type t:= t - val of_int: Cil.ikind -> int_t -> t - val of_bool: Cil.ikind -> bool -> t - val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t - val of_congruence: Cil.ikind -> int_t * int_t -> t - - val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t - val is_top_of: Cil.ikind -> t -> bool - - val project: int_precision -> t -> t - val invariant: Cil.exp -> t -> Invariant.t -end - -module type Z = Y with type int_t = Z.t - - -module IntDomLifter (I : S) = -struct - open Cil - type int_t = I.int_t - type t = { v : I.t; ikind : CilType.Ikind.t } [@@deriving eq, ord, hash] - - let ikind {ikind; _} = ikind - - (* Helper functions *) - let check_ikinds x y = if x.ikind <> y.ikind then raise (IncompatibleIKinds (GobPretty.sprintf "ikinds %a and %a are incompatible. Values: %a and %a" CilType.Ikind.pretty x.ikind CilType.Ikind.pretty y.ikind I.pretty x.v I.pretty y.v)) - let lift op x = {x with v = op x.ikind x.v } - (* For logical operations the result is of type int *) - let lift_logical op x = {v = op x.ikind x.v; ikind = Cil.IInt} - let lift2 op x y = check_ikinds x y; {x with v = op x.ikind x.v y.v } - let lift2_cmp op x y = check_ikinds x y; {v = op x.ikind x.v y.v; ikind = Cil.IInt} - - let bot_of ikind = { v = I.bot_of ikind; ikind} - let bot () = failwith "bot () is not implemented for IntDomLifter." - let is_bot x = I.is_bot x.v - let top_of ikind = { v = I.top_of ikind; ikind} - let top () = failwith "top () is not implemented for IntDomLifter." - let is_top x = I.is_top x.v - - (* Leq does not check for ikind, because it is used in invariant with arguments of different type. - TODO: check ikinds here and fix invariant to work with right ikinds *) - let leq x y = I.leq x.v y.v - let join = lift2 I.join - let meet = lift2 I.meet - let widen = lift2 I.widen - let narrow = lift2 I.narrow - - let show x = - if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then - "⊤" - else - I.show x.v (* TODO add ikind to output *) - let pretty () x = - if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then - Pretty.text "⊤" - else - I.pretty () x.v (* TODO add ikind to output *) - let pretty_diff () (x, y) = I.pretty_diff () (x.v, y.v) (* TODO check ikinds, add them to output *) - let printXml o x = - if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then - BatPrintf.fprintf o "\n\n⊤\n\n\n" - else - I.printXml o x.v (* TODO add ikind to output *) - (* This is for debugging *) - let name () = "IntDomLifter(" ^ (I.name ()) ^ ")" - let to_yojson x = I.to_yojson x.v - let invariant e x = - let e' = Cilfacade.mkCast ~e ~newt:(TInt (x.ikind, [])) in - I.invariant_ikind e' x.ikind x.v - let tag x = I.tag x.v - let arbitrary ik = failwith @@ "Arbitrary not implement for " ^ (name ()) ^ "." - let to_int x = I.to_int x.v - let of_int ikind x = { v = I.of_int ikind x; ikind} - let equal_to i x = I.equal_to i x.v - let to_bool x = I.to_bool x.v - let of_bool ikind b = { v = I.of_bool ikind b; ikind} - let to_excl_list x = I.to_excl_list x.v - let of_excl_list ikind is = {v = I.of_excl_list ikind is; ikind} - let is_excl_list x = I.is_excl_list x.v - let to_incl_list x = I.to_incl_list x.v - let of_interval ?(suppress_ovwarn=false) ikind (lb,ub) = {v = I.of_interval ~suppress_ovwarn ikind (lb,ub); ikind} - let of_congruence ikind (c,m) = {v = I.of_congruence ikind (c,m); ikind} - let starting ?(suppress_ovwarn=false) ikind i = {v = I.starting ~suppress_ovwarn ikind i; ikind} - let ending ?(suppress_ovwarn=false) ikind i = {v = I.ending ~suppress_ovwarn ikind i; ikind} - let maximal x = I.maximal x.v - let minimal x = I.minimal x.v - - let neg = lift I.neg - let add = lift2 I.add - let sub = lift2 I.sub - let mul = lift2 I.mul - let div = lift2 I.div - let rem = lift2 I.rem - let lt = lift2_cmp I.lt - let gt = lift2_cmp I.gt - let le = lift2_cmp I.le - let ge = lift2_cmp I.ge - let eq = lift2_cmp I.eq - let ne = lift2_cmp I.ne - let lognot = lift I.lognot - let logand = lift2 I.logand - let logor = lift2 I.logor - let logxor = lift2 I.logxor - let shift_left x y = {x with v = I.shift_left x.ikind x.v y.v } (* TODO check ikinds*) - let shift_right x y = {x with v = I.shift_right x.ikind x.v y.v } (* TODO check ikinds*) - let c_lognot = lift_logical I.c_lognot - let c_logand = lift2 I.c_logand - let c_logor = lift2 I.c_logor - - let cast_to ?(suppress_ovwarn=false) ?torg ikind x = {v = I.cast_to ~suppress_ovwarn ~torg:(TInt(x.ikind,[])) ikind x.v; ikind} - - let is_top_of ik x = ik = x.ikind && I.is_top_of ik x.v - - let relift x = { v = I.relift x.v; ikind = x.ikind } - - let project p v = { v = I.project v.ikind p v.v; ikind = v.ikind } -end - -module type Ikind = -sig - val ikind: unit -> Cil.ikind -end - -module PtrDiffIkind : Ikind = -struct - let ikind = Cilfacade.ptrdiff_ikind -end - -module IntDomWithDefaultIkind (I: Y) (Ik: Ikind) : Y with type t = I.t and type int_t = I.int_t = -struct - include I - let top () = I.top_of (Ik.ikind ()) - let bot () = I.bot_of (Ik.ikind ()) -end - -module Size = struct (* size in bits as int, range as int64 *) - open Cil - let sign x = if Z.compare x Z.zero < 0 then `Signed else `Unsigned - - let top_typ = TInt (ILongLong, []) - let min_for x = intKindForValue x (sign x = `Unsigned) - let bit = function (* bits needed for representation *) - | IBool -> 1 - | ik -> bytesSizeOfInt ik * 8 - let is_int64_big_int x = Z.fits_int64 x - let card ik = (* cardinality *) - let b = bit ik in - Z.shift_left Z.one b - let bits ik = (* highest bits for neg/pos values *) - let s = bit ik in - if isSigned ik then s-1, s-1 else 0, s - let bits_i64 ik = BatTuple.Tuple2.mapn Int64.of_int (bits ik) - let range ik = - let a,b = bits ik in - let x = if isSigned ik then Z.neg (Z.shift_left Z.one a) (* -2^a *) else Z.zero in - let y = Z.pred (Z.shift_left Z.one b) in (* 2^b - 1 *) - x,y - - let is_cast_injective ~from_type ~to_type = - let (from_min, from_max) = range (Cilfacade.get_ikind from_type) in - let (to_min, to_max) = range (Cilfacade.get_ikind to_type) in - if M.tracing then M.trace "int" "is_cast_injective %a (%a, %a) -> %a (%a, %a)" CilType.Typ.pretty from_type GobZ.pretty from_min GobZ.pretty from_max CilType.Typ.pretty to_type GobZ.pretty to_min GobZ.pretty to_max; - Z.compare to_min from_min <= 0 && Z.compare from_max to_max <= 0 - - let cast t x = (* TODO: overflow is implementation-dependent! *) - if t = IBool then - (* C11 6.3.1.2 Boolean type *) - if Z.equal x Z.zero then Z.zero else Z.one - else - let a,b = range t in - let c = card t in - let y = Z.erem x c in - let y = if Z.gt y b then Z.sub y c - else if Z.lt y a then Z.add y c - else y - in - if M.tracing then M.tracel "cast" "Cast %a to range [%a, %a] (%a) = %a (%s in int64)" GobZ.pretty x GobZ.pretty a GobZ.pretty b GobZ.pretty c GobZ.pretty y (if is_int64_big_int y then "fits" else "does not fit"); - y - - let min_range_sign_agnostic x = - let size ik = - let a,b = bits_i64 ik in - Int64.neg a,b - in - if sign x = `Signed then - size (min_for x) - else - let a, b = size (min_for x) in - if b <= 64L then - let upper_bound_less = Int64.sub b 1L in - let max_one_less = Z.(pred @@ shift_left Z.one (Int64.to_int upper_bound_less)) in - if x <= max_one_less then - a, upper_bound_less - else - a,b - else - a, b - - (* From the number of bits used to represent a positive value, determines the maximal representable value *) - let max_from_bit_range pos_bits = Z.(pred @@ shift_left Z.one (to_int (Z.of_int64 pos_bits))) - - (* From the number of bits used to represent a non-positive value, determines the minimal representable value *) - let min_from_bit_range neg_bits = Z.(if neg_bits = 0L then Z.zero else neg @@ shift_left Z.one (to_int (neg (Z.of_int64 neg_bits)))) - -end - - -module StdTop (B: sig type t val top_of: Cil.ikind -> t end) = struct - open B - (* these should be overwritten for better precision if possible: *) - let to_excl_list x = None - let of_excl_list ik x = top_of ik - let is_excl_list x = false - let to_incl_list x = None - let of_interval ?(suppress_ovwarn=false) ik x = top_of ik - let of_congruence ik x = top_of ik - let starting ?(suppress_ovwarn=false) ik x = top_of ik - let ending ?(suppress_ovwarn=false) ik x = top_of ik - let maximal x = None - let minimal x = None -end - -module Std (B: sig - type t - val name: unit -> string - val top_of: Cil.ikind -> t - val bot_of: Cil.ikind -> t - val show: t -> string - val equal: t -> t -> bool - end) = struct - include Printable.StdLeaf - let name = B.name (* overwrite the one from Printable.Std *) - open B - let is_top x = failwith "is_top not implemented for IntDomain.Std" - let is_bot x = B.equal x (bot_of Cil.IInt) (* Here we assume that the representation of bottom is independent of the ikind - This may be true for intdomain implementations, but not e.g. for IntDomLifter. *) - let is_top_of ik x = B.equal x (top_of ik) - - (* all output is based on B.show *) - include Printable.SimpleShow ( - struct - type nonrec t = t - let show = show - end - ) - let pretty_diff () (x,y) = dprintf "%s: %a instead of %a" (name ()) pretty x pretty y - - include StdTop (B) -end - -(* Textbook interval arithmetic, without any overflow handling etc. *) -module IntervalArith (Ints_t : IntOps.IntOps) = struct - let min4 a b c d = Ints_t.min (Ints_t.min a b) (Ints_t.min c d) - let max4 a b c d = Ints_t.max (Ints_t.max a b) (Ints_t.max c d) - - let mul (x1, x2) (y1, y2) = - let x1y1 = (Ints_t.mul x1 y1) in - let x1y2 = (Ints_t.mul x1 y2) in - let x2y1 = (Ints_t.mul x2 y1) in - let x2y2 = (Ints_t.mul x2 y2) in - (min4 x1y1 x1y2 x2y1 x2y2, max4 x1y1 x1y2 x2y1 x2y2) - - let shift_left (x1,x2) (y1,y2) = - let y1p = Ints_t.shift_left Ints_t.one y1 in - let y2p = Ints_t.shift_left Ints_t.one y2 in - mul (x1, x2) (y1p, y2p) - - let div (x1, x2) (y1, y2) = - let x1y1n = (Ints_t.div x1 y1) in - let x1y2n = (Ints_t.div x1 y2) in - let x2y1n = (Ints_t.div x2 y1) in - let x2y2n = (Ints_t.div x2 y2) in - let x1y1p = (Ints_t.div x1 y1) in - let x1y2p = (Ints_t.div x1 y2) in - let x2y1p = (Ints_t.div x2 y1) in - let x2y2p = (Ints_t.div x2 y2) in - (min4 x1y1n x1y2n x2y1n x2y2n, max4 x1y1p x1y2p x2y1p x2y2p) - - let add (x1, x2) (y1, y2) = (Ints_t.add x1 y1, Ints_t.add x2 y2) - let sub (x1, x2) (y1, y2) = (Ints_t.sub x1 y2, Ints_t.sub x2 y1) - - let neg (x1, x2) = (Ints_t.neg x2, Ints_t.neg x1) - - let one = (Ints_t.one, Ints_t.one) - let zero = (Ints_t.zero, Ints_t.zero) - let top_bool = (Ints_t.zero, Ints_t.one) - - let to_int (x1, x2) = - if Ints_t.equal x1 x2 then Some x1 else None - - let upper_threshold u max_ik = - let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.upper_thresholds () else ResettableLazy.force widening_thresholds in - let u = Ints_t.to_bigint u in - let max_ik' = Ints_t.to_bigint max_ik in - let t = List.find_opt (fun x -> Z.compare u x <= 0 && Z.compare x max_ik' <= 0) ts in - BatOption.map_default Ints_t.of_bigint max_ik t - let lower_threshold l min_ik = - let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.lower_thresholds () else ResettableLazy.force widening_thresholds_desc in - let l = Ints_t.to_bigint l in - let min_ik' = Ints_t.to_bigint min_ik in - let t = List.find_opt (fun x -> Z.compare l x >= 0 && Z.compare x min_ik' >= 0) ts in - BatOption.map_default Ints_t.of_bigint min_ik t - let is_upper_threshold u = - let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.upper_thresholds () else ResettableLazy.force widening_thresholds in - let u = Ints_t.to_bigint u in - List.exists (Z.equal u) ts - let is_lower_threshold l = - let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.lower_thresholds () else ResettableLazy.force widening_thresholds_desc in - let l = Ints_t.to_bigint l in - List.exists (Z.equal l) ts -end - -module IntInvariant = -struct - let of_int e ik x = - if get_bool "witness.invariant.exact" then - Invariant.of_exp Cil.(BinOp (Eq, e, kintegerCilint ik x, intType)) - else - Invariant.none - - let of_incl_list e ik ps = - match ps with - | [_; _] when ik = IBool && not (get_bool "witness.invariant.inexact-type-bounds") -> - assert (List.mem Z.zero ps); - assert (List.mem Z.one ps); - Invariant.none - | [_] when get_bool "witness.invariant.exact" -> - Invariant.none - | _ :: _ :: _ - | [_] | [] -> - List.fold_left (fun a x -> - let i = Invariant.of_exp Cil.(BinOp (Eq, e, kintegerCilint ik x, intType)) in - Invariant.(a || i) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) - ) (Invariant.bot ()) ps - - let of_interval_opt e ik = function - | (Some x1, Some x2) when Z.equal x1 x2 -> - of_int e ik x1 - | x1_opt, x2_opt -> - let (min_ik, max_ik) = Size.range ik in - let inexact_type_bounds = get_bool "witness.invariant.inexact-type-bounds" in - let i1 = - match x1_opt, inexact_type_bounds with - | Some x1, false when Z.equal min_ik x1 -> Invariant.none - | Some x1, _ -> Invariant.of_exp Cil.(BinOp (Le, kintegerCilint ik x1, e, intType)) - | None, _ -> Invariant.none - in - let i2 = - match x2_opt, inexact_type_bounds with - | Some x2, false when Z.equal x2 max_ik -> Invariant.none - | Some x2, _ -> Invariant.of_exp Cil.(BinOp (Le, e, kintegerCilint ik x2, intType)) - | None, _ -> Invariant.none - in - Invariant.(i1 && i2) - - let of_interval e ik (x1, x2) = - of_interval_opt e ik (Some x1, Some x2) - - let of_excl_list e ik ns = - List.fold_left (fun a x -> - let i = Invariant.of_exp Cil.(BinOp (Ne, e, kintegerCilint ik x, intType)) in - Invariant.(a && i) - ) (Invariant.top ()) ns -end - -module IntervalFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) option = -struct - let name () = "intervals" - type int_t = Ints_t.t - type t = (Ints_t.t * Ints_t.t) option [@@deriving eq, ord, hash] - module IArith = IntervalArith (Ints_t) - - let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) - - let top () = failwith @@ "top () not implemented for " ^ (name ()) - let top_of ik = Some (range ik) - let bot () = None - let bot_of ik = bot () (* TODO: improve *) - - let show = function None -> "bottom" | Some (x,y) -> "["^Ints_t.to_string x^","^Ints_t.to_string y^"]" - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let equal_to i = function - | None -> failwith "unsupported: equal_to with bottom" - | Some (a, b) -> - if a = b && b = i then `Eq else if Ints_t.compare a i <= 0 && Ints_t.compare i b <=0 then `Top else `Neq - - let norm ?(suppress_ovwarn=false) ?(cast=false) ik : (t -> t * overflow_info) = function None -> (None, {underflow=false; overflow=false}) | Some (x,y) -> - if Ints_t.compare x y > 0 then - (None,{underflow=false; overflow=false}) - else ( - let (min_ik, max_ik) = range ik in - let underflow = Ints_t.compare min_ik x > 0 in - let overflow = Ints_t.compare max_ik y < 0 in - let ov_info = { underflow = underflow && not suppress_ovwarn; overflow = overflow && not suppress_ovwarn } in - let v = - if underflow || overflow then - if should_wrap ik then (* could add [|| cast], but that's GCC implementation-defined behavior: https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html#Integers-implementation *) - (* We can only soundly wrap if at most one overflow occurred, otherwise the minimal and maximal values of the interval *) - (* on Z will not safely contain the minimal and maximal elements after the cast *) - let diff = Ints_t.abs (Ints_t.sub max_ik min_ik) in - let resdiff = Ints_t.abs (Ints_t.sub y x) in - if Ints_t.compare resdiff diff > 0 then - top_of ik - else - let l = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint x) in - let u = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint y) in - if Ints_t.compare l u <= 0 then - Some (l, u) - else - (* Interval that wraps around (begins to the right of its end). We can not represent such intervals *) - top_of ik - else if not cast && should_ignore_overflow ik then - let tl, tu = BatOption.get @@ top_of ik in - Some (Ints_t.max tl x, Ints_t.min tu y) - else - top_of ik - else - Some (x,y) - in - (v, ov_info) - ) - - let leq (x:t) (y:t) = - match x, y with - | None, _ -> true - | Some _, None -> false - | Some (x1,x2), Some (y1,y2) -> Ints_t.compare x1 y1 >= 0 && Ints_t.compare x2 y2 <= 0 - - let join ik (x:t) y = - match x, y with - | None, z | z, None -> z - | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.min x1 y1, Ints_t.max x2 y2) |> fst - - let meet ik (x:t) y = - match x, y with - | None, z | z, None -> None - | Some (x1,x2), Some (y1,y2) -> norm ik @@ Some (Ints_t.max x1 y1, Ints_t.min x2 y2) |> fst - - (* TODO: change to_int signature so it returns a big_int *) - let to_int x = Option.bind x (IArith.to_int) - let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm ~suppress_ovwarn ik @@ Some (x,y) - let of_int ik (x: int_t) = of_interval ik (x,x) - let zero = Some IArith.zero - let one = Some IArith.one - let top_bool = Some IArith.top_bool - - let of_bool _ik = function true -> one | false -> zero - let to_bool (a: t) = match a with - | None -> None - | Some (l, u) when Ints_t.compare l Ints_t.zero = 0 && Ints_t.compare u Ints_t.zero = 0 -> Some false - | x -> if leq zero x then None else Some true - - let starting ?(suppress_ovwarn=false) ik n = - norm ~suppress_ovwarn ik @@ Some (n, snd (range ik)) - - let ending ?(suppress_ovwarn=false) ik n = - norm ~suppress_ovwarn ik @@ Some (fst (range ik), n) - - (* TODO: change signature of maximal, minimal to return big_int*) - let maximal = function None -> None | Some (x,y) -> Some y - let minimal = function None -> None | Some (x,y) -> Some x - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = norm ~cast:true t (* norm does all overflow handling *) - - let widen ik x y = - match x, y with - | None, z | z, None -> z - | Some (l0,u0), Some (l1,u1) -> - let (min_ik, max_ik) = range ik in - let threshold = get_interval_threshold_widening () in - let l2 = - if Ints_t.compare l0 l1 = 0 then l0 - else if threshold then IArith.lower_threshold l1 min_ik - else min_ik - in - let u2 = - if Ints_t.compare u0 u1 = 0 then u0 - else if threshold then IArith.upper_threshold u1 max_ik - else max_ik - in - norm ik @@ Some (l2,u2) |> fst - let widen ik x y = - let r = widen ik x y in - if M.tracing && not (equal x y) then M.tracel "int" "interval widen %a %a -> %a" pretty x pretty y pretty r; - assert (leq x y); (* TODO: remove for performance reasons? *) - r - - let narrow ik x y = - match x, y with - | _,None | None, _ -> None - | Some (x1,x2), Some (y1,y2) -> - let threshold = get_interval_threshold_widening () in - let (min_ik, max_ik) = range ik in - let lr = if Ints_t.compare min_ik x1 = 0 || threshold && Ints_t.compare y1 x1 > 0 && IArith.is_lower_threshold x1 then y1 else x1 in - let ur = if Ints_t.compare max_ik x2 = 0 || threshold && Ints_t.compare y2 x2 < 0 && IArith.is_upper_threshold x2 then y2 else x2 in - norm ik @@ Some (lr,ur) |> fst - - - let narrow ik x y = - if get_interval_narrow_by_meet () then - meet ik x y - else - narrow ik x y - - let log f ~annihilator ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> bot_of ik - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_bool i1, to_bool i2 with - | Some x, _ when x = annihilator -> of_bool ik annihilator - | _, Some y when y = annihilator -> of_bool ik annihilator - | Some x, Some y -> of_bool ik (f x y) - | _ -> top_of ik - - let c_logor = log (||) ~annihilator:true - let c_logand = log (&&) ~annihilator:false - - let log1 f ik i1 = - if is_bot i1 then - bot_of ik - else - match to_bool i1 with - | Some x -> of_bool ik (f ik x) - | _ -> top_of ik - - let c_lognot = log1 (fun _ik -> not) - - let bit f ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> bot_of ik - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_int i1, to_int i2 with - | Some x, Some y -> (try of_int ik (f ik x y) |> fst with Division_by_zero -> top_of ik) - | _ -> top_of ik - - let bitcomp f ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> (bot_of ik,{underflow=false; overflow=false}) - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_int i1, to_int i2 with - | Some x, Some y -> (try of_int ik (f ik x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{underflow=false; overflow=false})) - | _ -> (top_of ik,{underflow=true; overflow=true}) - - let logxor = bit (fun _ik -> Ints_t.logxor) - - let logand ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> bot_of ik - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_int i1, to_int i2 with - | Some x, Some y -> (try of_int ik (Ints_t.logand x y) |> fst with Division_by_zero -> top_of ik) - | _, Some y when Ints_t.equal y Ints_t.zero -> of_int ik Ints_t.zero |> fst - | _, Some y when Ints_t.equal y Ints_t.one -> of_interval ik (Ints_t.zero, Ints_t.one) |> fst - | _ -> top_of ik - - let logor = bit (fun _ik -> Ints_t.logor) - - let bit1 f ik i1 = - if is_bot i1 then - bot_of ik - else - match to_int i1 with - | Some x -> of_int ik (f ik x) |> fst - | _ -> top_of ik - - let lognot = bit1 (fun _ik -> Ints_t.lognot) - let shift_right = bitcomp (fun _ik x y -> Ints_t.shift_right x (Ints_t.to_int y)) - - let neg ?no_ov ik = function None -> (None,{underflow=false; overflow=false}) | Some x -> norm ik @@ Some (IArith.neg x) - - let binary_op_with_norm ?no_ov op ik x y = match x, y with - | None, None -> (None, {overflow=false; underflow= false}) - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some x, Some y -> norm ik @@ Some (op x y) - - let add ?no_ov = binary_op_with_norm IArith.add - let mul ?no_ov = binary_op_with_norm IArith.mul - let sub ?no_ov = binary_op_with_norm IArith.sub - - let shift_left ik a b = - match is_bot a, is_bot b with - | true, true -> (bot_of ik,{underflow=false; overflow=false}) - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show a) (show b))) - | _ -> - match a, minimal b, maximal b with - | Some a, Some bl, Some bu when (Ints_t.compare bl Ints_t.zero >= 0) -> - (try - let r = IArith.shift_left a (Ints_t.to_int bl, Ints_t.to_int bu) in - norm ik @@ Some r - with Z.Overflow -> (top_of ik,{underflow=false; overflow=true})) - | _ -> (top_of ik,{underflow=true; overflow=true}) - - let rem ik x y = match x, y with - | None, None -> None - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (xl, xu), Some (yl, yu) -> - if is_top_of ik x && is_top_of ik y then - (* This is needed to preserve soundness also on things bigger than int32 e.g. *) - (* x: 3803957176L -> T in Interval32 *) - (* y: 4209861404L -> T in Interval32 *) - (* x % y: 3803957176L -> T in Interval32 *) - (* T in Interval32 is [-2147483648,2147483647] *) - (* the code below computes [-2147483647,2147483647] for this though which is unsound *) - top_of ik - else - (* If we have definite values, Ints_t.rem will give a definite result. - * Otherwise we meet with a [range] the result can be in. - * This range is [0, min xu b] if x is positive, and [max xl -b, min xu b] if x can be negative. - * The precise bound b is one smaller than the maximum bound. Negative y give the same result as positive. *) - let pos x = if Ints_t.compare x Ints_t.zero < 0 then Ints_t.neg x else x in - let b = Ints_t.sub (Ints_t.max (pos yl) (pos yu)) Ints_t.one in - let range = if Ints_t.compare xl Ints_t.zero>= 0 then Some (Ints_t.zero, Ints_t.min xu b) else Some (Ints_t.max xl (Ints_t.neg b), Ints_t.min (Ints_t.max (pos xl) (pos xu)) b) in - meet ik (bit (fun _ik -> Ints_t.rem) ik x y) range - - let rec div ?no_ov ik x y = - match x, y with - | None, None -> (bot (),{underflow=false; overflow=false}) - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | (Some (x1,x2) as x), (Some (y1,y2) as y) -> - begin - let is_zero v = Ints_t.compare v Ints_t.zero = 0 in - match y1, y2 with - | l, u when is_zero l && is_zero u -> (top_of ik,{underflow=false; overflow=false}) (* TODO warn about undefined behavior *) - | l, _ when is_zero l -> div ik (Some (x1,x2)) (Some (Ints_t.one,y2)) - | _, u when is_zero u -> div ik (Some (x1,x2)) (Some (y1, Ints_t.(neg one))) - | _ when leq (of_int ik (Ints_t.zero) |> fst) (Some (y1,y2)) -> (top_of ik,{underflow=false; overflow=false}) - | _ -> binary_op_with_norm IArith.div ik x y - end - - let ne ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then - of_bool ik true - else if Ints_t.compare x2 y1 <= 0 && Ints_t.compare y2 x1 <= 0 then - of_bool ik false - else top_bool - - let eq ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 <= 0 && Ints_t.compare x2 y1 <= 0 then - of_bool ik true - else if Ints_t.compare y2 x1 < 0 || Ints_t.compare x2 y1 < 0 then - of_bool ik false - else top_bool - - let ge ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 <= 0 then of_bool ik true - else if Ints_t.compare x2 y1 < 0 then of_bool ik false - else top_bool - - let le ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare x2 y1 <= 0 then of_bool ik true - else if Ints_t.compare y2 x1 < 0 then of_bool ik false - else top_bool - - let gt ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare y2 x1 < 0 then of_bool ik true - else if Ints_t.compare x2 y1 <= 0 then of_bool ik false - else top_bool - - let lt ik x y = - match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (x1,x2), Some (y1,y2) -> - if Ints_t.compare x2 y1 < 0 then of_bool ik true - else if Ints_t.compare y2 x1 <= 0 then of_bool ik false - else top_bool - - let invariant_ikind e ik = function - | Some (x1, x2) -> - let (x1', x2') = BatTuple.Tuple2.mapn Ints_t.to_bigint (x1, x2) in - IntInvariant.of_interval e ik (x1', x2') - | None -> Invariant.none - - let arbitrary ik = - let open QCheck.Iter in - (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint GobQCheck.Arbitrary.big_int in *) - (* TODO: apparently bigints are really slow compared to int64 for domaintest *) - let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - let pair_arb = QCheck.pair int_arb int_arb in - let shrink = function - | Some (l, u) -> (return None) <+> (GobQCheck.shrink pair_arb (l, u) >|= of_interval ik >|= fst) - | None -> empty - in - QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) (fun x -> of_interval ik x |> fst ) pair_arb) - - let modulo n k = - let result = Ints_t.rem n k in - if Ints_t.compare result Ints_t.zero >= 0 then result - else Ints_t.add result k - - let refine_with_congruence ik (intv : t) (cong : (int_t * int_t ) option) : t = - match intv, cong with - | Some (x, y), Some (c, m) -> - if Ints_t.equal m Ints_t.zero && (Ints_t.compare c x < 0 || Ints_t.compare c y > 0) then None - else if Ints_t.equal m Ints_t.zero then - Some (c, c) - else - let (min_ik, max_ik) = range ik in - let rcx = - if Ints_t.equal x min_ik then x else - Ints_t.add x (modulo (Ints_t.sub c x) (Ints_t.abs m)) in - let lcy = - if Ints_t.equal y max_ik then y else - Ints_t.sub y (modulo (Ints_t.sub y c) (Ints_t.abs m)) in - if Ints_t.compare rcx lcy > 0 then None - else if Ints_t.equal rcx lcy then norm ik @@ Some (rcx, rcx) |> fst - else norm ik @@ Some (rcx, lcy) |> fst - | _ -> None - - let refine_with_congruence ik x y = - let refn = refine_with_congruence ik x y in - if M.tracing then M.trace "refine" "int_refine_with_congruence %a %a -> %a" pretty x pretty y pretty refn; - refn - - let refine_with_interval ik a b = meet ik a b - - let refine_with_excl_list ik (intv : t) (excl : (int_t list * (int64 * int64)) option) : t = - match intv, excl with - | None, _ | _, None -> intv - | Some(l, u), Some(ls, (rl, rh)) -> - let rec shrink op b = - let new_b = (op b (Ints_t.of_int(Bool.to_int(BatList.mem_cmp Ints_t.compare b ls)))) in - if not (Ints_t.equal b new_b) then shrink op new_b else new_b - in - let (min_ik, max_ik) = range ik in - let l' = if Ints_t.equal l min_ik then l else shrink Ints_t.add l in - let u' = if Ints_t.equal u max_ik then u else shrink Ints_t.sub u in - let intv' = norm ik @@ Some (l', u') |> fst in - let range = norm ~suppress_ovwarn:true ik (Some (Ints_t.of_bigint (Size.min_from_bit_range rl), Ints_t.of_bigint (Size.max_from_bit_range rh))) |> fst in - meet ik intv' range - - let refine_with_incl_list ik (intv: t) (incl : (int_t list) option) : t = - match intv, incl with - | None, _ | _, None -> intv - | Some(l, u), Some(ls) -> - let rec min m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with - | None -> min (Some x) xs | Some m -> if Ints_t.compare m x < 0 then min (Some m) xs else min (Some x) xs in - let rec max m1 ms = match ms with | [] -> m1 | x::xs -> match m1 with - | None -> max (Some x) xs | Some m -> if Ints_t.compare m x > 0 then max (Some m) xs else max (Some x) xs in - match min None ls, max None ls with - | Some m1, Some m2 -> refine_with_interval ik (Some(l, u)) (Some (m1, m2)) - | _, _-> intv - - let project ik p t = t -end - -(** IntervalSetFunctor that is not just disjunctive completion of intervals, but attempts to be precise for wraparound arithmetic for unsigned types *) -module IntervalSetFunctor (Ints_t : IntOps.IntOps): SOverflow with type int_t = Ints_t.t and type t = (Ints_t.t * Ints_t.t) list = -struct - - module Interval = IntervalFunctor (Ints_t) - module IArith = IntervalArith (Ints_t) - - - let name () = "interval_sets" - - type int_t = Ints_t.t - - let (>.) a b = Ints_t.compare a b > 0 - let (=.) a b = Ints_t.compare a b = 0 - let (<.) a b = Ints_t.compare a b < 0 - let (>=.) a b = Ints_t.compare a b >= 0 - let (<=.) a b = Ints_t.compare a b <= 0 - let (+.) a b = Ints_t.add a b - let (-.) a b = Ints_t.sub a b - - (* - Each domain's element is guaranteed to be in canonical form. That is, each interval contained - inside the set does not overlap with each other and they are not adjacent. - *) - type t = (Ints_t.t * Ints_t.t) list [@@deriving eq, hash, ord] - - let range ik = BatTuple.Tuple2.mapn Ints_t.of_bigint (Size.range ik) - - let top () = failwith @@ "top () not implemented for " ^ (name ()) - - let top_of ik = [range ik] - - let bot () = [] - - let bot_of ik = bot () - - let show (x: t) = - let show_interval i = Printf.sprintf "[%s, %s]" (Ints_t.to_string (fst i)) (Ints_t.to_string (snd i)) in - List.fold_left (fun acc i -> (show_interval i) :: acc) [] x |> List.rev |> String.concat ", " |> Printf.sprintf "[%s]" - - (* New type definition for the sweeping line algorithm used for implementing join/meet functions. *) - type event = Enter of Ints_t.t | Exit of Ints_t.t - - let unbox_event = function Enter x -> x | Exit x -> x - - let cmp_events x y = - (* Deliberately comparing ints first => Cannot be derived *) - let res = Ints_t.compare (unbox_event x) (unbox_event y) in - if res <> 0 then res - else - begin - match (x, y) with - | (Enter _, Exit _) -> -1 - | (Exit _, Enter _) -> 1 - | (_, _) -> 0 - end - - let interval_set_to_events (xs: t) = - List.concat_map (fun (a, b) -> [Enter a; Exit b]) xs - - let two_interval_sets_to_events (xs: t) (ys: t) = - let xs = interval_set_to_events xs in - let ys = interval_set_to_events ys in - List.merge cmp_events xs ys - - (* Using the sweeping line algorithm, combined_event_list returns a new event list representing the intervals in which at least n intervals in xs overlap - This function is used for both join and meet operations with different parameter n: 1 for join, 2 for meet *) - let combined_event_list lattice_op (xs:event list) = - let l = match lattice_op with `Join -> 1 | `Meet -> 2 in - let aux (interval_count, acc) = function - | Enter x -> (interval_count + 1, if (interval_count + 1) >= l && interval_count < l then (Enter x)::acc else acc) - | Exit x -> (interval_count - 1, if interval_count >= l && (interval_count - 1) < l then (Exit x)::acc else acc) - in - List.fold_left aux (0, []) xs |> snd |> List.rev - - let rec events_to_intervals = function - | [] -> [] - | (Enter x)::(Exit y)::xs -> (x, y)::(events_to_intervals xs) - | _ -> failwith "Invalid events list" - - let remove_empty_gaps (xs: t) = - let aux acc (l, r) = match acc with - | ((a, b)::acc') when (b +. Ints_t.one) >=. l -> (a, r)::acc' - | _ -> (l, r)::acc - in - List.fold_left aux [] xs |> List.rev - - let canonize (xs: t) = - interval_set_to_events xs |> - List.sort cmp_events |> - combined_event_list `Join |> - events_to_intervals |> - remove_empty_gaps - - let unop (x: t) op = match x with - | [] -> [] - | _ -> canonize @@ List.concat_map op x - - let binop (x: t) (y: t) op : t = match x, y with - | [], _ -> [] - | _, [] -> [] - | _, _ -> canonize @@ List.concat_map op (BatList.cartesian_product x y) - - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let minimal = function - | [] -> None - | (x, _)::_ -> Some x - - let maximal = function - | [] -> None - | xs -> Some (BatList.last xs |> snd) - - let equal_to_interval i (a, b) = - if a =. b && b =. i then - `Eq - else if a <=. i && i <=. b then - `Top - else - `Neq - - let equal_to i xs = match List.map (equal_to_interval i) xs with - | [] -> failwith "unsupported: equal_to with bottom" - | [`Eq] -> `Eq - | ys when List.for_all ((=) `Neq) ys -> `Neq - | _ -> `Top - - let norm_interval ?(suppress_ovwarn=false) ?(cast=false) ik (x,y) : t*overflow_info = - if x >. y then - ([],{underflow=false; overflow=false}) - else - let (min_ik, max_ik) = range ik in - let underflow = min_ik >. x in - let overflow = max_ik <. y in - let v = if underflow || overflow then - begin - if should_wrap ik then (* could add [|| cast], but that's GCC implementation-defined behavior: https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html#Integers-implementation *) - (* We can only soundly wrap if at most one overflow occurred, otherwise the minimal and maximal values of the interval *) - (* on Z will not safely contain the minimal and maximal elements after the cast *) - let diff = Ints_t.abs (max_ik -. min_ik) in - let resdiff = Ints_t.abs (y -. x) in - if resdiff >. diff then - [range ik] - else - let l = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint x) in - let u = Ints_t.of_bigint @@ Size.cast ik (Ints_t.to_bigint y) in - if l <=. u then - [(l, u)] - else - (* Interval that wraps around (begins to the right of its end). We CAN represent such intervals *) - [(min_ik, u); (l, max_ik)] - else if not cast && should_ignore_overflow ik then - [Ints_t.max min_ik x, Ints_t.min max_ik y] - else - [range ik] - end - else - [(x,y)] - in - if suppress_ovwarn then (v, {underflow=false; overflow=false}) else (v, {underflow; overflow}) - - let norm_intvs ?(suppress_ovwarn=false) ?(cast=false) (ik:ikind) (xs: t) : t*overflow_info = - let res = List.map (norm_interval ~suppress_ovwarn ~cast ik) xs in - let intvs = List.concat_map fst res in - let underflow = List.exists (fun (_,{underflow; _}) -> underflow) res in - let overflow = List.exists (fun (_,{overflow; _}) -> underflow) res in - (canonize intvs,{underflow; overflow}) - - let binary_op_with_norm op (ik:ikind) (x: t) (y: t) : t*overflow_info = match x, y with - | [], _ -> ([],{overflow=false; underflow=false}) - | _, [] -> ([],{overflow=false; underflow=false}) - | _, _ -> norm_intvs ik @@ List.concat_map (fun (x,y) -> [op x y]) (BatList.cartesian_product x y) - - let binary_op_with_ovc (x: t) (y: t) op : t*overflow_info = match x, y with - | [], _ -> ([],{overflow=false; underflow=false}) - | _, [] -> ([],{overflow=false; underflow=false}) - | _, _ -> - let res = List.map op (BatList.cartesian_product x y) in - let intvs = List.concat_map fst res in - let underflow = List.exists (fun (_,{underflow; _}) -> underflow) res in - let overflow = List.exists (fun (_,{overflow; _}) -> underflow) res in - (canonize intvs,{underflow; overflow}) - - let unary_op_with_norm op (ik:ikind) (x: t) = match x with - | [] -> ([],{overflow=false; underflow=false}) - | _ -> norm_intvs ik @@ List.concat_map (fun x -> [op x]) x - - let rec leq (xs: t) (ys: t) = - let leq_interval (al, au) (bl, bu) = al >=. bl && au <=. bu in - match xs, ys with - | [], _ -> true - | _, [] -> false - | (xl,xr)::xs', (yl,yr)::ys' -> - if leq_interval (xl,xr) (yl,yr) then - leq xs' ys - else if xr <. yl then - false - else - leq xs ys' - - let join ik (x: t) (y: t): t = - two_interval_sets_to_events x y |> - combined_event_list `Join |> - events_to_intervals |> - remove_empty_gaps - - let meet ik (x: t) (y: t): t = - two_interval_sets_to_events x y |> - combined_event_list `Meet |> - events_to_intervals - - let to_int = function - | [x] -> IArith.to_int x - | _ -> None - - let zero = [IArith.zero] - let one = [IArith.one] - let top_bool = [IArith.top_bool] - - let not_bool (x:t) = - let is_false x = equal x zero in - let is_true x = equal x one in - if is_true x then zero else if is_false x then one else top_bool - - let to_bool = function - | [(l,u)] when l =. Ints_t.zero && u =. Ints_t.zero -> Some false - | x -> if leq zero x then None else Some true - - let of_bool _ = function true -> one | false -> zero - - let of_interval ?(suppress_ovwarn=false) ik (x,y) = norm_interval ~suppress_ovwarn ~cast:false ik (x,y) - - let of_int ik (x: int_t) = of_interval ik (x, x) - - let lt ik x y = - match x, y with - | [], [] -> bot_of ik - | [], _ | _, [] -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | _, _ -> - let (max_x, min_y) = (maximal x |> Option.get, minimal y |> Option.get) in - let (min_x, max_y) = (minimal x |> Option.get, maximal y |> Option.get) in - if max_x <. min_y then - of_bool ik true - else if min_x >=. max_y then - of_bool ik false - else - top_bool - - let le ik x y = - match x, y with - | [], [] -> bot_of ik - | [], _ | _, [] -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | _, _ -> - let (max_x, min_y) = (maximal x |> Option.get, minimal y |> Option.get) in - let (min_x, max_y) = (minimal x |> Option.get, maximal y |> Option.get) in - if max_x <=. min_y then - of_bool ik true - else if min_x >. max_y then - of_bool ik false - else - top_bool - - let gt ik x y = not_bool @@ le ik x y - - let ge ik x y = not_bool @@ lt ik x y - - let eq ik x y = match x, y with - | (a, b)::[], (c, d)::[] when a =. b && c =. d && a =. c -> - one - | _ -> - if is_bot (meet ik x y) then - zero - else - top_bool - - let ne ik x y = not_bool @@ eq ik x y - let interval_to_int i = Interval.to_int (Some i) - let interval_to_bool i = Interval.to_bool (Some i) - - let log f ik (i1, i2) = - match (interval_to_bool i1, interval_to_bool i2) with - | Some x, Some y -> of_bool ik (f x y) - | _ -> top_of ik - - - let bit f ik (i1, i2) = - match (interval_to_int i1), (interval_to_int i2) with - | Some x, Some y -> (try of_int ik (f x y) |> fst with Division_by_zero -> top_of ik) - | _ -> top_of ik - - - let bitcomp f ik (i1, i2) = - match (interval_to_int i1, interval_to_int i2) with - | Some x, Some y -> (try of_int ik (f x y) with Division_by_zero | Invalid_argument _ -> (top_of ik,{overflow=false; underflow=false})) - | _, _ -> (top_of ik,{overflow=false; underflow=false}) - - let logand ik x y = - let interval_logand = bit Ints_t.logand ik in - binop x y interval_logand - - let logor ik x y = - let interval_logor = bit Ints_t.logor ik in - binop x y interval_logor - - let logxor ik x y = - let interval_logxor = bit Ints_t.logxor ik in - binop x y interval_logxor - - let lognot ik x = - let interval_lognot i = - match interval_to_int i with - | Some x -> of_int ik (Ints_t.lognot x) |> fst - | _ -> top_of ik - in - unop x interval_lognot - - let shift_left ik x y = - let interval_shiftleft = bitcomp (fun x y -> Ints_t.shift_left x (Ints_t.to_int y)) ik in - binary_op_with_ovc x y interval_shiftleft - - let shift_right ik x y = - let interval_shiftright = bitcomp (fun x y -> Ints_t.shift_right x (Ints_t.to_int y)) ik in - binary_op_with_ovc x y interval_shiftright - - let c_lognot ik x = - let log1 f ik i1 = - match interval_to_bool i1 with - | Some x -> of_bool ik (f x) - | _ -> top_of ik - in - let interval_lognot = log1 not ik in - unop x interval_lognot - - let c_logand ik x y = - let interval_logand = log (&&) ik in - binop x y interval_logand - - let c_logor ik x y = - let interval_logor = log (||) ik in - binop x y interval_logor - - let add ?no_ov = binary_op_with_norm IArith.add - let sub ?no_ov = binary_op_with_norm IArith.sub - let mul ?no_ov = binary_op_with_norm IArith.mul - let neg ?no_ov = unary_op_with_norm IArith.neg - - let div ?no_ov ik x y = - let rec interval_div x (y1, y2) = begin - let top_of ik = top_of ik |> List.hd in - let is_zero v = v =. Ints_t.zero in - match y1, y2 with - | l, u when is_zero l && is_zero u -> top_of ik (* TODO warn about undefined behavior *) - | l, _ when is_zero l -> interval_div x (Ints_t.one,y2) - | _, u when is_zero u -> interval_div x (y1, Ints_t.(neg one)) - | _ when leq (of_int ik (Ints_t.zero) |> fst) ([(y1,y2)]) -> top_of ik - | _ -> IArith.div x (y1, y2) - end - in binary_op_with_norm interval_div ik x y - - let rem ik x y = - let interval_rem (x, y) = - if Interval.is_top_of ik (Some x) && Interval.is_top_of ik (Some y) then - top_of ik - else - let (xl, xu) = x in let (yl, yu) = y in - let pos x = if x <. Ints_t.zero then Ints_t.neg x else x in - let b = (Ints_t.max (pos yl) (pos yu)) -. Ints_t.one in - let range = if xl >=. Ints_t.zero then (Ints_t.zero, Ints_t.min xu b) else (Ints_t.max xl (Ints_t.neg b), Ints_t.min (Ints_t.max (pos xl) (pos xu)) b) in - meet ik (bit Ints_t.rem ik (x, y)) [range] - in - binop x y interval_rem - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik x = norm_intvs ~cast:true ik x - - (* - narrows down the extremeties of xs if they are equal to boundary values of the ikind with (possibly) narrower values from ys - *) - let narrow ik xs ys = match xs ,ys with - | [], _ -> [] | _ ,[] -> xs - | _, _ -> - let min_xs = minimal xs |> Option.get in - let max_xs = maximal xs |> Option.get in - let min_ys = minimal ys |> Option.get in - let max_ys = maximal ys |> Option.get in - let min_range,max_range = range ik in - let threshold = get_interval_threshold_widening () in - let min = if min_xs =. min_range || threshold && min_ys >. min_xs && IArith.is_lower_threshold min_xs then min_ys else min_xs in - let max = if max_xs =. max_range || threshold && max_ys <. max_xs && IArith.is_upper_threshold max_xs then max_ys else max_xs in - xs - |> (function (_, y)::z -> (min, y)::z | _ -> []) - |> List.rev - |> (function (x, _)::z -> (x, max)::z | _ -> []) - |> List.rev - - (* - 1. partitions the intervals of xs by assigning each of them to the an interval in ys that includes it. - and joins all intervals in xs assigned to the same interval in ys as one interval. - 2. checks for every pair of adjacent pairs whether the pairs did approach (if you compare the intervals from xs and ys) and merges them if it is the case. - 3. checks whether partitions at the extremeties are approaching infinity (and expands them to infinity. in that case) - - The expansion (between a pair of adjacent partitions or at extremeties ) stops at a threshold. - *) - let widen ik xs ys = - let (min_ik,max_ik) = range ik in - let threshold = get_bool "ana.int.interval_threshold_widening" in - let upper_threshold (_,u) = IArith.upper_threshold u max_ik in - let lower_threshold (l,_) = IArith.lower_threshold l min_ik in - (*obtain partitioning of xs intervals according to the ys interval that includes them*) - let rec interval_sets_to_partitions (ik: ikind) (acc : (int_t * int_t) option) (xs: t) (ys: t)= - match xs,ys with - | _, [] -> [] - | [], (y::ys) -> (acc,y):: interval_sets_to_partitions ik None [] ys - | (x::xs), (y::ys) when Interval.leq (Some x) (Some y) -> interval_sets_to_partitions ik (Interval.join ik acc (Some x)) xs (y::ys) - | (x::xs), (y::ys) -> (acc,y) :: interval_sets_to_partitions ik None (x::xs) ys - in - let interval_sets_to_partitions ik xs ys = interval_sets_to_partitions ik None xs ys in - (*merge a pair of adjacent partitions*) - let merge_pair ik (a,b) (c,d) = - let new_a = function - | None -> Some (upper_threshold b, upper_threshold b) - | Some (ax,ay) -> Some (ax, upper_threshold b) - in - let new_c = function - | None -> Some (lower_threshold d, lower_threshold d) - | Some (cx,cy) -> Some (lower_threshold d, cy) - in - if threshold && (lower_threshold d +. Ints_t.one) >. (upper_threshold b) then - [(new_a a,(fst b, upper_threshold b)); (new_c c, (lower_threshold d, snd d))] - else - [(Interval.join ik a c, (Interval.join ik (Some b) (Some d) |> Option.get))] - in - let partitions_are_approaching part_left part_right = match part_left, part_right with - | (Some (_, left_x), (_, left_y)), (Some (right_x, _), (right_y, _)) -> (right_x -. left_x) >. (right_y -. left_y) - | _,_ -> false - in - (*merge all approaching pairs of adjacent partitions*) - let rec merge_list ik = function - | [] -> [] - | x::y::xs when partitions_are_approaching x y -> merge_list ik ((merge_pair ik x y) @ xs) - | x::xs -> x :: merge_list ik xs - in - (*expands left extremity*) - let widen_left = function - | [] -> [] - | (None,(lb,rb))::ts -> let lt = if threshold then lower_threshold (lb,lb) else min_ik in (None, (lt,rb))::ts - | (Some (la,ra), (lb,rb))::ts when lb <. la -> let lt = if threshold then lower_threshold (lb,lb) else min_ik in (Some (la,ra),(lt,rb))::ts - | x -> x - in - (*expands right extremity*) - let widen_right x = - let map_rightmost = function - | [] -> [] - | (None,(lb,rb))::ts -> let ut = if threshold then upper_threshold (rb,rb) else max_ik in (None, (lb,ut))::ts - | (Some (la,ra), (lb,rb))::ts when ra <. rb -> let ut = if threshold then upper_threshold (rb,rb) else max_ik in (Some (la,ra),(lb,ut))::ts - | x -> x - in - List.rev x |> map_rightmost |> List.rev - in - interval_sets_to_partitions ik xs ys |> merge_list ik |> widen_left |> widen_right |> List.map snd - - let starting ?(suppress_ovwarn=false) ik n = norm_interval ik ~suppress_ovwarn (n, snd (range ik)) - - let ending ?(suppress_ovwarn=false) ik n = norm_interval ik ~suppress_ovwarn (fst (range ik), n) - - let invariant_ikind e ik xs = - List.map (fun x -> Interval.invariant_ikind e ik (Some x)) xs |> - let open Invariant in List.fold_left (||) (bot ()) - - let modulo n k = - let result = Ints_t.rem n k in - if result >=. Ints_t.zero then result - else result +. k - - let refine_with_congruence ik (intvs: t) (cong: (int_t * int_t ) option): t = - let refine_with_congruence_interval ik (cong : (int_t * int_t ) option) (intv : (int_t * int_t ) option): t = - match intv, cong with - | Some (x, y), Some (c, m) -> - if m =. Ints_t.zero && (c <. x || c >. y) then [] - else if m =. Ints_t.zero then - [(c, c)] - else - let (min_ik, max_ik) = range ik in - let rcx = - if x =. min_ik then x else - x +. (modulo (c -. x) (Ints_t.abs m)) in - let lcy = - if y =. max_ik then y else - y -. (modulo (y -. c) (Ints_t.abs m)) in - if rcx >. lcy then [] - else if rcx =. lcy then norm_interval ik (rcx, rcx) |> fst - else norm_interval ik (rcx, lcy) |> fst - | _ -> [] - in - List.concat_map (fun x -> refine_with_congruence_interval ik cong (Some x)) intvs - - let refine_with_interval ik xs = function None -> [] | Some (a,b) -> meet ik xs [(a,b)] - - let refine_with_incl_list ik intvs = function - | None -> intvs - | Some xs -> meet ik intvs (List.map (fun x -> (x,x)) xs) - - let excl_range_to_intervalset (ik: ikind) ((min, max): int_t * int_t) (excl: int_t): t = - let intv1 = (min, excl -. Ints_t.one) in - let intv2 = (excl +. Ints_t.one, max) in - norm_intvs ik ~suppress_ovwarn:true [intv1 ; intv2] |> fst - - let of_excl_list ik (excls: int_t list) = - let excl_list = List.map (excl_range_to_intervalset ik (range ik)) excls in - let res = List.fold_left (meet ik) (top_of ik) excl_list in - res - - let refine_with_excl_list ik (intv : t) = function - | None -> intv - | Some (xs, range) -> - let excl_to_intervalset (ik: ikind) ((rl, rh): (int64 * int64)) (excl: int_t): t = - excl_range_to_intervalset ik (Ints_t.of_bigint (Size.min_from_bit_range rl),Ints_t.of_bigint (Size.max_from_bit_range rh)) excl - in - let excl_list = List.map (excl_to_intervalset ik range) xs in - List.fold_left (meet ik) intv excl_list - - let project ik p t = t - - let arbitrary ik = - let open QCheck.Iter in - (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint GobQCheck.Arbitrary.big_int in *) - (* TODO: apparently bigints are really slow compared to int64 for domaintest *) - let int_arb = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 in - let pair_arb = QCheck.pair int_arb int_arb in - let list_pair_arb = QCheck.small_list pair_arb in - let canonize_randomly_generated_list = (fun x -> norm_intvs ik x |> fst) in - let shrink xs = GobQCheck.shrink list_pair_arb xs >|= canonize_randomly_generated_list - in QCheck.(set_shrink shrink @@ set_print show @@ map (*~rev:BatOption.get*) canonize_randomly_generated_list list_pair_arb) -end - -module SOverflowUnlifter (D : SOverflow) : S with type int_t = D.int_t and type t = D.t = struct - include D - - let add ?no_ov ik x y = fst @@ D.add ?no_ov ik x y - - let sub ?no_ov ik x y = fst @@ D.sub ?no_ov ik x y - - let mul ?no_ov ik x y = fst @@ D.mul ?no_ov ik x y - - let div ?no_ov ik x y = fst @@ D.div ?no_ov ik x y - - let neg ?no_ov ik x = fst @@ D.neg ?no_ov ik x - - let cast_to ?suppress_ovwarn ?torg ?no_ov ik x = fst @@ D.cast_to ?suppress_ovwarn ?torg ?no_ov ik x - - let of_int ik x = fst @@ D.of_int ik x - - let of_interval ?suppress_ovwarn ik x = fst @@ D.of_interval ?suppress_ovwarn ik x - - let starting ?suppress_ovwarn ik x = fst @@ D.starting ?suppress_ovwarn ik x - - let ending ?suppress_ovwarn ik x = fst @@ D.ending ?suppress_ovwarn ik x - - let shift_left ik x y = fst @@ D.shift_left ik x y - - let shift_right ik x y = fst @@ D.shift_right ik x y -end - -module IntIkind = struct let ikind () = Cil.IInt end -module Interval = IntervalFunctor (IntOps.BigIntOps) -module Interval32 = IntDomWithDefaultIkind (IntDomLifter (SOverflowUnlifter (IntervalFunctor (IntOps.Int64Ops)))) (IntIkind) -module IntervalSet = IntervalSetFunctor (IntOps.BigIntOps) -module Integers (Ints_t : IntOps.IntOps): IkindUnawareS with type t = Ints_t.t and type int_t = Ints_t.t = (* no top/bot, order is <= *) -struct - include Printable.Std - let name () = "integers" - type t = Ints_t.t [@@deriving eq, ord, hash] - type int_t = Ints_t.t - let top () = raise Unknown - let bot () = raise Error - let top_of ik = top () - let bot_of ik = bot () - let show (x: Ints_t.t) = Ints_t.to_string x - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - (* is_top and is_bot are never called, but if they were, the Std impl would raise their exception, so we overwrite them: *) - let is_top _ = false - let is_bot _ = false - - let equal_to i x = if i > x then `Neq else `Top - let leq x y = x <= y - let join x y = if Ints_t.compare x y > 0 then x else y - let widen = join - let meet x y = if Ints_t.compare x y > 0 then y else x - let narrow = meet - - let of_bool x = if x then Ints_t.one else Ints_t.zero - let to_bool' x = x <> Ints_t.zero - let to_bool x = Some (to_bool' x) - let of_int x = x - let to_int x = Some x - - let neg = Ints_t.neg - let add = Ints_t.add (* TODO: signed overflow is undefined behavior! *) - let sub = Ints_t.sub - let mul = Ints_t.mul - let div = Ints_t.div - let rem = Ints_t.rem - let lt n1 n2 = of_bool (n1 < n2) - let gt n1 n2 = of_bool (n1 > n2) - let le n1 n2 = of_bool (n1 <= n2) - let ge n1 n2 = of_bool (n1 >= n2) - let eq n1 n2 = of_bool (n1 = n2) - let ne n1 n2 = of_bool (n1 <> n2) - let lognot = Ints_t.lognot - let logand = Ints_t.logand - let logor = Ints_t.logor - let logxor = Ints_t.logxor - let shift_left n1 n2 = Ints_t.shift_left n1 (Ints_t.to_int n2) - let shift_right n1 n2 = Ints_t.shift_right n1 (Ints_t.to_int n2) - let c_lognot n1 = of_bool (not (to_bool' n1)) - let c_logand n1 n2 = of_bool ((to_bool' n1) && (to_bool' n2)) - let c_logor n1 n2 = of_bool ((to_bool' n1) || (to_bool' n2)) - let cast_to ?(suppress_ovwarn=false) ?torg t x = failwith @@ "Cast_to not implemented for " ^ (name ()) ^ "." - let arbitrary ik = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 (* TODO: use ikind *) - let invariant _ _ = Invariant.none (* TODO *) -end - -module FlatPureIntegers: IkindUnawareS with type t = int64 and type int_t = int64 = (* Integers, but raises Unknown/Error on join/meet *) -struct - include Integers(IntOps.Int64Ops) - let top () = raise Unknown - let bot () = raise Error - let leq = equal - let pretty_diff () (x,y) = Pretty.dprintf "Integer %a instead of %a" pretty x pretty y - let join x y = if equal x y then x else top () - let meet x y = if equal x y then x else bot () -end - -module Flat (Base: IkindUnawareS) = (* identical to Lift, but goes to `Top/`Bot if Base raises Unknown/Error *) -struct - type int_t = Base.int_t - include Lattice.FlatConf (struct - include Printable.DefaultConf - let top_name = "Unknown int" - let bot_name = "Error int" - end) (Base) - - let top_of ik = top () - let bot_of ik = bot () - - - let name () = "flat integers" - let cast_to ?(suppress_ovwarn=false) ?torg t = function - | `Lifted x -> `Lifted (Base.cast_to t x) - | x -> x - - let equal_to i = function - | `Bot -> failwith "unsupported: equal_to with bottom" - | `Top -> `Top - | `Lifted x -> Base.equal_to i x - - let of_int x = `Lifted (Base.of_int x) - let to_int x = match x with - | `Lifted x -> Base.to_int x - | _ -> None - - let of_bool x = `Lifted (Base.of_bool x) - let to_bool x = match x with - | `Lifted x -> Base.to_bool x - | _ -> None - - let to_excl_list x = None - let of_excl_list ik x = top_of ik - let is_excl_list x = false - let to_incl_list x = None - let of_interval ?(suppress_ovwarn=false) ik x = top_of ik - let of_congruence ik x = top_of ik - let starting ?(suppress_ovwarn=false) ikind x = top_of ikind - let ending ?(suppress_ovwarn=false) ikind x = top_of ikind - let maximal x = None - let minimal x = None - - let lift1 f x = match x with - | `Lifted x -> - (try `Lifted (f x) with Unknown -> `Top | Error -> `Bot) - | x -> x - let lift2 f x y = match x,y with - | `Lifted x, `Lifted y -> - (try `Lifted (f x y) with Unknown -> `Top | Error -> `Bot) - | `Bot, `Bot -> `Bot - | _ -> `Top - - let neg = lift1 Base.neg - let add = lift2 Base.add - let sub = lift2 Base.sub - let mul = lift2 Base.mul - let div = lift2 Base.div - let rem = lift2 Base.rem - let lt = lift2 Base.lt - let gt = lift2 Base.gt - let le = lift2 Base.le - let ge = lift2 Base.ge - let eq = lift2 Base.eq - let ne = lift2 Base.ne - let lognot = lift1 Base.lognot - let logand = lift2 Base.logand - let logor = lift2 Base.logor - let logxor = lift2 Base.logxor - let shift_left = lift2 Base.shift_left - let shift_right = lift2 Base.shift_right - let c_lognot = lift1 Base.c_lognot - let c_logand = lift2 Base.c_logand - let c_logor = lift2 Base.c_logor - - let invariant e = function - | `Lifted x -> Base.invariant e x - | `Top | `Bot -> Invariant.none -end - -module Lift (Base: IkindUnawareS) = (* identical to Flat, but does not go to `Top/Bot` if Base raises Unknown/Error *) -struct - include Lattice.LiftPO (struct - include Printable.DefaultConf - let top_name = "MaxInt" - let bot_name = "MinInt" - end) (Base) - type int_t = Base.int_t - let top_of ik = top () - let bot_of ik = bot () - include StdTop (struct type nonrec t = t let top_of = top_of end) - - let name () = "lifted integers" - let cast_to ?(suppress_ovwarn=false) ?torg t = function - | `Lifted x -> `Lifted (Base.cast_to t x) - | x -> x - - let equal_to i = function - | `Bot -> failwith "unsupported: equal_to with bottom" - | `Top -> `Top - | `Lifted x -> Base.equal_to i x - - let of_int x = `Lifted (Base.of_int x) - let to_int x = match x with - | `Lifted x -> Base.to_int x - | _ -> None - - let of_bool x = `Lifted (Base.of_bool x) - let to_bool x = match x with - | `Lifted x -> Base.to_bool x - | _ -> None - - let lift1 f x = match x with - | `Lifted x -> `Lifted (f x) - | x -> x - let lift2 f x y = match x,y with - | `Lifted x, `Lifted y -> `Lifted (f x y) - | `Bot, `Bot -> `Bot - | _ -> `Top - - let neg = lift1 Base.neg - let add = lift2 Base.add - let sub = lift2 Base.sub - let mul = lift2 Base.mul - let div = lift2 Base.div - let rem = lift2 Base.rem - let lt = lift2 Base.lt - let gt = lift2 Base.gt - let le = lift2 Base.le - let ge = lift2 Base.ge - let eq = lift2 Base.eq - let ne = lift2 Base.ne - let lognot = lift1 Base.lognot - let logand = lift2 Base.logand - let logor = lift2 Base.logor - let logxor = lift2 Base.logxor - let shift_left = lift2 Base.shift_left - let shift_right = lift2 Base.shift_right - let c_lognot = lift1 Base.c_lognot - let c_logand = lift2 Base.c_logand - let c_logor = lift2 Base.c_logor - - let invariant e = function - | `Lifted x -> Base.invariant e x - | `Top | `Bot -> Invariant.none -end - -module Flattened = Flat (Integers (IntOps.Int64Ops)) -module Lifted = Lift (Integers (IntOps.Int64Ops)) - -module Reverse (Base: IkindUnawareS) = -struct - include Base - include (Lattice.Reverse (Base) : Lattice.S with type t := Base.t) -end - -module BISet = struct - include SetDomain.Make (IntOps.BigIntOps) - let is_singleton s = cardinal s = 1 -end - -(* The module [Exclusion] constains common functionality about handling of exclusion sets between [DefExc] and [Enums] *) -module Exclusion = -struct - module R = Interval32 - (* We use these types for the functions in this module to make the intended meaning more explicit *) - type t = Exc of BISet.t * Interval32.t - type inc = Inc of BISet.t [@@unboxed] - let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) - let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) - let cardinality_of_range r = Z.succ (Z.add (Z.neg (min_of_range r)) (max_of_range r)) - - let cardinality_BISet s = - Z.of_int (BISet.cardinal s) - - let leq_excl_incl (Exc (xs, r)) (Inc ys) = - (* For a <= b to hold, the cardinalities must fit, i.e. |a| <= |b|, which implies |min_r, max_r| - |xs| <= |ys|. We check this first. *) - let lower_bound_cardinality_a = Z.sub (cardinality_of_range r) (cardinality_BISet xs) in - let card_b = cardinality_BISet ys in - if Z.compare lower_bound_cardinality_a card_b > 0 then - false - else (* The cardinality did fit, so we check for all elements that are represented by range r, whether they are in (xs union ys) *) - let min_a = min_of_range r in - let max_a = max_of_range r in - GobZ.for_all_range (fun el -> BISet.mem el xs || BISet.mem el ys) (min_a, max_a) - - let leq (Exc (xs, r)) (Exc (ys, s)) = - let min_a, max_a = min_of_range r, max_of_range r in - let excluded_check = BISet.for_all (fun y -> BISet.mem y xs || Z.compare y min_a < 0 || Z.compare y max_a > 0) ys in (* if true, then the values ys, that are not in b, also do not occur in a *) - if not excluded_check - then false - else begin (* Check whether all elements that are in the range r, but not in s, are in xs, i.e. excluded. *) - if R.leq r s then true - else begin if Z.compare (cardinality_BISet xs) (Z.sub (cardinality_of_range r) (cardinality_of_range s)) >= 0 (* Check whether the number of excluded elements in a is as least as big as |min_r, max_r| - |min_s, max_s| *) - then - let min_b, max_b = min_of_range s, max_of_range s in - let leq1 = (* check whether the elements in [r_l; s_l-1] are all in xs, i.e. excluded *) - if Z.compare min_a min_b < 0 then - GobZ.for_all_range (fun x -> BISet.mem x xs) (min_a, Z.pred min_b) - else - true - in - let leq2 () = (* check whether the elements in [s_u+1; r_u] are all in xs, i.e. excluded *) - if Z.compare max_b max_a < 0 then - GobZ.for_all_range (fun x -> BISet.mem x xs) (Z.succ max_b, max_a) - else - true - in - leq1 && (leq2 ()) - else - false - end - end -end - -module DefExc : S with type int_t = Z.t = (* definite or set of excluded values *) -struct - module S = BISet - module R = Interval32 (* range for exclusion *) - - (* Ikind used for intervals representing the domain *) - let range_ikind = Cil.IInt - let size t = R.of_interval range_ikind (let a,b = Size.bits_i64 t in Int64.neg a,b) - - - type t = [ - | `Excluded of S.t * R.t - | `Definite of Z.t - | `Bot - ] [@@deriving eq, ord, hash] - type int_t = Z.t - let name () = "def_exc" - - - let top_range = R.of_interval range_ikind (-99L, 99L) (* Since there is no top ikind we use a range that includes both ILongLong [-63,63] and IULongLong [0,64]. Only needed for intermediate range computation on longs. Correct range is set by cast. *) - let top () = `Excluded (S.empty (), top_range) - let bot () = `Bot - let top_of ik = `Excluded (S.empty (), size ik) - let bot_of ik = bot () - - let show x = - let short_size x = "("^R.show x^")" in - match x with - | `Bot -> "Error int" - | `Definite x -> Z.to_string x - (* Print the empty exclusion as if it was a distinct top element: *) - | `Excluded (s,l) when S.is_empty s -> "Unknown int" ^ short_size l - (* Prepend the exclusion sets with something: *) - | `Excluded (s,l) -> "Not " ^ S.show s ^ short_size l - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let maximal = function - | `Definite x -> Some x - | `Excluded (s,r) -> Some (Exclusion.max_of_range r) - | `Bot -> None - - let minimal = function - | `Definite x -> Some x - | `Excluded (s,r) -> Some (Exclusion.min_of_range r) - | `Bot -> None - - let in_range r i = - if Z.compare i Z.zero < 0 then - let lowerb = Exclusion.min_of_range r in - Z.compare lowerb i <= 0 - else - let upperb = Exclusion.max_of_range r in - Z.compare i upperb <= 0 - - let is_top x = x = top () - - let equal_to i = function - | `Bot -> failwith "unsupported: equal_to with bottom" - | `Definite x -> if i = x then `Eq else `Neq - | `Excluded (s,r) -> if S.mem i s then `Neq else `Top - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik = function - | `Excluded (s,r) -> - let r' = size ik in - if R.leq r r' then (* upcast -> no change *) - `Excluded (s, r) - else if ik = IBool then (* downcast to bool *) - if S.mem Z.zero s then - `Definite Z.one - else - `Excluded (S.empty(), r') - else - (* downcast: may overflow *) - (* let s' = S.map (Size.cast ik) s in *) - (* We want to filter out all i in s' where (t)x with x in r could be i. *) - (* Since this is hard to compute, we just keep all i in s' which overflowed, since those are safe - all i which did not overflow may now be possible due to overflow of r. *) - (* S.diff s' s, r' *) - (* The above is needed for test 21/03, but not sound! See example https://github.com/goblint/analyzer/pull/95#discussion_r483023140 *) - `Excluded (S.empty (), r') - | `Definite x -> `Definite (Size.cast ik x) - | `Bot -> `Bot - - (* Wraps definite values and excluded values according to the ikind. - * For an `Excluded s,r , assumes that r is already an overapproximation of the range of possible values. - * r might be larger than the possible range of this type; the range of the returned `Excluded set will be within the bounds of the ikind. - *) - let norm ik v = - match v with - | `Excluded (s, r) -> - let possibly_overflowed = not (R.leq r (size ik)) || not (S.for_all (in_range (size ik)) s) in - (* If no overflow occurred, just return x *) - if not possibly_overflowed then ( - v - ) - (* Else, if an overflow might have occurred but we should just ignore it *) - else if should_ignore_overflow ik then ( - let r = size ik in - (* filter out excluded elements that are not in the range *) - let mapped_excl = S.filter (in_range r) s in - `Excluded (mapped_excl, r) - ) - (* Else, if an overflow occurred that we should not treat with wrap-around, go to top *) - else if not (should_wrap ik) then ( - top_of ik - ) else ( - (* Else an overflow occurred that we should treat with wrap-around *) - let r = size ik in - (* Perform a wrap-around for unsigned values and for signed values (if configured). *) - let mapped_excl = S.map (fun excl -> Size.cast ik excl) s in - match ik with - | IBool -> - begin match S.mem Z.zero mapped_excl, S.mem Z.one mapped_excl with - | false, false -> `Excluded (mapped_excl, r) (* Not {} -> Not {} *) - | true, false -> `Definite Z.one (* Not {0} -> 1 *) - | false, true -> `Definite Z.zero (* Not {1} -> 0 *) - | true, true -> `Bot (* Not {0, 1} -> bot *) - end - | ik -> - `Excluded (mapped_excl, r) - ) - | `Definite x -> - let min, max = Size.range ik in - (* Perform a wrap-around for unsigned values and for signed values (if configured). *) - if should_wrap ik then ( - cast_to ik v - ) - else if Z.compare min x <= 0 && Z.compare x max <= 0 then ( - v - ) - else if should_ignore_overflow ik then ( - M.warn ~category:M.Category.Integer.overflow "DefExc: Value was outside of range, indicating overflow, but 'sem.int.signed_overflow' is 'assume_none' -> Returned Bot"; - `Bot - ) - else ( - top_of ik - ) - | `Bot -> `Bot - - let leq x y = match (x,y) with - (* `Bot <= x is always true *) - | `Bot, _ -> true - (* Anything except bot <= bot is always false *) - | _, `Bot -> false - (* Two known values are leq whenever equal *) - | `Definite (x: int_t), `Definite y -> x = y - (* A definite value is leq all exclusion sets that don't contain it *) - | `Definite x, `Excluded (s,r) -> in_range r x && not (S.mem x s) - (* No finite exclusion set can be leq than a definite value *) - | `Excluded (xs, xr), `Definite d -> - Exclusion.(leq_excl_incl (Exc (xs, xr)) (Inc (S.singleton d))) - | `Excluded (xs,xr), `Excluded (ys,yr) -> - Exclusion.(leq (Exc (xs,xr)) (Exc (ys, yr))) - - let join' ?range ik x y = - match (x,y) with - (* The least upper bound with the bottom element: *) - | `Bot, x -> x - | x, `Bot -> x - (* The case for two known values: *) - | `Definite (x: int_t), `Definite y -> - (* If they're equal, it's just THAT value *) - if x = y then `Definite x - (* Unless one of them is zero, we can exclude it: *) - else - let a,b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in - let r = R.join (R.of_interval range_ikind a) (R.of_interval range_ikind b) in - `Excluded ((if Z.equal x Z.zero || Z.equal y Z.zero then S.empty () else S.singleton Z.zero), r) - (* A known value and an exclusion set... the definite value should no - * longer be excluded: *) - | `Excluded (s,r), `Definite x - | `Definite x, `Excluded (s,r) -> - if not (in_range r x) then - let a = R.of_interval range_ikind (Size.min_range_sign_agnostic x) in - `Excluded (S.remove x s, R.join a r) - else - `Excluded (S.remove x s, r) - (* For two exclusion sets, only their intersection can be excluded: *) - | `Excluded (x,wx), `Excluded (y,wy) -> `Excluded (S.inter x y, range |? R.join wx wy) - - let join ik = join' ik - - - let widen ik x y = - if get_def_exc_widen_by_join () then - join' ik x y - else if equal x y then - x - else - join' ~range:(size ik) ik x y - - - let meet ik x y = - match (x,y) with - (* Greatest LOWER bound with the least element is trivial: *) - | `Bot, _ -> `Bot - | _, `Bot -> `Bot - (* Definite elements are either equal or the glb is bottom *) - | `Definite x, `Definite y -> if x = y then `Definite x else `Bot - (* The glb of a definite element and an exclusion set is either bottom or - * just the element itself, if it isn't in the exclusion set *) - | `Excluded (s,r), `Definite x - | `Definite x, `Excluded (s,r) -> if S.mem x s || not (in_range r x) then `Bot else `Definite x - (* The greatest lower bound of two exclusion sets is their union, this is - * just DeMorgans Law *) - | `Excluded (x,r1), `Excluded (y,r2) -> - let r' = R.meet r1 r2 in - let s' = S.union x y |> S.filter (in_range r') in - `Excluded (s', r') - - let narrow ik x y = x - - let of_int ik x = norm ik @@ `Definite x - let to_int x = match x with - | `Definite x -> Some x - | _ -> None - - let from_excl ikind (s: S.t) = norm ikind @@ `Excluded (s, size ikind) - - let of_bool_cmp ik x = of_int ik (if x then Z.one else Z.zero) - let of_bool = of_bool_cmp - let to_bool x = - match x with - | `Definite x -> Some (IntOps.BigIntOps.to_bool x) - | `Excluded (s,r) when S.mem Z.zero s -> Some true - | _ -> None - let top_bool = `Excluded (S.empty (), R.of_interval range_ikind (0L, 1L)) - - let of_interval ?(suppress_ovwarn=false) ik (x,y) = - if Z.compare x y = 0 then - of_int ik x - else - let a, b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in - let r = R.join (R.of_interval ~suppress_ovwarn range_ikind a) (R.of_interval ~suppress_ovwarn range_ikind b) in - let ex = if Z.gt x Z.zero || Z.lt y Z.zero then S.singleton Z.zero else S.empty () in - norm ik @@ (`Excluded (ex, r)) - - let starting ?(suppress_ovwarn=false) ikind x = - let _,u_ik = Size.range ikind in - of_interval ~suppress_ovwarn ikind (x, u_ik) - - let ending ?(suppress_ovwarn=false) ikind x = - let l_ik,_ = Size.range ikind in - of_interval ~suppress_ovwarn ikind (l_ik, x) - - let of_excl_list t l = - let r = size t in (* elements in l are excluded from the full range of t! *) - `Excluded (List.fold_right S.add l (S.empty ()), r) - let is_excl_list l = match l with `Excluded _ -> true | _ -> false - let to_excl_list (x:t) = match x with - | `Definite _ -> None - | `Excluded (s,r) -> Some (S.elements s, (Option.get (R.minimal r), Option.get (R.maximal r))) - | `Bot -> None - - let to_incl_list x = match x with - | `Definite x -> Some [x] - | `Excluded _ -> None - | `Bot -> None - - let apply_range f r = (* apply f to the min/max of the old range r to get a new range *) - (* If the Int64 might overflow on us during computation, we instead go to top_range *) - match R.minimal r, R.maximal r with - | _ -> - let rf m = (size % Size.min_for % f) (m r) in - let r1, r2 = rf Exclusion.min_of_range, rf Exclusion.max_of_range in - R.join r1 r2 - - (* Default behaviour for unary operators, simply maps the function to the - * DefExc data structure. *) - let lift1 f ik x = norm ik @@ match x with - | `Excluded (s,r) -> - let s' = S.map f s in - `Excluded (s', apply_range f r) - | `Definite x -> `Definite (f x) - | `Bot -> `Bot - - let lift2 f ik x y = norm ik (match x,y with - (* We don't bother with exclusion sets: *) - | `Excluded _, `Definite _ - | `Definite _, `Excluded _ - | `Excluded _, `Excluded _ -> top () - (* The good case: *) - | `Definite x, `Definite y -> - (try `Definite (f x y) with | Division_by_zero -> top ()) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y)))) - - (* Default behaviour for binary operators that are injective in either - * argument, so that Exclusion Sets can be used: *) - let lift2_inj f ik x y = - let def_exc f x s r = `Excluded (S.map (f x) s, apply_range (f x) r) in - norm ik @@ - match x,y with - (* If both are exclusion sets, there isn't anything we can do: *) - | `Excluded _, `Excluded _ -> top () - (* A definite value should be applied to all members of the exclusion set *) - | `Definite x, `Excluded (s,r) -> def_exc f x s r - (* Same thing here, but we should flip the operator to map it properly *) - | `Excluded (s,r), `Definite x -> def_exc (Batteries.flip f) x s r - (* The good case: *) - | `Definite x, `Definite y -> `Definite (f x y) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - - (* The equality check: *) - let eq ik x y = match x,y with - (* Not much to do with two exclusion sets: *) - | `Excluded _, `Excluded _ -> top () - (* Is x equal to an exclusion set, if it is a member then NO otherwise we - * don't know: *) - | `Definite x, `Excluded (s,r) -> if S.mem x s then of_bool IInt false else top () - | `Excluded (s,r), `Definite x -> if S.mem x s then of_bool IInt false else top () - (* The good case: *) - | `Definite x, `Definite y -> of_bool IInt (x = y) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - - (* The inequality check: *) - let ne ik x y = match x,y with - (* Not much to do with two exclusion sets: *) - | `Excluded _, `Excluded _ -> top () - (* Is x unequal to an exclusion set, if it is a member then Yes otherwise we - * don't know: *) - | `Definite x, `Excluded (s,r) -> if S.mem x s then of_bool IInt true else top () - | `Excluded (s,r), `Definite x -> if S.mem x s then of_bool IInt true else top () - (* The good case: *) - | `Definite x, `Definite y -> of_bool IInt (x <> y) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - - let neg ?no_ov ik (x :t) = norm ik @@ lift1 Z.neg ik x - let add ?no_ov ik x y = norm ik @@ lift2_inj Z.add ik x y - - let sub ?no_ov ik x y = norm ik @@ lift2_inj Z.sub ik x y - let mul ?no_ov ik x y = norm ik @@ match x, y with - | `Definite z, (`Excluded _ | `Definite _) when Z.equal z Z.zero -> x - | (`Excluded _ | `Definite _), `Definite z when Z.equal z Z.zero -> y - | `Definite a, `Excluded (s,r) - (* Integer multiplication with even numbers is not injective. *) - (* Thus we cannot exclude the values to which the exclusion set would be mapped to. *) - | `Excluded (s,r),`Definite a when Z.equal (Z.rem a (Z.of_int 2)) Z.zero -> `Excluded (S.empty (), apply_range (Z.mul a) r) - | _ -> lift2_inj Z.mul ik x y - let div ?no_ov ik x y = lift2 Z.div ik x y - let rem ik x y = lift2 Z.rem ik x y - - (* Comparison handling copied from Enums. *) - let handle_bot x y f = match x, y with - | `Bot, `Bot -> `Bot - | `Bot, _ - | _, `Bot -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | _, _ -> f () - - let lt ik x y = - handle_bot x y (fun () -> - match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when Z.compare x2 y1 < 0 -> of_bool ik true - | Some x1, _, _, Some y2 when Z.compare x1 y2 >= 0 -> of_bool ik false - | _, _, _, _ -> top_bool) - - let gt ik x y = lt ik y x - - let le ik x y = - handle_bot x y (fun () -> - match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when Z.compare x2 y1 <= 0 -> of_bool ik true - | Some x1, _, _, Some y2 when Z.compare x1 y2 > 0 -> of_bool ik false - | _, _, _, _ -> top_bool) - - let ge ik x y = le ik y x - - let lognot = lift1 Z.lognot - - let logand ik x y = norm ik (match x,y with - (* We don't bother with exclusion sets: *) - | `Excluded _, `Definite i -> - (* Except in two special cases *) - if Z.equal i Z.zero then - `Definite Z.zero - else if Z.equal i Z.one then - of_interval IBool (Z.zero, Z.one) - else - top () - | `Definite _, `Excluded _ - | `Excluded _, `Excluded _ -> top () - (* The good case: *) - | `Definite x, `Definite y -> - (try `Definite (Z.logand x y) with | Division_by_zero -> top ()) - | `Bot, `Bot -> `Bot - | _ -> - (* If only one of them is bottom, we raise an exception that eval_rv will catch *) - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y)))) - - - let logor = lift2 Z.logor - let logxor = lift2 Z.logxor - - let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = - (* BigInt only accepts int as second argument for shifts; perform conversion here *) - let shift_op_big_int a (b: int_t) = - let (b : int) = Z.to_int b in - shift_op a b - in - (* If one of the parameters of the shift is negative, the result is undefined *) - let is_negative = GobOption.for_all (fun x -> Z.lt x Z.zero) in - if is_negative (minimal x) || is_negative (minimal y) then - top_of ik - else - norm ik @@ lift2 shift_op_big_int ik x y - - let shift_left = - shift Z.shift_left - - let shift_right = - shift Z.shift_right - (* TODO: lift does not treat Not {0} as true. *) - let c_logand ik x y = - match to_bool x, to_bool y with - | Some false, _ - | _, Some false -> - of_bool ik false - | _, _ -> - lift2 IntOps.BigIntOps.c_logand ik x y - let c_logor ik x y = - match to_bool x, to_bool y with - | Some true, _ - | _, Some true -> - of_bool ik true - | _, _ -> - lift2 IntOps.BigIntOps.c_logor ik x y - let c_lognot ik = eq ik (of_int ik Z.zero) - - let invariant_ikind e ik (x:t) = - match x with - | `Definite x -> - IntInvariant.of_int e ik x - | `Excluded (s, r) -> - (* Emit range invariant if tighter than ikind bounds. - This can be more precise than interval, which has been widened. *) - let (rmin, rmax) = (Exclusion.min_of_range r, Exclusion.max_of_range r) in - let ri = IntInvariant.of_interval e ik (rmin, rmax) in - let si = IntInvariant.of_excl_list e ik (S.elements s) in - Invariant.(ri && si) - | `Bot -> Invariant.none - - let arbitrary ik = - let open QCheck.Iter in - let excluded s = from_excl ik s in - let definite x = of_int ik x in - let shrink = function - | `Excluded (s, _) -> GobQCheck.shrink (S.arbitrary ()) s >|= excluded (* S TODO: possibly shrink excluded to definite *) - | `Definite x -> (return `Bot) <+> (GobQCheck.shrink (IntOps.BigIntOps.arbitrary ()) x >|= definite) - | `Bot -> empty - in - QCheck.frequency ~shrink ~print:show [ - 20, QCheck.map excluded (S.arbitrary ()); - 10, QCheck.map definite (IntOps.BigIntOps.arbitrary ()); - 1, QCheck.always `Bot - ] (* S TODO: decide frequencies *) - - let refine_with_congruence ik a b = a - let refine_with_interval ik a b = match a, b with - | x, Some(i) -> meet ik x (of_interval ik i) - | _ -> a - let refine_with_excl_list ik a b = match a, b with - | `Excluded (s, r), Some(ls, _) -> meet ik (`Excluded (s, r)) (of_excl_list ik ls) (* TODO: refine with excl range? *) - | _ -> a - let refine_with_incl_list ik a b = a - - let project ik p t = t -end - -(* Inclusion/Exclusion sets. Go to top on arithmetic operations (except for some easy cases, e.g. multiplication with 0). Joins on widen, i.e. precise integers as long as not derived from arithmetic expressions. *) -module Enums : S with type int_t = Z.t = struct - module R = Interval32 (* range for exclusion *) - - let range_ikind = Cil.IInt - let size t = R.of_interval range_ikind (let a,b = Size.bits_i64 t in Int64.neg a,b) - - type t = Inc of BISet.t | Exc of BISet.t * R.t [@@deriving eq, ord, hash] (* inclusion/exclusion set *) - - type int_t = Z.t - let name () = "enums" - let bot () = failwith "bot () not implemented for Enums" - let top () = failwith "top () not implemented for Enums" - let bot_of ik = Inc (BISet.empty ()) - let top_bool = Inc (BISet.of_list [Z.zero; Z.one]) - let top_of ik = - match ik with - | IBool -> top_bool - | _ -> Exc (BISet.empty (), size ik) - - let range ik = Size.range ik - -(* - let max_of_range r = Size.max_from_bit_range (Option.get (R.maximal r)) - let min_of_range r = Size.min_from_bit_range (Option.get (R.minimal r)) - let cardinality_of_range r = Z.add (Z.neg (min_of_range r)) (max_of_range r) *) - let value_in_range (min, max) v = Z.compare min v <= 0 && Z.compare v max <= 0 - - let show = function - | Inc xs when BISet.is_empty xs -> "bot" - | Inc xs -> "{" ^ (String.concat ", " (List.map Z.to_string (BISet.elements xs))) ^ "}" - | Exc (xs,r) -> "not {" ^ (String.concat ", " (List.map Z.to_string (BISet.elements xs))) ^ "} " ^ "("^R.show r^")" - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - (* Normalization function for enums, that handles overflows for Inc. - As we do not compute on Excl, we do not have to perform any overflow handling for it. *) - let norm ikind v = - let min, max = range ikind in - (* Whether the value v lies within the values of the specified ikind. *) - let value_in_ikind v = - Z.compare min v <= 0 && Z.compare v max <= 0 - in - match v with - | Inc xs when BISet.for_all value_in_ikind xs -> v - | Inc xs -> - if should_wrap ikind then - Inc (BISet.map (Size.cast ikind) xs) - else if should_ignore_overflow ikind then - Inc (BISet.filter value_in_ikind xs) - else - top_of ikind - | Exc (xs, r) -> - (* The following assert should hold for Exc, therefore we do not have to overflow handling / normalization for it: - let range_in_ikind r = - R.leq r (size ikind) - in - let r_min, r_max = min_of_range r, max_of_range r in - assert (range_in_ikind r && BISet.for_all (value_in_range (r_min, r_max)) xs); *) - begin match ikind with - | IBool -> - begin match BISet.mem Z.zero xs, BISet.mem Z.one xs with - | false, false -> top_bool (* Not {} -> {0, 1} *) - | true, false -> Inc (BISet.singleton Z.one) (* Not {0} -> {1} *) - | false, true -> Inc (BISet.singleton Z.zero) (* Not {1} -> {0} *) - | true, true -> bot_of ikind (* Not {0, 1} -> bot *) - end - | _ -> - v - end - - - let equal_to i = function - | Inc x -> - if BISet.mem i x then - if BISet.is_singleton x then `Eq - else `Top - else `Neq - | Exc (x, r) -> - if BISet.mem i x then `Neq - else `Top - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov ik v = norm ik @@ match v with - | Exc (s,r) -> - let r' = size ik in - if R.leq r r' then (* upcast -> no change *) - Exc (s, r) - else if ik = IBool then (* downcast to bool *) - if BISet.mem Z.zero s then - Inc (BISet.singleton Z.one) - else - Exc (BISet.empty(), r') - else (* downcast: may overflow *) - Exc ((BISet.empty ()), r') - | Inc xs -> - let casted_xs = BISet.map (Size.cast ik) xs in - if Cil.isSigned ik && not (BISet.equal xs casted_xs) - then top_of ik (* When casting into a signed type and the result does not fit, the behavior is implementation-defined *) - else Inc casted_xs - - let of_int ikind x = cast_to ikind (Inc (BISet.singleton x)) - - let of_interval ?(suppress_ovwarn=false) ik (x, y) = - if Z.compare x y = 0 then - of_int ik x - else - let a, b = Size.min_range_sign_agnostic x, Size.min_range_sign_agnostic y in - let r = R.join (R.of_interval ~suppress_ovwarn range_ikind a) (R.of_interval ~suppress_ovwarn range_ikind b) in - let ex = if Z.gt x Z.zero || Z.lt y Z.zero then BISet.singleton Z.zero else BISet.empty () in - norm ik @@ (Exc (ex, r)) - - let join _ x y = - match x, y with - | Inc x, Inc y -> Inc (BISet.union x y) - | Exc (x,r1), Exc (y,r2) -> Exc (BISet.inter x y, R.join r1 r2) - | Exc (x,r), Inc y - | Inc y, Exc (x,r) -> - let r = if BISet.is_empty y - then r - else - let (min_el_range, max_el_range) = Batteries.Tuple2.mapn (fun x -> R.of_interval range_ikind (Size.min_range_sign_agnostic x)) (BISet.min_elt y, BISet.max_elt y) in - let range = R.join min_el_range max_el_range in - R.join r range - in - Exc (BISet.diff x y, r) - - let meet _ x y = - match x, y with - | Inc x, Inc y -> Inc (BISet.inter x y) - | Exc (x,r1), Exc (y,r2) -> - let r = R.meet r1 r2 in - let r_min, r_max = Exclusion.min_of_range r, Exclusion.max_of_range r in - let filter_by_range = BISet.filter (value_in_range (r_min, r_max)) in - (* We remove those elements from the exclusion set that do not fit in the range anyway *) - let excl = BISet.union (filter_by_range x) (filter_by_range y) in - Exc (excl, r) - | Inc x, Exc (y,r) - | Exc (y,r), Inc x -> Inc (BISet.diff x y) - - let widen = join - let narrow = meet - let leq a b = - match a, b with - | Inc xs, Exc (ys, r) -> - if BISet.is_empty xs - then true - else - let min_b, max_b = Exclusion.min_of_range r, Exclusion.max_of_range r in - let min_a, max_a = BISet.min_elt xs, BISet.max_elt xs in - (* Check that the xs fit into the range r *) - Z.compare min_b min_a <= 0 && Z.compare max_a max_b <= 0 && - (* && check that none of the values contained in xs is excluded, i.e. contained in ys. *) - BISet.for_all (fun x -> not (BISet.mem x ys)) xs - | Inc xs, Inc ys -> - BISet.subset xs ys - | Exc (xs, r), Exc (ys, s) -> - Exclusion.(leq (Exc (xs, r)) (Exc (ys, s))) - | Exc (xs, r), Inc ys -> - Exclusion.(leq_excl_incl (Exc (xs, r)) (Inc ys)) - - let handle_bot x y f = match is_bot x, is_bot y with - | false, false -> f () - | true, false - | false, true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | true, true -> Inc (BISet.empty ()) - - let lift1 f ikind v = norm ikind @@ match v with - | Inc x when BISet.is_empty x -> v (* Return bottom when value is bottom *) - | Inc x when BISet.is_singleton x -> Inc (BISet.singleton (f (BISet.choose x))) - | _ -> top_of ikind - - let lift2 f (ikind: Cil.ikind) u v = - handle_bot u v (fun () -> - norm ikind @@ match u, v with - | Inc x,Inc y when BISet.is_singleton x && BISet.is_singleton y -> Inc (BISet.singleton (f (BISet.choose x) (BISet.choose y))) - | _,_ -> top_of ikind) - - let lift2 f ikind a b = - try lift2 f ikind a b with Division_by_zero -> top_of ikind - - let neg ?no_ov = lift1 Z.neg - let add ?no_ov ikind a b = - match a, b with - | Inc z,x when BISet.is_singleton z && BISet.choose z = Z.zero -> x - | x,Inc z when BISet.is_singleton z && BISet.choose z = Z.zero -> x - | x,y -> lift2 Z.add ikind x y - let sub ?no_ov = lift2 Z.sub - let mul ?no_ov ikind a b = - match a, b with - | Inc one,x when BISet.is_singleton one && BISet.choose one = Z.one -> x - | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x - | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a - | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> b - | x,y -> lift2 Z.mul ikind x y - - let div ?no_ov ikind a b = match a, b with - | x,Inc one when BISet.is_singleton one && BISet.choose one = Z.one -> x - | _,Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> top_of ikind - | Inc zero,_ when BISet.is_singleton zero && BISet.choose zero = Z.zero -> a - | x,y -> lift2 Z.div ikind x y - - let rem = lift2 Z.rem - - let lognot = lift1 Z.lognot - let logand = lift2 Z.logand - let logor = lift2 Z.logor - let logxor = lift2 Z.logxor - - let shift (shift_op: int_t -> int -> int_t) (ik: Cil.ikind) (x: t) (y: t) = - handle_bot x y (fun () -> - (* BigInt only accepts int as second argument for shifts; perform conversion here *) - let shift_op_big_int a (b: int_t) = - let (b : int) = Z.to_int b in - shift_op a b - in - (* If one of the parameters of the shift is negative, the result is undefined *) - let is_negative = GobOption.for_all (fun x -> Z.lt x Z.zero) in - if is_negative (minimal x) || is_negative (minimal y) then - top_of ik - else - lift2 shift_op_big_int ik x y) - - let shift_left = - shift Z.shift_left - - let shift_right = - shift Z.shift_right - - let of_bool ikind x = Inc (BISet.singleton (if x then Z.one else Z.zero)) - let to_bool = function - | Inc e when BISet.is_empty e -> None - | Exc (e,_) when BISet.is_empty e -> None - | Inc zero when BISet.is_singleton zero && BISet.choose zero = Z.zero -> Some false - | Inc xs when BISet.for_all ((<>) Z.zero) xs -> Some true - | Exc (xs,_) when BISet.exists ((=) Z.zero) xs -> Some true - | _ -> None - let to_int = function Inc x when BISet.is_singleton x -> Some (BISet.choose x) | _ -> None - - let to_excl_list = function Exc (x,r) when not (BISet.is_empty x) -> Some (BISet.elements x, (Option.get (R.minimal r), Option.get (R.maximal r))) | _ -> None - let of_excl_list ik xs = - let min_ik, max_ik = Size.range ik in - let exc = BISet.of_list @@ List.filter (value_in_range (min_ik, max_ik)) xs in - norm ik @@ Exc (exc, size ik) - let is_excl_list = BatOption.is_some % to_excl_list - let to_incl_list = function Inc s when not (BISet.is_empty s) -> Some (BISet.elements s) | _ -> None - - let starting ?(suppress_ovwarn=false) ikind x = - let _,u_ik = Size.range ikind in - of_interval ~suppress_ovwarn ikind (x, u_ik) - - let ending ?(suppress_ovwarn=false) ikind x = - let l_ik,_ = Size.range ikind in - of_interval ~suppress_ovwarn ikind (l_ik, x) - - let c_lognot ik x = - if is_bot x - then x - else - match to_bool x with - | Some b -> of_bool ik (not b) - | None -> top_bool - - let c_logand = lift2 IntOps.BigIntOps.c_logand - let c_logor = lift2 IntOps.BigIntOps.c_logor - let maximal = function - | Inc xs when not (BISet.is_empty xs) -> Some (BISet.max_elt xs) - | Exc (excl,r) -> - let rec decrement_while_contained v = - if BISet.mem v excl - then decrement_while_contained (Z.pred v) - else v - in - let range_max = Exclusion.max_of_range r in - Some (decrement_while_contained range_max) - | _ (* bottom case *) -> None - - let minimal = function - | Inc xs when not (BISet.is_empty xs) -> Some (BISet.min_elt xs) - | Exc (excl,r) -> - let rec increment_while_contained v = - if BISet.mem v excl - then increment_while_contained (Z.succ v) - else v - in - let range_min = Exclusion.min_of_range r in - Some (increment_while_contained range_min) - | _ (* bottom case *) -> None - - let lt ik x y = - handle_bot x y (fun () -> - match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when Z.compare x2 y1 < 0 -> of_bool ik true - | Some x1, _, _, Some y2 when Z.compare x1 y2 >= 0 -> of_bool ik false - | _, _, _, _ -> top_bool) - - let gt ik x y = lt ik y x - - let le ik x y = - handle_bot x y (fun () -> - match minimal x, maximal x, minimal y, maximal y with - | _, Some x2, Some y1, _ when Z.compare x2 y1 <= 0 -> of_bool ik true - | Some x1, _, _, Some y2 when Z.compare x1 y2 > 0 -> of_bool ik false - | _, _, _, _ -> top_bool) - - let ge ik x y = le ik y x - - let eq ik x y = - handle_bot x y (fun () -> - match x, y with - | Inc xs, Inc ys when BISet.is_singleton xs && BISet.is_singleton ys -> of_bool ik (Z.equal (BISet.choose xs) (BISet.choose ys)) - | _, _ -> - if is_bot (meet ik x y) then - (* If the meet is empty, there is no chance that concrete values are equal *) - of_bool ik false - else - top_bool) - - let ne ik x y = c_lognot ik (eq ik x y) - - let invariant_ikind e ik x = - match x with - | Inc ps -> - IntInvariant.of_incl_list e ik (BISet.elements ps) - | Exc (ns, r) -> - (* Emit range invariant if tighter than ikind bounds. - This can be more precise than interval, which has been widened. *) - let (rmin, rmax) = (Exclusion.min_of_range r, Exclusion.max_of_range r) in - let ri = IntInvariant.of_interval e ik (rmin, rmax) in - let nsi = IntInvariant.of_excl_list e ik (BISet.elements ns) in - Invariant.(ri && nsi) - - - let arbitrary ik = - let open QCheck.Iter in - let neg s = of_excl_list ik (BISet.elements s) in - let pos s = norm ik (Inc s) in - let shrink = function - | Exc (s, _) -> GobQCheck.shrink (BISet.arbitrary ()) s >|= neg (* S TODO: possibly shrink neg to pos *) - | Inc s -> GobQCheck.shrink (BISet.arbitrary ()) s >|= pos - in - QCheck.frequency ~shrink ~print:show [ - 20, QCheck.map neg (BISet.arbitrary ()); - 10, QCheck.map pos (BISet.arbitrary ()); - ] (* S TODO: decide frequencies *) - - let refine_with_congruence ik a b = - let contains c m x = if Z.equal m Z.zero then Z.equal c x else Z.equal (Z.rem (Z.sub x c) m) Z.zero in - match a, b with - | Inc e, None -> bot_of ik - | Inc e, Some (c, m) -> Inc (BISet.filter (contains c m) e) - | _ -> a - - let refine_with_interval ik a b = a (* TODO: refine inclusion (exclusion?) set *) - - let refine_with_excl_list ik a b = - match b with - | Some (ls, _) -> meet ik a (of_excl_list ik ls) (* TODO: refine with excl range? *) - | _ -> a - - let refine_with_incl_list ik a b = - match a, b with - | Inc x, Some (ls) -> meet ik (Inc x) (Inc (BISet.of_list ls)) - | _ -> a - - let project ik p t = t -end - -module Congruence : S with type int_t = Z.t and type t = (Z.t * Z.t) option = -struct - let name () = "congruences" - type int_t = Z.t - - (* represents congruence class of c mod m, None is bot *) - type t = (Z.t * Z.t) option [@@deriving eq, ord, hash] - - let ( *: ) = Z.mul - let (+:) = Z.add - let (-:) = Z.sub - let (%:) = Z.rem - let (/:) = Z.div - let (=:) = Z.equal - let (<:) x y = Z.compare x y < 0 - let (>:) x y = Z.compare x y > 0 - let (<=:) x y = Z.compare x y <= 0 - let (>=:) x y = Z.compare x y >= 0 - (* a divides b *) - let ( |: ) a b = - if a =: Z.zero then false else (b %: a) =: Z.zero - - let normalize ik x = - match x with - | None -> None - | Some (c, m) -> - if m =: Z.zero then - if should_wrap ik then - Some (Size.cast ik c, m) - else - Some (c, m) - else - let m' = Z.abs m in - let c' = c %: m' in - if c' <: Z.zero then - Some (c' +: m', m') - else - Some (c' %: m', m') - - let range ik = Size.range ik - - let top () = Some (Z.zero, Z.one) - let top_of ik = Some (Z.zero, Z.one) - let bot () = None - let bot_of ik = bot () - - let show = function ik -> match ik with - | None -> "⟂" - | Some (c, m) when (c, m) = (Z.zero, Z.zero) -> Z.to_string c - | Some (c, m) -> - let a = if c =: Z.zero then "" else Z.to_string c in - let b = if m =: Z.zero then "" else if m = Z.one then "ℤ" else Z.to_string m^"ℤ" in - let c = if a = "" || b = "" then "" else "+" in - a^c^b - - include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) - - let is_top x = x = top () - - let equal_to i = function - | None -> failwith "unsupported: equal_to with bottom" - | Some (a, b) when b =: Z.zero -> if a =: i then `Eq else `Neq - | Some (a, b) -> if i %: b =: a then `Top else `Neq - - let leq (x:t) (y:t) = - match x, y with - | None, _ -> true - | Some _, None -> false - | Some (c1,m1), Some (c2,m2) when m2 =: Z.zero && m1 =: Z.zero -> c1 =: c2 - | Some (c1,m1), Some (c2,m2) when m2 =: Z.zero -> c1 =: c2 && m1 =: Z.zero - | Some (c1,m1), Some (c2,m2) -> m2 |: Z.gcd (c1 -: c2) m1 - (* Typo in original equation of P. Granger (m2 instead of m1): gcd (c1 -: c2) m2 - Reference: https://doi.org/10.1080/00207168908803778 Page 171 corollary 3.3*) - - let leq x y = - let res = leq x y in - if M.tracing then M.trace "congruence" "leq %a %a -> %a " pretty x pretty y pretty (Some (Z.of_int (Bool.to_int res), Z.zero)) ; - res - - let join ik (x:t) y = - match x, y with - | None, z | z, None -> z - | Some (c1,m1), Some (c2,m2) -> - let m3 = Z.gcd m1 (Z.gcd m2 (c1 -: c2)) in - normalize ik (Some (c1, m3)) - - let join ik (x:t) y = - let res = join ik x y in - if M.tracing then M.trace "congruence" "join %a %a -> %a" pretty x pretty y pretty res; - res - - - let meet ik x y = - (* if it exists, c2/a2 is solution to a*x ≡ c (mod m) *) - let congruence_series a c m = - let rec next a1 c1 a2 c2 = - if a2 |: a1 then (a2, c2) - else next a2 c2 (a1 %: a2) (c1 -: (c2 *: (a1 /: a2))) - in next m Z.zero a c - in - let simple_case i c m = - if m |: (i -: c) - then Some (i, Z.zero) else None - in - match x, y with - | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero -> if c1 =: c2 then Some (c1, Z.zero) else None - | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero -> simple_case c1 c2 m2 - | Some (c1, m1), Some (c2, m2) when m2 =: Z.zero -> simple_case c2 c1 m1 - | Some (c1, m1), Some (c2, m2) when (Z.gcd m1 m2) |: (c1 -: c2) -> - let (c, m) = congruence_series m1 (c2 -: c1 ) m2 in - normalize ik (Some(c1 +: (m1 *: (m /: c)), m1 *: (m2 /: c))) - | _ -> None - - let meet ik x y = - let res = meet ik x y in - if M.tracing then M.trace "congruence" "meet %a %a -> %a" pretty x pretty y pretty res; - res - - let to_int = function Some (c, m) when m =: Z.zero -> Some c | _ -> None - let of_int ik (x: int_t) = normalize ik @@ Some (x, Z.zero) - let zero = Some (Z.zero, Z.zero) - let one = Some (Z.one, Z.zero) - let top_bool = top() - - let of_bool _ik = function true -> one | false -> zero - - let to_bool (a: t) = match a with - | None -> None - | x when equal zero x -> Some false - | x -> if leq zero x then None else Some true - - let starting ?(suppress_ovwarn=false) ik n = top() - - let ending = starting - - let of_congruence ik (c,m) = normalize ik @@ Some(c,m) - - let maximal t = match t with - | Some (x, y) when y =: Z.zero -> Some x - | _ -> None - - let minimal t = match t with - | Some (x,y) when y =: Z.zero -> Some x - | _ -> None - - (* cast from original type to ikind, set to top if the value doesn't fit into the new type *) - let cast_to ?(suppress_ovwarn=false) ?torg ?(no_ov=false) t x = - match x with - | None -> None - | Some (c, m) when m =: Z.zero -> - let c' = Size.cast t c in - (* When casting into a signed type and the result does not fit, the behavior is implementation-defined. (C90 6.2.1.2, C99 and C11 6.3.1.3) *) - (* We go with GCC behavior here: *) - (* For conversion to a type of width N, the value is reduced modulo 2^N to be within range of the type; no signal is raised. *) - (* (https://gcc.gnu.org/onlinedocs/gcc/Integers-implementation.html) *) - (* Clang behaves the same but they never document that anywhere *) - Some (c', m) - | _ -> - let (min_t, max_t) = range t in - let p ikorg = - let (min_ikorg, max_ikorg) = range ikorg in - ikorg = t || (max_t >=: max_ikorg && min_t <=: min_ikorg) - in - match torg with - | Some (Cil.TInt (ikorg, _)) when p ikorg -> - if M.tracing then M.trace "cong-cast" "some case"; - x - | _ -> top () - - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov (t : Cil.ikind) x = - let pretty_bool _ x = Pretty.text (string_of_bool x) in - let res = cast_to ?torg ?no_ov t x in - if M.tracing then M.trace "cong-cast" "Cast %a to %a (no_ov: %a) = %a" pretty x Cil.d_ikind t (Pretty.docOpt (pretty_bool ())) no_ov pretty res; - res - - let widen = join - - let widen ik x y = - let res = widen ik x y in - if M.tracing then M.trace "congruence" "widen %a %a -> %a" pretty x pretty y pretty res; - res - - let narrow = meet - - let log f ik i1 i2 = - match is_bot i1, is_bot i2 with - | true, true -> bot_of ik - | true, _ - | _ , true -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show i1) (show i2))) - | _ -> - match to_bool i1, to_bool i2 with - | Some x, Some y -> of_bool ik (f x y) - | _ -> top_of ik - - let c_logor = log (||) - let c_logand = log (&&) - - let log1 f ik i1 = - if is_bot i1 then - bot_of ik - else - match to_bool i1 with - | Some x -> of_bool ik (f ik x) - | _ -> top_of ik - - let c_lognot = log1 (fun _ik -> not) - - let shift_right _ _ _ = top() - - let shift_right ik x y = - let res = shift_right ik x y in - if M.tracing then M.trace "congruence" "shift_right : %a %a becomes %a " pretty x pretty y pretty res; - res - - let shift_left ik x y = - (* Naive primality test *) - (* let is_prime n = - let n = Z.abs n in - let rec is_prime' d = - (d *: d >: n) || ((not ((n %: d) =: Z.zero)) && (is_prime' [@tailcall]) (d +: Z.one)) - in - not (n =: Z.one) && is_prime' (Z.of_int 2) - in *) - match x, y with - | None, None -> None - | None, _ - | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c, m), Some (c', m') when Cil.isSigned ik || c <: Z.zero || c' <: Z.zero -> top_of ik - | Some (c, m), Some (c', m') -> - let (_, max_ik) = range ik in - if m =: Z.zero && m' =: Z.zero then - normalize ik @@ Some (Z.logand max_ik (Z.shift_left c (Z.to_int c')), Z.zero) - else - let x = Z.logand max_ik (Z.shift_left Z.one (Z.to_int c')) in (* 2^c' *) - (* TODO: commented out because fails test with _Bool *) - (* if is_prime (m' +: Z.one) then - normalize ik @@ Some (x *: c, Z.gcd (x *: m) ((c *: x) *: (m' +: Z.one))) - else *) - normalize ik @@ Some (x *: c, Z.gcd (x *: m) (c *: x)) - - let shift_left ik x y = - let res = shift_left ik x y in - if M.tracing then M.trace "congruence" "shift_left : %a %a becomes %a " pretty x pretty y pretty res; - res - - (* Handle unsigned overflows. - From n === k mod (2^a * b), we conclude n === k mod 2^a, for a <= bitwidth. - The congruence modulo b may not persist on an overflow. *) - let handle_overflow ik (c, m) = - if m =: Z.zero then - normalize ik (Some (c, m)) - else - (* Find largest m'=2^k (for some k) such that m is divisible by m' *) - let tz = Z.trailing_zeros m in - let m' = Z.shift_left Z.one tz in - - let max = (snd (Size.range ik)) +: Z.one in - if m' >=: max then - (* if m' >= 2 ^ {bitlength}, there is only one value in range *) - let c' = c %: max in - Some (c', Z.zero) - else - normalize ik (Some (c, m')) - - let mul ?(no_ov=false) ik x y = - let no_ov_case (c1, m1) (c2, m2) = - c1 *: c2, Z.gcd (c1 *: m2) (Z.gcd (m1 *: c2) (m1 *: m2)) - in - match x, y with - | None, None -> bot () - | None, _ | _, None -> - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c1, m1), Some (c2, m2) when no_ov -> - Some (no_ov_case (c1, m1) (c2, m2)) - | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero && not (Cil.isSigned ik) -> - let (_, max_ik) = range ik in - Some ((c1 *: c2) %: (max_ik +: Z.one), Z.zero) - | Some a, Some b when not (Cil.isSigned ik) -> - handle_overflow ik (no_ov_case a b ) - | _ -> top () - - let mul ?no_ov ik x y = - let res = mul ?no_ov ik x y in - if M.tracing then M.trace "congruence" "mul : %a %a -> %a " pretty x pretty y pretty res; - res - - let neg ?(no_ov=false) ik x = - match x with - | None -> bot() - | Some _ -> mul ~no_ov ik (of_int ik (Z.of_int (-1))) x - - let add ?(no_ov=false) ik x y = - let no_ov_case (c1, m1) (c2, m2) = - c1 +: c2, Z.gcd m1 m2 - in - match (x, y) with - | None, None -> bot () - | None, _ | _, None -> - raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some a, Some b when no_ov -> - normalize ik (Some (no_ov_case a b)) - | Some (c1, m1), Some (c2, m2) when m1 =: Z.zero && m2 =: Z.zero && not (Cil.isSigned ik) -> - let (_, max_ik) = range ik in - Some((c1 +: c2) %: (max_ik +: Z.one), Z.zero) - | Some a, Some b when not (Cil.isSigned ik) -> - handle_overflow ik (no_ov_case a b) - | _ -> top () - - - let add ?no_ov ik x y = - let res = add ?no_ov ik x y in - if M.tracing then - M.trace "congruence" "add : %a %a -> %a" pretty x pretty y - pretty res ; - res - - let sub ?(no_ov=false) ik x y = add ~no_ov ik x (neg ~no_ov ik y) - - - let sub ?no_ov ik x y = - let res = sub ?no_ov ik x y in - if M.tracing then - M.trace "congruence" "sub : %a %a -> %a" pretty x pretty y - pretty res ; - res - - let lognot ik x = match x with - | None -> None - | Some (c, m) -> - if (Cil.isSigned ik) then - sub ik (neg ik x) one - else - let (_, max_ik) = range ik in - Some (Z.sub max_ik c, m) - - (** The implementation of the bit operations could be improved based on the master’s thesis - 'Abstract Interpretation and Abstract Domains' written by Stefan Bygde. - see: http://www.es.mdh.se/pdf_publications/948.pdf *) - let bit2 f ik x y = match x, y with - | None, None -> None - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c, m), Some (c', m') -> - if m =: Z.zero && m' =: Z.zero then Some (f c c', Z.zero) - else top () - - let logor ik x y = bit2 Z.logor ik x y - - let logand ik x y = match x, y with - | None, None -> None - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c, m), Some (c', m') -> - if m =: Z.zero && m' =: Z.zero then - (* both arguments constant *) - Some (Z.logand c c', Z.zero) - else if m' =: Z.zero && c' =: Z.one && Z.rem m (Z.of_int 2) =: Z.zero then - (* x & 1 and x == c (mod 2*z) *) - (* Value is equal to LSB of c *) - Some (Z.logand c c', Z.zero) - else - top () - - let logxor ik x y = bit2 Z.logxor ik x y - - let rem ik x y = - match x, y with - | None, None -> bot() - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c1, m1), Some(c2, m2) -> - if m2 =: Z.zero then - if (c2 |: m1) && (c1 %: c2 =: Z.zero || m1 =: Z.zero || not (Cil.isSigned ik)) then - Some (c1 %: c2, Z.zero) - else - normalize ik (Some (c1, (Z.gcd m1 c2))) - else - normalize ik (Some (c1, Z.gcd m1 (Z.gcd c2 m2))) - - let rem ik x y = let res = rem ik x y in - if M.tracing then M.trace "congruence" "rem : %a %a -> %a " pretty x pretty y pretty res; - res - - let div ?(no_ov=false) ik x y = - match x,y with - | None, None -> bot () - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | _, x when leq zero x -> top () - | Some(c1, m1), Some(c2, m2) when not no_ov && m2 =: Z.zero && c2 =: Z.neg Z.one -> top () - | Some(c1, m1), Some(c2, m2) when m1 =: Z.zero && m2 =: Z.zero -> Some (c1 /: c2, Z.zero) - | Some(c1, m1), Some(c2, m2) when m2 =: Z.zero && c2 |: m1 && c2 |: c1 -> Some (c1 /: c2, m1 /: c2) - | _, _ -> top () - - - let div ?no_ov ik x y = - let res = div ?no_ov ik x y in - if M.tracing then - M.trace "congruence" "div : %a %a -> %a" pretty x pretty y pretty - res ; - res - - let ne ik (x: t) (y: t) = match x, y with - | Some (c1, m1), Some (c2, m2) when (m1 =: Z.zero) && (m2 =: Z.zero) -> of_bool ik (not (c1 =: c2 )) - | x, y -> if meet ik x y = None then of_bool ik true else top_bool - - let eq ik (x: t) (y: t) = match x, y with - | Some (c1, m1), Some (c2, m2) when (m1 =: Z.zero) && (m2 =: Z.zero) -> of_bool ik (c1 =: c2) - | x, y -> if meet ik x y <> None then top_bool else of_bool ik false - - let comparison ik op x y = match x, y with - | None, None -> bot_of ik - | None, _ | _, None -> raise (ArithmeticOnIntegerBot (Printf.sprintf "%s op %s" (show x) (show y))) - | Some (c1, m1), Some (c2, m2) -> - if m1 =: Z.zero && m2 =: Z.zero then - if op c1 c2 then of_bool ik true else of_bool ik false - else - top_bool - - let ge ik x y = comparison ik (>=:) x y - - let ge ik x y = - let res = ge ik x y in - if M.tracing then M.trace "congruence" "greater or equal : %a %a -> %a " pretty x pretty y pretty res; - res - - let le ik x y = comparison ik (<=:) x y - - let le ik x y = - let res = le ik x y in - if M.tracing then M.trace "congruence" "less or equal : %a %a -> %a " pretty x pretty y pretty res; - res - - let gt ik x y = comparison ik (>:) x y - - - let gt ik x y = - let res = gt ik x y in - if M.tracing then M.trace "congruence" "greater than : %a %a -> %a " pretty x pretty y pretty res; - res - - let lt ik x y = comparison ik (<:) x y - - let lt ik x y = - let res = lt ik x y in - if M.tracing then M.trace "congruence" "less than : %a %a -> %a " pretty x pretty y pretty res; - res - - let invariant_ikind e ik x = - match x with - | x when is_top x -> Invariant.top () - | Some (c, m) when m =: Z.zero -> - IntInvariant.of_int e ik c - | Some (c, m) -> - let open Cil in - let (c, m) = BatTuple.Tuple2.mapn (fun a -> kintegerCilint ik a) (c, m) in - Invariant.of_exp (BinOp (Eq, (BinOp (Mod, e, m, TInt(ik,[]))), c, intType)) - | None -> Invariant.none - - let arbitrary ik = - let open QCheck in - let int_arb = map ~rev:Z.to_int64 Z.of_int64 GobQCheck.Arbitrary.int64 in - let cong_arb = pair int_arb int_arb in - let of_pair ik p = normalize ik (Some p) in - let to_pair = Option.get in - set_print show (map ~rev:to_pair (of_pair ik) cong_arb) - - let refine_with_interval ik (cong : t) (intv : (int_t * int_t ) option) : t = - match intv, cong with - | Some (x, y), Some (c, m) -> - if m =: Z.zero then - if c <: x || c >: y then None else Some (c, Z.zero) - else - let rcx = x +: ((c -: x) %: Z.abs m) in - let lcy = y -: ((y -: c) %: Z.abs m) in - if rcx >: lcy then None - else if rcx =: lcy then Some (rcx, Z.zero) - else cong - | _ -> None - - let refine_with_interval ik (cong : t) (intv : (int_t * int_t) option) : t = - let pretty_intv _ i = - match i with - | Some (l, u) -> Pretty.dprintf "[%a,%a]" GobZ.pretty l GobZ.pretty u - | _ -> Pretty.text ("Display Error") in - let refn = refine_with_interval ik cong intv in - if M.tracing then M.trace "refine" "cong_refine_with_interval %a %a -> %a" pretty cong pretty_intv intv pretty refn; - refn - - let refine_with_congruence ik a b = meet ik a b - let refine_with_excl_list ik a b = a - let refine_with_incl_list ik a b = a - - let project ik p t = t -end - -module SOverflowLifter (D : S) : SOverflow with type int_t = D.int_t and type t = D.t = struct - - include D - - let lift v = (v, {overflow=false; underflow=false}) - - let add ?no_ov ik x y = lift @@ D.add ?no_ov ik x y - - let sub ?no_ov ik x y = lift @@ D.sub ?no_ov ik x y - - let mul ?no_ov ik x y = lift @@ D.mul ?no_ov ik x y - - let div ?no_ov ik x y = lift @@ D.div ?no_ov ik x y - - let neg ?no_ov ik x = lift @@ D.neg ?no_ov ik x - - let cast_to ?suppress_ovwarn ?torg ?no_ov ik x = lift @@ D.cast_to ?suppress_ovwarn ?torg ?no_ov ik x - - let of_int ik x = lift @@ D.of_int ik x - - let of_interval ?suppress_ovwarn ik x = lift @@ D.of_interval ?suppress_ovwarn ik x - - let starting ?suppress_ovwarn ik x = lift @@ D.starting ?suppress_ovwarn ik x - - let ending ?suppress_ovwarn ik x = lift @@ D.ending ?suppress_ovwarn ik x - - let shift_left ik x y = lift @@ D.shift_left ik x y - - let shift_right ik x y = lift @@ D.shift_right ik x y - -end - - - -(* The old IntDomList had too much boilerplate since we had to edit every function in S when adding a new domain. With the following, we only have to edit the places where fn are applied, i.e., create, mapp, map, map2. You can search for I3 below to see where you need to extend. *) -(* discussion: https://github.com/goblint/analyzer/pull/188#issuecomment-818928540 *) -module IntDomTupleImpl = struct - include Printable.Std (* for default invariant, tag, ... *) - - open Batteries - type int_t = Z.t - module I1 = SOverflowLifter (DefExc) - module I2 = Interval - module I3 = SOverflowLifter (Enums) - module I4 = SOverflowLifter (Congruence) - module I5 = IntervalSetFunctor (IntOps.BigIntOps) - - type t = I1.t option * I2.t option * I3.t option * I4.t option * I5.t option - [@@deriving eq, ord, hash] - - let name () = "intdomtuple" - - (* The Interval domain can lead to too many contexts for recursive functions (top is [min,max]), but we don't want to drop all ints as with `ana.base.context.int`. TODO better solution? *) - let no_interval = Tuple5.map2 (const None) - let no_intervalSet = Tuple5.map5 (const None) - - type 'a m = (module SOverflow with type t = 'a) - type 'a m2 = (module SOverflow with type t = 'a and type int_t = int_t ) - - (* only first-order polymorphism on functions -> use records to get around monomorphism restriction on arguments *) - type 'b poly_in = { fi : 'a. 'a m -> 'b -> 'a } [@@unboxed] (* inject *) - type 'b poly2_in = { fi2 : 'a. 'a m2 -> 'b -> 'a } [@@unboxed] (* inject for functions that depend on int_t *) - type 'b poly2_in_ovc = { fi2_ovc : 'a. 'a m2 -> 'b -> 'a * overflow_info} [@@unboxed] (* inject for functions that depend on int_t *) - - type 'b poly_pr = { fp : 'a. 'a m -> 'a -> 'b } [@@unboxed] (* project *) - type 'b poly_pr2 = { fp2 : 'a. 'a m2 -> 'a -> 'b } [@@unboxed] (* project for functions that depend on int_t *) - type 'b poly2_pr = {f2p: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'b} [@@unboxed] - type poly1 = {f1: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a} [@@unboxed] (* needed b/c above 'b must be different from 'a *) - type poly1_ovc = {f1_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a * overflow_info } [@@unboxed] (* needed b/c above 'b must be different from 'a *) - type poly2 = {f2: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a} [@@unboxed] - type poly2_ovc = {f2_ovc: 'a. 'a m -> ?no_ov:bool -> 'a -> 'a -> 'a * overflow_info } [@@unboxed] - type 'b poly3 = { f3: 'a. 'a m -> 'a option } [@@unboxed] (* used for projection to given precision *) - let create r x ((p1, p2, p3, p4, p5): int_precision) = - let f b g = if b then Some (g x) else None in - f p1 @@ r.fi (module I1), f p2 @@ r.fi (module I2), f p3 @@ r.fi (module I3), f p4 @@ r.fi (module I4), f p5 @@ r.fi (module I5) - let create r x = (* use where values are introduced *) - create r x (int_precision_from_node_or_config ()) - let create2 r x ((p1, p2, p3, p4, p5): int_precision) = - let f b g = if b then Some (g x) else None in - f p1 @@ r.fi2 (module I1), f p2 @@ r.fi2 (module I2), f p3 @@ r.fi2 (module I3), f p4 @@ r.fi2 (module I4), f p5 @@ r.fi2 (module I5) - let create2 r x = (* use where values are introduced *) - create2 r x (int_precision_from_node_or_config ()) - - let no_overflow ik = function - | Some(_, {underflow; overflow}) -> not (underflow || overflow) - | _ -> false - - let check_ov ?(suppress_ovwarn = false) ~cast ik intv intv_set = - let no_ov = (no_overflow ik intv) || (no_overflow ik intv_set) in - if not no_ov && not suppress_ovwarn && ( BatOption.is_some intv || BatOption.is_some intv_set) then ( - let (_,{underflow=underflow_intv; overflow=overflow_intv}) = match intv with None -> (I2.bot (), {underflow= true; overflow = true}) | Some x -> x in - let (_,{underflow=underflow_intv_set; overflow=overflow_intv_set}) = match intv_set with None -> (I5.bot (), {underflow= true; overflow = true}) | Some x -> x in - let underflow = underflow_intv && underflow_intv_set in - let overflow = overflow_intv && overflow_intv_set in - set_overflow_flag ~cast ~underflow ~overflow ik; - ); - no_ov - - let create2_ovc ik r x ((p1, p2, p3, p4, p5): int_precision) = - let f b g = if b then Some (g x) else None in - let map x = Option.map fst x in - let intv = f p2 @@ r.fi2_ovc (module I2) in - let intv_set = f p5 @@ r.fi2_ovc (module I5) in - ignore (check_ov ~cast:false ik intv intv_set); - map @@ f p1 @@ r.fi2_ovc (module I1), map @@ f p2 @@ r.fi2_ovc (module I2), map @@ f p3 @@ r.fi2_ovc (module I3), map @@ f p4 @@ r.fi2_ovc (module I4), map @@ f p5 @@ r.fi2_ovc (module I5) - - let create2_ovc ik r x = (* use where values are introduced *) - create2_ovc ik r x (int_precision_from_node_or_config ()) - - - let opt_map2 f ?no_ov = - curry @@ function Some x, Some y -> Some (f ?no_ov x y) | _ -> None - - let to_list x = Tuple5.enum x |> List.of_enum |> List.filter_map identity (* contains only the values of activated domains *) - let to_list_some x = List.filter_map identity @@ to_list x (* contains only the Some-values of activated domains *) - - let exists = function - | (Some true, _, _, _, _) - | (_, Some true, _, _, _) - | (_, _, Some true, _, _) - | (_, _, _, Some true, _) - | (_, _, _, _, Some true) -> - true - | _ -> - false - - let for_all = function - | (Some false, _, _, _, _) - | (_, Some false, _, _, _) - | (_, _, Some false, _, _) - | (_, _, _, Some false, _) - | (_, _, _, _, Some false) -> - false - | _ -> - true - - (* f0: constructors *) - let top () = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.top } () - let bot () = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.bot } () - let top_of = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.top_of } - let bot_of = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.bot_of } - let of_bool ik = create { fi = fun (type a) (module I:SOverflow with type t = a) -> I.of_bool ik } - let of_excl_list ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_excl_list ik} - let of_int ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_int ik } - let starting ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.starting ~suppress_ovwarn ik } - let ending ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.ending ~suppress_ovwarn ik } - let of_interval ?(suppress_ovwarn=false) ik = create2_ovc ik { fi2_ovc = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_interval ~suppress_ovwarn ik } - let of_congruence ik = create2 { fi2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.of_congruence ik } - - let refine_with_congruence ik ((a, b, c, d, e) : t) (cong : (int_t * int_t) option) : t= - let opt f a = - curry @@ function Some x, y -> Some (f a x y) | _ -> None - in - ( opt I1.refine_with_congruence ik a cong - , opt I2.refine_with_congruence ik b cong - , opt I3.refine_with_congruence ik c cong - , opt I4.refine_with_congruence ik d cong - , opt I5.refine_with_congruence ik e cong) - - let refine_with_interval ik (a, b, c, d, e) intv = - let opt f a = - curry @@ function Some x, y -> Some (f a x y) | _ -> None - in - ( opt I1.refine_with_interval ik a intv - , opt I2.refine_with_interval ik b intv - , opt I3.refine_with_interval ik c intv - , opt I4.refine_with_interval ik d intv - , opt I5.refine_with_interval ik e intv ) - - let refine_with_excl_list ik (a, b, c, d, e) excl = - let opt f a = - curry @@ function Some x, y -> Some (f a x y) | _ -> None - in - ( opt I1.refine_with_excl_list ik a excl - , opt I2.refine_with_excl_list ik b excl - , opt I3.refine_with_excl_list ik c excl - , opt I4.refine_with_excl_list ik d excl - , opt I5.refine_with_excl_list ik e excl ) - - let refine_with_incl_list ik (a, b, c, d, e) incl = - let opt f a = - curry @@ function Some x, y -> Some (f a x y) | _ -> None - in - ( opt I1.refine_with_incl_list ik a incl - , opt I2.refine_with_incl_list ik b incl - , opt I3.refine_with_incl_list ik c incl - , opt I4.refine_with_incl_list ik d incl - , opt I5.refine_with_incl_list ik e incl ) - - - let mapp r (a, b, c, d, e) = - let map = BatOption.map in - ( map (r.fp (module I1)) a - , map (r.fp (module I2)) b - , map (r.fp (module I3)) c - , map (r.fp (module I4)) d - , map (r.fp (module I5)) e) - - - let mapp2 r (a, b, c, d, e) = - BatOption. - ( map (r.fp2 (module I1)) a - , map (r.fp2 (module I2)) b - , map (r.fp2 (module I3)) c - , map (r.fp2 (module I4)) d - , map (r.fp2 (module I5)) e) - - - (* exists/for_all *) - let is_bot = exists % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_bot } - let is_top = for_all % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_top } - let is_top_of ik = for_all % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_top_of ik } - let is_excl_list = exists % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.is_excl_list } - - let map2p r (xa, xb, xc, xd, xe) (ya, yb, yc, yd, ye) = - ( opt_map2 (r.f2p (module I1)) xa ya - , opt_map2 (r.f2p (module I2)) xb yb - , opt_map2 (r.f2p (module I3)) xc yc - , opt_map2 (r.f2p (module I4)) xd yd - , opt_map2 (r.f2p (module I5)) xe ye) - - (* f2p: binary projections *) - let (%%) f g x = f % (g x) (* composition for binary function g *) - - let leq = - for_all - %% map2p {f2p= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.leq)} - - let flat f x = match to_list_some x with [] -> None | xs -> Some (f xs) - - let to_excl_list x = - let merge ps = - let (vs, rs) = List.split ps in - let (mins, maxs) = List.split rs in - (List.concat vs |> List.sort_uniq Z.compare, (List.min mins, List.max maxs)) - in - mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_excl_list } x |> flat merge - - let to_incl_list x = - let hd l = match l with h::t -> h | _ -> [] in - let tl l = match l with h::t -> t | _ -> [] in - let a y = BatSet.of_list (hd y) in - let b y = BatList.map BatSet.of_list (tl y) in - let merge y = BatSet.elements @@ BatList.fold BatSet.intersect (a y) (b y) - in - mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_incl_list } x |> flat merge - - let same show x = let xs = to_list_some x in let us = List.unique xs in let n = List.length us in - if n = 1 then Some (List.hd xs) - else ( - if n>1 then Messages.info ~category:Unsound "Inconsistent state! %a" (Pretty.docList ~sep:(Pretty.text ",") (Pretty.text % show)) us; (* do not want to abort *) - None - ) - let to_int = same Z.to_string % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.to_int } - - let pretty () x = - match to_int x with - | Some v when not (GobConfig.get_bool "dbg.full-output") -> Pretty.text (Z.to_string v) - | _ -> - mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> (* assert sf==I.short; *) I.pretty () } x - |> to_list - |> (fun xs -> - text "(" ++ ( - try - List.reduce (fun a b -> a ++ text "," ++ b) xs - with Invalid_argument _ -> - nil) - ++ text ")") (* NOTE: the version above does something else. also, we ignore the sf-argument here. *) - - let refine_functions ik : (t -> t) list = - let maybe reffun ik domtup dom = - match dom with Some y -> reffun ik domtup y | _ -> domtup - in - [(fun (a, b, c, d, e) -> refine_with_excl_list ik (a, b, c, d, e) (to_excl_list (a, b, c, d, e))); - (fun (a, b, c, d, e) -> refine_with_incl_list ik (a, b, c, d, e) (to_incl_list (a, b, c, d, e))); - (fun (a, b, c, d, e) -> maybe refine_with_interval ik (a, b, c, d, e) b); (* TODO: get interval across all domains with minimal and maximal *) - (fun (a, b, c, d, e) -> maybe refine_with_congruence ik (a, b, c, d, e) d)] - - let refine ik ((a, b, c, d, e) : t ) : t = - let dt = ref (a, b, c, d, e) in - (match get_refinement () with - | "never" -> () - | "once" -> - List.iter (fun f -> dt := f !dt) (refine_functions ik); - | "fixpoint" -> - let quit_loop = ref false in - while not !quit_loop do - let old_dt = !dt in - List.iter (fun f -> dt := f !dt) (refine_functions ik); - quit_loop := equal old_dt !dt; - if is_bot !dt then dt := bot_of ik; quit_loop := true; - if M.tracing then M.trace "cong-refine-loop" "old: %a, new: %a" pretty old_dt pretty !dt; - done; - | _ -> () - ); !dt - - - (* map with overflow check *) - let mapovc ?(suppress_ovwarn=false) ?(cast=false) ik r (a, b, c, d, e) = - let map f ?no_ov = function Some x -> Some (f ?no_ov x) | _ -> None in - let intv = map (r.f1_ovc (module I2)) b in - let intv_set = map (r.f1_ovc (module I5)) e in - let no_ov = check_ov ~suppress_ovwarn ~cast ik intv intv_set in - let no_ov = no_ov || should_ignore_overflow ik in - refine ik - ( map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I1) x |> fst) a - , BatOption.map fst intv - , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I3) x |> fst) c - , map (fun ?no_ov x -> r.f1_ovc ?no_ov (module I4) x |> fst) ~no_ov d - , BatOption.map fst intv_set ) - - (* map2 with overflow check *) - let map2ovc ?(cast=false) ik r (xa, xb, xc, xd, xe) (ya, yb, yc, yd, ye) = - let intv = opt_map2 (r.f2_ovc (module I2)) xb yb in - let intv_set = opt_map2 (r.f2_ovc (module I5)) xe ye in - let no_ov = check_ov ~cast ik intv intv_set in - let no_ov = no_ov || should_ignore_overflow ik in - refine ik - ( opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I1) x y |> fst) xa ya - , BatOption.map fst intv - , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I3) x y |> fst) xc yc - , opt_map2 (fun ?no_ov x y -> r.f2_ovc ?no_ov (module I4) x y |> fst) ~no_ov:no_ov xd yd - , BatOption.map fst intv_set ) - - let map ik r (a, b, c, d, e) = - refine ik - BatOption. - ( map (r.f1 (module I1)) a - , map (r.f1 (module I2)) b - , map (r.f1 (module I3)) c - , map (r.f1 (module I4)) d - , map (r.f1 (module I5)) e) - - let map2 ?(norefine=false) ik r (xa, xb, xc, xd, xe) (ya, yb, yc, yd, ye) = - let r = - ( opt_map2 (r.f2 (module I1)) xa ya - , opt_map2 (r.f2 (module I2)) xb yb - , opt_map2 (r.f2 (module I3)) xc yc - , opt_map2 (r.f2 (module I4)) xd yd - , opt_map2 (r.f2 (module I5)) xe ye) - in - if norefine then r else refine ik r - - - (* f1: unary ops *) - let neg ?no_ov ik = - mapovc ik {f1_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.neg ?no_ov ik)} - - let lognot ik = - map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.lognot ik)} - - let c_lognot ik = - map ik {f1 = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_lognot ik)} - - let cast_to ?(suppress_ovwarn=false) ?torg ?no_ov t = - mapovc ~suppress_ovwarn ~cast:true t {f1_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.cast_to ?torg ?no_ov t)} - - (* fp: projections *) - let equal_to i x = - let xs = mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.equal_to i } x |> Tuple5.enum |> List.of_enum |> List.filter_map identity in - if List.mem `Eq xs then `Eq else - if List.mem `Neq xs then `Neq else - `Top - - let to_bool = same string_of_bool % mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.to_bool } - let minimal = flat (List.max ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.minimal } - let maximal = flat (List.min ~cmp:Z.compare) % mapp2 { fp2 = fun (type a) (module I:SOverflow with type t = a and type int_t = int_t) -> I.maximal } - (* others *) - let show x = - match to_int x with - | Some v when not (GobConfig.get_bool "dbg.full-output") -> Z.to_string v - | _ -> mapp { fp = fun (type a) (module I:SOverflow with type t = a) x -> I.name () ^ ":" ^ (I.show x) } x - |> to_list - |> String.concat "; " - let to_yojson = [%to_yojson: Yojson.Safe.t list] % to_list % mapp { fp = fun (type a) (module I:SOverflow with type t = a) x -> I.to_yojson x } - - (* `map/opt_map` are used by `project` *) - let opt_map b f = - curry @@ function None, true -> f | x, y when y || b -> x | _ -> None - let map ~keep r (i1, i2, i3, i4, i5) (b1, b2, b3, b4, b5) = - ( opt_map keep (r.f3 (module I1)) i1 b1 - , opt_map keep (r.f3 (module I2)) i2 b2 - , opt_map keep (r.f3 (module I3)) i3 b3 - , opt_map keep (r.f3 (module I4)) i4 b4 - , opt_map keep (r.f3 (module I5)) i5 b5 ) - - (** Project tuple t to precision p - * We have to deactivate IntDomains after the refinement, since we might - * lose information if we do it before. E.g. only "Interval" is active - * and shall be projected to only "Def_Exc". By seting "Interval" to None - * before refinement we have no information for "Def_Exc". - * - * Thus we have 3 Steps: - * 1. Add padding to t by setting `None` to `I.top_of ik` if p is true for this element - * 2. Refine the padded t - * 3. Set elements of t to `None` if p is false for this element - * - * Side Note: - * ~keep is used to reuse `map/opt_map` for Step 1 and 3. - * ~keep:true will keep elements that are `Some x` but should be set to `None` by p. - * This way we won't loose any information for the refinement. - * ~keep:false will set the elements to `None` as defined by p *) - let project ik (p: int_precision) t = - let t_padded = map ~keep:true { f3 = fun (type a) (module I:SOverflow with type t = a) -> Some (I.top_of ik) } t p in - let t_refined = refine ik t_padded in - map ~keep:false { f3 = fun (type a) (module I:SOverflow with type t = a) -> None } t_refined p - - - (* f2: binary ops *) - let join ik = - map2 ~norefine:true ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.join ik)} - - let meet ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.meet ik)} - - let widen ik = - map2 ~norefine:true ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.widen ik)} - - let narrow ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.narrow ik)} - - let add ?no_ov ik = - map2ovc ik - {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.add ?no_ov ik)} - - let sub ?no_ov ik = - map2ovc ik - {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.sub ?no_ov ik)} - - let mul ?no_ov ik = - map2ovc ik - {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.mul ?no_ov ik)} - - let div ?no_ov ik = - map2ovc ik - {f2_ovc = (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.div ?no_ov ik)} - - let rem ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.rem ik)} - - let lt ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.lt ik)} - - let gt ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.gt ik)} - - let le ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.le ik)} - - let ge ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.ge ik)} - - let eq ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.eq ik)} - - let ne ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.ne ik)} - - let logand ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logand ik)} - - let logor ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logor ik)} - - let logxor ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.logxor ik)} - - let shift_left ik = - map2ovc ik {f2_ovc= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.shift_left ik)} - - let shift_right ik = - map2ovc ik {f2_ovc= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.shift_right ik)} - - let c_logand ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_logand ik)} - - let c_logor ik = - map2 ik {f2= (fun (type a) (module I : SOverflow with type t = a) ?no_ov -> I.c_logor ik)} - - - (* printing boilerplate *) - let pretty_diff () (x,y) = dprintf "%a instead of %a" pretty x pretty y - let printXml f x = - match to_int x with - | Some v when not (GobConfig.get_bool "dbg.full-output") -> BatPrintf.fprintf f "\n\n%s\n\n\n" (Z.to_string v) - | _ -> BatPrintf.fprintf f "\n\n%s\n\n\n" (show x) - - let invariant_ikind e ik ((_, _, _, x_cong, x_intset) as x) = - (* TODO: do refinement before to ensure incl_list being more precise than intervals, etc (https://github.com/goblint/analyzer/pull/1517#discussion_r1693998515), requires refine functions to actually refine that *) - let simplify_int fallback = - match to_int x with - | Some v -> - (* If definite, output single equality instead of every subdomain repeating same equality (or something less precise). *) - IntInvariant.of_int e ik v - | None -> - fallback () - in - let simplify_all () = - match to_incl_list x with - | Some ps -> - (* If inclusion set, output disjunction of equalities because it subsumes interval(s), exclusion set and congruence. *) - IntInvariant.of_incl_list e ik ps - | None -> - (* Get interval bounds from all domains (intervals and exclusion set ranges). *) - let min = minimal x in - let max = maximal x in - let ns = Option.map fst (to_excl_list x) |? [] in (* Ignore exclusion set bit range, known via interval bounds already. *) - (* "Refine" out-of-bounds exclusions for simpler output. *) - let ns = Option.map_default (fun min -> List.filter (Z.leq min) ns) ns min in - let ns = Option.map_default (fun max -> List.filter (Z.geq max) ns) ns max in - Invariant.( - IntInvariant.of_interval_opt e ik (min, max) && (* Output best interval bounds once instead of multiple subdomains repeating them (or less precise ones). *) - IntInvariant.of_excl_list e ik ns && - Option.map_default (I4.invariant_ikind e ik) Invariant.none x_cong && (* Output congruence as is. *) - Option.map_default (I5.invariant_ikind e ik) Invariant.none x_intset (* Output interval sets as is. *) - ) - in - let simplify_none () = - let is = to_list (mapp { fp = fun (type a) (module I:SOverflow with type t = a) -> I.invariant_ikind e ik } x) in - List.fold_left (fun a i -> - Invariant.(a && i) - ) (Invariant.top ()) is - in - match GobConfig.get_string "ana.base.invariant.int.simplify" with - | "none" -> simplify_none () - | "int" -> simplify_int simplify_none - | "all" -> simplify_int simplify_all - | _ -> assert false - - let arbitrary ik = QCheck.(set_print show @@ tup5 (option (I1.arbitrary ik)) (option (I2.arbitrary ik)) (option (I3.arbitrary ik)) (option (I4.arbitrary ik)) (option (I5.arbitrary ik))) - - let relift (a, b, c, d, e) = - (Option.map I1.relift a, Option.map I2.relift b, Option.map I3.relift c, Option.map I4.relift d, Option.map I5.relift e) -end - -module IntDomTuple = -struct - module I = IntDomLifter (IntDomTupleImpl) - include I - - let top () = failwith "top in IntDomTuple not supported. Use top_of instead." - let no_interval (x: I.t) = {x with v = IntDomTupleImpl.no_interval x.v} - - let no_intervalSet (x: I.t) = {x with v = IntDomTupleImpl.no_intervalSet x.v} -end - -let of_const (i, ik, str) = IntDomTuple.of_int ik i +include IntDomain0 + +include IntervalDomain +include IntervalSetDomain +include DefExcDomain +include EnumsDomain +include CongruenceDomain +include IntDomTuple diff --git a/src/cdomain/value/cdomains/intDomain0.ml b/src/cdomain/value/cdomains/intDomain0.ml new file mode 100644 index 0000000000..61a5f2c19b --- /dev/null +++ b/src/cdomain/value/cdomains/intDomain0.ml @@ -0,0 +1,922 @@ +open GobConfig +open GoblintCil +open Pretty +open PrecisionUtil + +module M = Messages + +let (%) = Batteries.(%) +let (|?) = Batteries.(|?) + +exception IncompatibleIKinds of string +exception Unknown +exception Error +exception ArithmeticOnIntegerBot of string + + + + +(** Define records that hold mutable variables representing different Configuration values. + * These values are used to keep track of whether or not the corresponding Config values are en-/disabled *) +type ana_int_config_values = { + mutable interval_threshold_widening : bool option; + mutable interval_narrow_by_meet : bool option; + mutable def_exc_widen_by_join : bool option; + mutable interval_threshold_widening_constants : string option; + mutable refinement : string option; +} + +let ana_int_config: ana_int_config_values = { + interval_threshold_widening = None; + interval_narrow_by_meet = None; + def_exc_widen_by_join = None; + interval_threshold_widening_constants = None; + refinement = None; +} + +let get_interval_threshold_widening () = + if ana_int_config.interval_threshold_widening = None then + ana_int_config.interval_threshold_widening <- Some (get_bool "ana.int.interval_threshold_widening"); + Option.get ana_int_config.interval_threshold_widening + +let get_interval_narrow_by_meet () = + if ana_int_config.interval_narrow_by_meet = None then + ana_int_config.interval_narrow_by_meet <- Some (get_bool "ana.int.interval_narrow_by_meet"); + Option.get ana_int_config.interval_narrow_by_meet + +let get_def_exc_widen_by_join () = + if ana_int_config.def_exc_widen_by_join = None then + ana_int_config.def_exc_widen_by_join <- Some (get_bool "ana.int.def_exc_widen_by_join"); + Option.get ana_int_config.def_exc_widen_by_join + +let get_interval_threshold_widening_constants () = + if ana_int_config.interval_threshold_widening_constants = None then + ana_int_config.interval_threshold_widening_constants <- Some (get_string "ana.int.interval_threshold_widening_constants"); + Option.get ana_int_config.interval_threshold_widening_constants + +let get_refinement () = + if ana_int_config.refinement = None then + ana_int_config.refinement <- Some (get_string "ana.int.refinement"); + Option.get ana_int_config.refinement + + + +(** Whether for a given ikind, we should compute with wrap-around arithmetic. + * Always for unsigned types, for signed types if 'sem.int.signed_overflow' is 'assume_wraparound' *) +let should_wrap ik = not (Cil.isSigned ik) || get_string "sem.int.signed_overflow" = "assume_wraparound" + +(** Whether for a given ikind, we should assume there are no overflows. + * Always false for unsigned types, true for signed types if 'sem.int.signed_overflow' is 'assume_none' *) +let should_ignore_overflow ik = Cil.isSigned ik && get_string "sem.int.signed_overflow" = "assume_none" + +let widening_thresholds = ResettableLazy.from_fun WideningThresholds.thresholds +let widening_thresholds_desc = ResettableLazy.from_fun (List.rev % WideningThresholds.thresholds) + +type overflow_info = { overflow: bool; underflow: bool;} + +let set_overflow_flag ~cast ~underflow ~overflow ik = + if !AnalysisState.executing_speculative_computations then + (* Do not produce warnings when the operations are not actually happening in code *) + () + else + let signed = Cil.isSigned ik in + if !AnalysisState.postsolving && signed && not cast then + AnalysisState.svcomp_may_overflow := true; + let sign = if signed then "Signed" else "Unsigned" in + match underflow, overflow with + | true, true -> + M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 190; CWE 191] "%s integer overflow and underflow" sign + | true, false -> + M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 191] "%s integer underflow" sign + | false, true -> + M.warn ~category:M.Category.Integer.overflow ~tags:[CWE 190] "%s integer overflow" sign + | false, false -> assert false + +let reset_lazy () = + ResettableLazy.reset widening_thresholds; + ResettableLazy.reset widening_thresholds_desc; + ana_int_config.interval_threshold_widening <- None; + ana_int_config.interval_narrow_by_meet <- None; + ana_int_config.def_exc_widen_by_join <- None; + ana_int_config.interval_threshold_widening_constants <- None; + ana_int_config.refinement <- None + +module type Arith = +sig + type t + val neg: t -> t + val add: t -> t -> t + val sub: t -> t -> t + val mul: t -> t -> t + val div: t -> t -> t + val rem: t -> t -> t + + val lt: t -> t -> t + val gt: t -> t -> t + val le: t -> t -> t + val ge: t -> t -> t + val eq: t -> t -> t + val ne: t -> t -> t + + val lognot: t -> t + val logand: t -> t -> t + val logor : t -> t -> t + val logxor: t -> t -> t + + val shift_left : t -> t -> t + val shift_right: t -> t -> t + + val c_lognot: t -> t + val c_logand: t -> t -> t + val c_logor : t -> t -> t + +end + +module type ArithIkind = +sig + type t + val neg: Cil.ikind -> t -> t + val add: Cil.ikind -> t -> t -> t + val sub: Cil.ikind -> t -> t -> t + val mul: Cil.ikind -> t -> t -> t + val div: Cil.ikind -> t -> t -> t + val rem: Cil.ikind -> t -> t -> t + + val lt: Cil.ikind -> t -> t -> t + val gt: Cil.ikind -> t -> t -> t + val le: Cil.ikind -> t -> t -> t + val ge: Cil.ikind -> t -> t -> t + val eq: Cil.ikind -> t -> t -> t + val ne: Cil.ikind -> t -> t -> t + + val lognot: Cil.ikind -> t -> t + val logand: Cil.ikind -> t -> t -> t + val logor : Cil.ikind -> t -> t -> t + val logxor: Cil.ikind -> t -> t -> t + + val shift_left : Cil.ikind -> t -> t -> t + val shift_right: Cil.ikind -> t -> t -> t + + val c_lognot: Cil.ikind -> t -> t + val c_logand: Cil.ikind -> t -> t -> t + val c_logor : Cil.ikind -> t -> t -> t + +end + +(* Shared functions between S and Z *) +module type B = +sig + include Lattice.S + type int_t + val bot_of: Cil.ikind -> t + val top_of: Cil.ikind -> t + val to_int: t -> int_t option + val equal_to: int_t -> t -> [`Eq | `Neq | `Top] + + val to_bool: t -> bool option + val to_excl_list: t -> (int_t list * (int64 * int64)) option + val of_excl_list: Cil.ikind -> int_t list -> t + val is_excl_list: t -> bool + + val to_incl_list: t -> int_t list option + + val maximal : t -> int_t option + val minimal : t -> int_t option + + val cast_to: ?suppress_ovwarn:bool -> ?torg:Cil.typ -> Cil.ikind -> t -> t +end + +(** Interface of IntDomain implementations that do not take ikinds for arithmetic operations yet. TODO: Should be ported to S in the future. *) +module type IkindUnawareS = +sig + include B + include Arith with type t := t + val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val of_int: int_t -> t + val of_bool: bool -> t + val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t + val of_congruence: Cil.ikind -> int_t * int_t -> t + val arbitrary: unit -> t QCheck.arbitrary + val invariant: Cil.exp -> t -> Invariant.t +end + +(** Interface of IntDomain implementations taking an ikind for arithmetic operations *) +module type S = +sig + include B + include ArithIkind with type t:= t + + val add : ?no_ov:bool -> Cil.ikind -> t -> t -> t + val sub : ?no_ov:bool -> Cil.ikind -> t -> t -> t + val mul : ?no_ov:bool -> Cil.ikind -> t -> t -> t + val div : ?no_ov:bool -> Cil.ikind -> t -> t -> t + val neg : ?no_ov:bool -> Cil.ikind -> t -> t + val cast_to : ?suppress_ovwarn:bool -> ?torg:Cil.typ -> ?no_ov:bool -> Cil.ikind -> t -> t + + val join: Cil.ikind -> t -> t -> t + val meet: Cil.ikind -> t -> t -> t + val narrow: Cil.ikind -> t -> t -> t + val widen: Cil.ikind -> t -> t -> t + val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val of_int: Cil.ikind -> int_t -> t + val of_bool: Cil.ikind -> bool -> t + val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t + val of_congruence: Cil.ikind -> int_t * int_t -> t + val is_top_of: Cil.ikind -> t -> bool + val invariant_ikind : Cil.exp -> Cil.ikind -> t -> Invariant.t + + val refine_with_congruence: Cil.ikind -> t -> (int_t * int_t) option -> t + val refine_with_interval: Cil.ikind -> t -> (int_t * int_t) option -> t + val refine_with_excl_list: Cil.ikind -> t -> (int_t list * (int64 * int64)) option -> t + val refine_with_incl_list: Cil.ikind -> t -> int_t list option -> t + + val project: Cil.ikind -> int_precision -> t -> t + val arbitrary: Cil.ikind -> t QCheck.arbitrary +end + +module type SOverflow = +sig + + include S + + val add : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info + + val sub : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info + + val mul : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info + + val div : ?no_ov:bool -> Cil.ikind -> t -> t -> t * overflow_info + + val neg : ?no_ov:bool -> Cil.ikind -> t -> t * overflow_info + + val cast_to : ?suppress_ovwarn:bool -> ?torg:Cil.typ -> ?no_ov:bool -> Cil.ikind -> t -> t * overflow_info + + val of_int : Cil.ikind -> int_t -> t * overflow_info + + val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t * overflow_info + + val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t * overflow_info + val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t * overflow_info + + val shift_left : Cil.ikind -> t -> t -> t * overflow_info + + val shift_right : Cil.ikind -> t -> t -> t * overflow_info +end + +module type Y = +sig + (* include B *) + include B + include Arith with type t:= t + val of_int: Cil.ikind -> int_t -> t + val of_bool: Cil.ikind -> bool -> t + val of_interval: ?suppress_ovwarn:bool -> Cil.ikind -> int_t * int_t -> t + val of_congruence: Cil.ikind -> int_t * int_t -> t + + val starting : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val ending : ?suppress_ovwarn:bool -> Cil.ikind -> int_t -> t + val is_top_of: Cil.ikind -> t -> bool + + val project: int_precision -> t -> t + val invariant: Cil.exp -> t -> Invariant.t +end + +module type Z = Y with type int_t = Z.t + + +module IntDomLifter (I : S) = +struct + open Cil + type int_t = I.int_t + type t = { v : I.t; ikind : CilType.Ikind.t } [@@deriving eq, ord, hash] + + let ikind {ikind; _} = ikind + + (* Helper functions *) + let check_ikinds x y = if x.ikind <> y.ikind then raise (IncompatibleIKinds (GobPretty.sprintf "ikinds %a and %a are incompatible. Values: %a and %a" CilType.Ikind.pretty x.ikind CilType.Ikind.pretty y.ikind I.pretty x.v I.pretty y.v)) + let lift op x = {x with v = op x.ikind x.v } + (* For logical operations the result is of type int *) + let lift_logical op x = {v = op x.ikind x.v; ikind = Cil.IInt} + let lift2 op x y = check_ikinds x y; {x with v = op x.ikind x.v y.v } + let lift2_cmp op x y = check_ikinds x y; {v = op x.ikind x.v y.v; ikind = Cil.IInt} + + let bot_of ikind = { v = I.bot_of ikind; ikind} + let bot () = failwith "bot () is not implemented for IntDomLifter." + let is_bot x = I.is_bot x.v + let top_of ikind = { v = I.top_of ikind; ikind} + let top () = failwith "top () is not implemented for IntDomLifter." + let is_top x = I.is_top x.v + + (* Leq does not check for ikind, because it is used in invariant with arguments of different type. + TODO: check ikinds here and fix invariant to work with right ikinds *) + let leq x y = I.leq x.v y.v + let join = lift2 I.join + let meet = lift2 I.meet + let widen = lift2 I.widen + let narrow = lift2 I.narrow + + let show x = + if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then + "⊤" + else + I.show x.v (* TODO add ikind to output *) + let pretty () x = + if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then + Pretty.text "⊤" + else + I.pretty () x.v (* TODO add ikind to output *) + let pretty_diff () (x, y) = I.pretty_diff () (x.v, y.v) (* TODO check ikinds, add them to output *) + let printXml o x = + if not (GobConfig.get_bool "dbg.full-output") && I.is_top_of x.ikind x.v then + BatPrintf.fprintf o "\n\n⊤\n\n\n" + else + I.printXml o x.v (* TODO add ikind to output *) + (* This is for debugging *) + let name () = "IntDomLifter(" ^ (I.name ()) ^ ")" + let to_yojson x = I.to_yojson x.v + let invariant e x = + let e' = Cilfacade.mkCast ~e ~newt:(TInt (x.ikind, [])) in + I.invariant_ikind e' x.ikind x.v + let tag x = I.tag x.v + let arbitrary ik = failwith @@ "Arbitrary not implement for " ^ (name ()) ^ "." + let to_int x = I.to_int x.v + let of_int ikind x = { v = I.of_int ikind x; ikind} + let equal_to i x = I.equal_to i x.v + let to_bool x = I.to_bool x.v + let of_bool ikind b = { v = I.of_bool ikind b; ikind} + let to_excl_list x = I.to_excl_list x.v + let of_excl_list ikind is = {v = I.of_excl_list ikind is; ikind} + let is_excl_list x = I.is_excl_list x.v + let to_incl_list x = I.to_incl_list x.v + let of_interval ?(suppress_ovwarn=false) ikind (lb,ub) = {v = I.of_interval ~suppress_ovwarn ikind (lb,ub); ikind} + let of_congruence ikind (c,m) = {v = I.of_congruence ikind (c,m); ikind} + let starting ?(suppress_ovwarn=false) ikind i = {v = I.starting ~suppress_ovwarn ikind i; ikind} + let ending ?(suppress_ovwarn=false) ikind i = {v = I.ending ~suppress_ovwarn ikind i; ikind} + let maximal x = I.maximal x.v + let minimal x = I.minimal x.v + + let neg = lift I.neg + let add = lift2 I.add + let sub = lift2 I.sub + let mul = lift2 I.mul + let div = lift2 I.div + let rem = lift2 I.rem + let lt = lift2_cmp I.lt + let gt = lift2_cmp I.gt + let le = lift2_cmp I.le + let ge = lift2_cmp I.ge + let eq = lift2_cmp I.eq + let ne = lift2_cmp I.ne + let lognot = lift I.lognot + let logand = lift2 I.logand + let logor = lift2 I.logor + let logxor = lift2 I.logxor + let shift_left x y = {x with v = I.shift_left x.ikind x.v y.v } (* TODO check ikinds*) + let shift_right x y = {x with v = I.shift_right x.ikind x.v y.v } (* TODO check ikinds*) + let c_lognot = lift_logical I.c_lognot + let c_logand = lift2 I.c_logand + let c_logor = lift2 I.c_logor + + let cast_to ?(suppress_ovwarn=false) ?torg ikind x = {v = I.cast_to ~suppress_ovwarn ~torg:(TInt(x.ikind,[])) ikind x.v; ikind} + + let is_top_of ik x = ik = x.ikind && I.is_top_of ik x.v + + let relift x = { v = I.relift x.v; ikind = x.ikind } + + let project p v = { v = I.project v.ikind p v.v; ikind = v.ikind } +end + +module type Ikind = +sig + val ikind: unit -> Cil.ikind +end + +module PtrDiffIkind : Ikind = +struct + let ikind = Cilfacade.ptrdiff_ikind +end + +module IntDomWithDefaultIkind (I: Y) (Ik: Ikind) : Y with type t = I.t and type int_t = I.int_t = +struct + include I + let top () = I.top_of (Ik.ikind ()) + let bot () = I.bot_of (Ik.ikind ()) +end + +module Size = struct (* size in bits as int, range as int64 *) + open Cil + let sign x = if Z.compare x Z.zero < 0 then `Signed else `Unsigned + + let top_typ = TInt (ILongLong, []) + let min_for x = intKindForValue x (sign x = `Unsigned) + let bit = function (* bits needed for representation *) + | IBool -> 1 + | ik -> bytesSizeOfInt ik * 8 + let is_int64_big_int x = Z.fits_int64 x + let card ik = (* cardinality *) + let b = bit ik in + Z.shift_left Z.one b + let bits ik = (* highest bits for neg/pos values *) + let s = bit ik in + if isSigned ik then s-1, s-1 else 0, s + let bits_i64 ik = BatTuple.Tuple2.mapn Int64.of_int (bits ik) + let range ik = + let a,b = bits ik in + let x = if isSigned ik then Z.neg (Z.shift_left Z.one a) (* -2^a *) else Z.zero in + let y = Z.pred (Z.shift_left Z.one b) in (* 2^b - 1 *) + x,y + + let is_cast_injective ~from_type ~to_type = + let (from_min, from_max) = range (Cilfacade.get_ikind from_type) in + let (to_min, to_max) = range (Cilfacade.get_ikind to_type) in + if M.tracing then M.trace "int" "is_cast_injective %a (%a, %a) -> %a (%a, %a)" CilType.Typ.pretty from_type GobZ.pretty from_min GobZ.pretty from_max CilType.Typ.pretty to_type GobZ.pretty to_min GobZ.pretty to_max; + Z.compare to_min from_min <= 0 && Z.compare from_max to_max <= 0 + + let cast t x = (* TODO: overflow is implementation-dependent! *) + if t = IBool then + (* C11 6.3.1.2 Boolean type *) + if Z.equal x Z.zero then Z.zero else Z.one + else + let a,b = range t in + let c = card t in + let y = Z.erem x c in + let y = if Z.gt y b then Z.sub y c + else if Z.lt y a then Z.add y c + else y + in + if M.tracing then M.tracel "cast" "Cast %a to range [%a, %a] (%a) = %a (%s in int64)" GobZ.pretty x GobZ.pretty a GobZ.pretty b GobZ.pretty c GobZ.pretty y (if is_int64_big_int y then "fits" else "does not fit"); + y + + let min_range_sign_agnostic x = + let size ik = + let a,b = bits_i64 ik in + Int64.neg a,b + in + if sign x = `Signed then + size (min_for x) + else + let a, b = size (min_for x) in + if b <= 64L then + let upper_bound_less = Int64.sub b 1L in + let max_one_less = Z.(pred @@ shift_left Z.one (Int64.to_int upper_bound_less)) in + if x <= max_one_less then + a, upper_bound_less + else + a,b + else + a, b + + (* From the number of bits used to represent a positive value, determines the maximal representable value *) + let max_from_bit_range pos_bits = Z.(pred @@ shift_left Z.one (to_int (Z.of_int64 pos_bits))) + + (* From the number of bits used to represent a non-positive value, determines the minimal representable value *) + let min_from_bit_range neg_bits = Z.(if neg_bits = 0L then Z.zero else neg @@ shift_left Z.one (to_int (neg (Z.of_int64 neg_bits)))) + +end + + +module StdTop (B: sig type t val top_of: Cil.ikind -> t end) = struct + open B + (* these should be overwritten for better precision if possible: *) + let to_excl_list x = None + let of_excl_list ik x = top_of ik + let is_excl_list x = false + let to_incl_list x = None + let of_interval ?(suppress_ovwarn=false) ik x = top_of ik + let of_congruence ik x = top_of ik + let starting ?(suppress_ovwarn=false) ik x = top_of ik + let ending ?(suppress_ovwarn=false) ik x = top_of ik + let maximal x = None + let minimal x = None +end + +module Std (B: sig + type t + val name: unit -> string + val top_of: Cil.ikind -> t + val bot_of: Cil.ikind -> t + val show: t -> string + val equal: t -> t -> bool + end) = struct + include Printable.StdLeaf + let name = B.name (* overwrite the one from Printable.Std *) + open B + let is_top x = failwith "is_top not implemented for IntDomain.Std" + let is_bot x = B.equal x (bot_of Cil.IInt) (* Here we assume that the representation of bottom is independent of the ikind + This may be true for intdomain implementations, but not e.g. for IntDomLifter. *) + let is_top_of ik x = B.equal x (top_of ik) + + (* all output is based on B.show *) + include Printable.SimpleShow ( + struct + type nonrec t = t + let show = show + end + ) + let pretty_diff () (x,y) = dprintf "%s: %a instead of %a" (name ()) pretty x pretty y + + include StdTop (B) +end + +(* Textbook interval arithmetic, without any overflow handling etc. *) +module IntervalArith (Ints_t : IntOps.IntOps) = struct + let min4 a b c d = Ints_t.min (Ints_t.min a b) (Ints_t.min c d) + let max4 a b c d = Ints_t.max (Ints_t.max a b) (Ints_t.max c d) + + let mul (x1, x2) (y1, y2) = + let x1y1 = (Ints_t.mul x1 y1) in + let x1y2 = (Ints_t.mul x1 y2) in + let x2y1 = (Ints_t.mul x2 y1) in + let x2y2 = (Ints_t.mul x2 y2) in + (min4 x1y1 x1y2 x2y1 x2y2, max4 x1y1 x1y2 x2y1 x2y2) + + let shift_left (x1,x2) (y1,y2) = + let y1p = Ints_t.shift_left Ints_t.one y1 in + let y2p = Ints_t.shift_left Ints_t.one y2 in + mul (x1, x2) (y1p, y2p) + + let div (x1, x2) (y1, y2) = + let x1y1n = (Ints_t.div x1 y1) in + let x1y2n = (Ints_t.div x1 y2) in + let x2y1n = (Ints_t.div x2 y1) in + let x2y2n = (Ints_t.div x2 y2) in + let x1y1p = (Ints_t.div x1 y1) in + let x1y2p = (Ints_t.div x1 y2) in + let x2y1p = (Ints_t.div x2 y1) in + let x2y2p = (Ints_t.div x2 y2) in + (min4 x1y1n x1y2n x2y1n x2y2n, max4 x1y1p x1y2p x2y1p x2y2p) + + let add (x1, x2) (y1, y2) = (Ints_t.add x1 y1, Ints_t.add x2 y2) + let sub (x1, x2) (y1, y2) = (Ints_t.sub x1 y2, Ints_t.sub x2 y1) + + let neg (x1, x2) = (Ints_t.neg x2, Ints_t.neg x1) + + let one = (Ints_t.one, Ints_t.one) + let zero = (Ints_t.zero, Ints_t.zero) + let top_bool = (Ints_t.zero, Ints_t.one) + + let to_int (x1, x2) = + if Ints_t.equal x1 x2 then Some x1 else None + + let upper_threshold u max_ik = + let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.upper_thresholds () else ResettableLazy.force widening_thresholds in + let u = Ints_t.to_bigint u in + let max_ik' = Ints_t.to_bigint max_ik in + let t = List.find_opt (fun x -> Z.compare u x <= 0 && Z.compare x max_ik' <= 0) ts in + BatOption.map_default Ints_t.of_bigint max_ik t + let lower_threshold l min_ik = + let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.lower_thresholds () else ResettableLazy.force widening_thresholds_desc in + let l = Ints_t.to_bigint l in + let min_ik' = Ints_t.to_bigint min_ik in + let t = List.find_opt (fun x -> Z.compare l x >= 0 && Z.compare x min_ik' >= 0) ts in + BatOption.map_default Ints_t.of_bigint min_ik t + let is_upper_threshold u = + let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.upper_thresholds () else ResettableLazy.force widening_thresholds in + let u = Ints_t.to_bigint u in + List.exists (Z.equal u) ts + let is_lower_threshold l = + let ts = if get_interval_threshold_widening_constants () = "comparisons" then WideningThresholds.lower_thresholds () else ResettableLazy.force widening_thresholds_desc in + let l = Ints_t.to_bigint l in + List.exists (Z.equal l) ts +end + +module IntInvariant = +struct + let of_int e ik x = + if get_bool "witness.invariant.exact" then + Invariant.of_exp Cil.(BinOp (Eq, e, kintegerCilint ik x, intType)) + else + Invariant.none + + let of_incl_list e ik ps = + match ps with + | [_; _] when ik = IBool && not (get_bool "witness.invariant.inexact-type-bounds") -> + assert (List.mem Z.zero ps); + assert (List.mem Z.one ps); + Invariant.none + | [_] when get_bool "witness.invariant.exact" -> + Invariant.none + | _ :: _ :: _ + | [_] | [] -> + List.fold_left (fun a x -> + let i = Invariant.of_exp Cil.(BinOp (Eq, e, kintegerCilint ik x, intType)) in + Invariant.(a || i) [@coverage off] (* bisect_ppx cannot handle redefined (||) *) + ) (Invariant.bot ()) ps + + let of_interval_opt e ik = function + | (Some x1, Some x2) when Z.equal x1 x2 -> + of_int e ik x1 + | x1_opt, x2_opt -> + let (min_ik, max_ik) = Size.range ik in + let inexact_type_bounds = get_bool "witness.invariant.inexact-type-bounds" in + let i1 = + match x1_opt, inexact_type_bounds with + | Some x1, false when Z.equal min_ik x1 -> Invariant.none + | Some x1, _ -> Invariant.of_exp Cil.(BinOp (Le, kintegerCilint ik x1, e, intType)) + | None, _ -> Invariant.none + in + let i2 = + match x2_opt, inexact_type_bounds with + | Some x2, false when Z.equal x2 max_ik -> Invariant.none + | Some x2, _ -> Invariant.of_exp Cil.(BinOp (Le, e, kintegerCilint ik x2, intType)) + | None, _ -> Invariant.none + in + Invariant.(i1 && i2) + + let of_interval e ik (x1, x2) = + of_interval_opt e ik (Some x1, Some x2) + + let of_excl_list e ik ns = + List.fold_left (fun a x -> + let i = Invariant.of_exp Cil.(BinOp (Ne, e, kintegerCilint ik x, intType)) in + Invariant.(a && i) + ) (Invariant.top ()) ns +end + +module SOverflowUnlifter (D : SOverflow) : S with type int_t = D.int_t and type t = D.t = struct + include D + + let add ?no_ov ik x y = fst @@ D.add ?no_ov ik x y + + let sub ?no_ov ik x y = fst @@ D.sub ?no_ov ik x y + + let mul ?no_ov ik x y = fst @@ D.mul ?no_ov ik x y + + let div ?no_ov ik x y = fst @@ D.div ?no_ov ik x y + + let neg ?no_ov ik x = fst @@ D.neg ?no_ov ik x + + let cast_to ?suppress_ovwarn ?torg ?no_ov ik x = fst @@ D.cast_to ?suppress_ovwarn ?torg ?no_ov ik x + + let of_int ik x = fst @@ D.of_int ik x + + let of_interval ?suppress_ovwarn ik x = fst @@ D.of_interval ?suppress_ovwarn ik x + + let starting ?suppress_ovwarn ik x = fst @@ D.starting ?suppress_ovwarn ik x + + let ending ?suppress_ovwarn ik x = fst @@ D.ending ?suppress_ovwarn ik x + + let shift_left ik x y = fst @@ D.shift_left ik x y + + let shift_right ik x y = fst @@ D.shift_right ik x y +end + +module IntIkind = struct let ikind () = Cil.IInt end + +module Integers (Ints_t : IntOps.IntOps): IkindUnawareS with type t = Ints_t.t and type int_t = Ints_t.t = (* no top/bot, order is <= *) +struct + include Printable.Std + let name () = "integers" + type t = Ints_t.t [@@deriving eq, ord, hash] + type int_t = Ints_t.t + let top () = raise Unknown + let bot () = raise Error + let top_of ik = top () + let bot_of ik = bot () + let show (x: Ints_t.t) = Ints_t.to_string x + + include Std (struct type nonrec t = t let name = name let top_of = top_of let bot_of = bot_of let show = show let equal = equal end) + (* is_top and is_bot are never called, but if they were, the Std impl would raise their exception, so we overwrite them: *) + let is_top _ = false + let is_bot _ = false + + let equal_to i x = if i > x then `Neq else `Top + let leq x y = x <= y + let join x y = if Ints_t.compare x y > 0 then x else y + let widen = join + let meet x y = if Ints_t.compare x y > 0 then y else x + let narrow = meet + + let of_bool x = if x then Ints_t.one else Ints_t.zero + let to_bool' x = x <> Ints_t.zero + let to_bool x = Some (to_bool' x) + let of_int x = x + let to_int x = Some x + + let neg = Ints_t.neg + let add = Ints_t.add (* TODO: signed overflow is undefined behavior! *) + let sub = Ints_t.sub + let mul = Ints_t.mul + let div = Ints_t.div + let rem = Ints_t.rem + let lt n1 n2 = of_bool (n1 < n2) + let gt n1 n2 = of_bool (n1 > n2) + let le n1 n2 = of_bool (n1 <= n2) + let ge n1 n2 = of_bool (n1 >= n2) + let eq n1 n2 = of_bool (n1 = n2) + let ne n1 n2 = of_bool (n1 <> n2) + let lognot = Ints_t.lognot + let logand = Ints_t.logand + let logor = Ints_t.logor + let logxor = Ints_t.logxor + let shift_left n1 n2 = Ints_t.shift_left n1 (Ints_t.to_int n2) + let shift_right n1 n2 = Ints_t.shift_right n1 (Ints_t.to_int n2) + let c_lognot n1 = of_bool (not (to_bool' n1)) + let c_logand n1 n2 = of_bool ((to_bool' n1) && (to_bool' n2)) + let c_logor n1 n2 = of_bool ((to_bool' n1) || (to_bool' n2)) + let cast_to ?(suppress_ovwarn=false) ?torg t x = failwith @@ "Cast_to not implemented for " ^ (name ()) ^ "." + let arbitrary ik = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 GobQCheck.Arbitrary.int64 (* TODO: use ikind *) + let invariant _ _ = Invariant.none (* TODO *) +end + +module FlatPureIntegers: IkindUnawareS with type t = int64 and type int_t = int64 = (* Integers, but raises Unknown/Error on join/meet *) +struct + include Integers(IntOps.Int64Ops) + let top () = raise Unknown + let bot () = raise Error + let leq = equal + let pretty_diff () (x,y) = Pretty.dprintf "Integer %a instead of %a" pretty x pretty y + let join x y = if equal x y then x else top () + let meet x y = if equal x y then x else bot () +end + +module Flat (Base: IkindUnawareS): IkindUnawareS with type t = [ `Bot | `Lifted of Base.t | `Top ] and type int_t = Base.int_t = (* identical to Lift, but goes to `Top/`Bot if Base raises Unknown/Error *) +struct + type int_t = Base.int_t + include Lattice.FlatConf (struct + include Printable.DefaultConf + let top_name = "Unknown int" + let bot_name = "Error int" + end) (Base) + + let top_of ik = top () + let bot_of ik = bot () + + + let name () = "flat integers" + let cast_to ?(suppress_ovwarn=false) ?torg t = function + | `Lifted x -> `Lifted (Base.cast_to t x) + | x -> x + + let equal_to i = function + | `Bot -> failwith "unsupported: equal_to with bottom" + | `Top -> `Top + | `Lifted x -> Base.equal_to i x + + let of_int x = `Lifted (Base.of_int x) + let to_int x = match x with + | `Lifted x -> Base.to_int x + | _ -> None + + let of_bool x = `Lifted (Base.of_bool x) + let to_bool x = match x with + | `Lifted x -> Base.to_bool x + | _ -> None + + let to_excl_list x = None + let of_excl_list ik x = top_of ik + let is_excl_list x = false + let to_incl_list x = None + let of_interval ?(suppress_ovwarn=false) ik x = top_of ik + let of_congruence ik x = top_of ik + let starting ?(suppress_ovwarn=false) ikind x = top_of ikind + let ending ?(suppress_ovwarn=false) ikind x = top_of ikind + let maximal x = None + let minimal x = None + + let lift1 f x = match x with + | `Lifted x -> + (try `Lifted (f x) with Unknown -> `Top | Error -> `Bot) + | x -> x + let lift2 f x y = match x,y with + | `Lifted x, `Lifted y -> + (try `Lifted (f x y) with Unknown -> `Top | Error -> `Bot) + | `Bot, `Bot -> `Bot + | _ -> `Top + + let neg = lift1 Base.neg + let add = lift2 Base.add + let sub = lift2 Base.sub + let mul = lift2 Base.mul + let div = lift2 Base.div + let rem = lift2 Base.rem + let lt = lift2 Base.lt + let gt = lift2 Base.gt + let le = lift2 Base.le + let ge = lift2 Base.ge + let eq = lift2 Base.eq + let ne = lift2 Base.ne + let lognot = lift1 Base.lognot + let logand = lift2 Base.logand + let logor = lift2 Base.logor + let logxor = lift2 Base.logxor + let shift_left = lift2 Base.shift_left + let shift_right = lift2 Base.shift_right + let c_lognot = lift1 Base.c_lognot + let c_logand = lift2 Base.c_logand + let c_logor = lift2 Base.c_logor + + let invariant e = function + | `Lifted x -> Base.invariant e x + | `Top | `Bot -> Invariant.none +end + +module Lift (Base: IkindUnawareS): IkindUnawareS with type t = [ `Bot | `Lifted of Base.t | `Top ] and type int_t = Base.int_t = (* identical to Flat, but does not go to `Top/Bot` if Base raises Unknown/Error *) +struct + include Lattice.LiftPO (struct + include Printable.DefaultConf + let top_name = "MaxInt" + let bot_name = "MinInt" + end) (Base) + type int_t = Base.int_t + let top_of ik = top () + let bot_of ik = bot () + include StdTop (struct type nonrec t = t let top_of = top_of end) + + let name () = "lifted integers" + let cast_to ?(suppress_ovwarn=false) ?torg t = function + | `Lifted x -> `Lifted (Base.cast_to t x) + | x -> x + + let equal_to i = function + | `Bot -> failwith "unsupported: equal_to with bottom" + | `Top -> `Top + | `Lifted x -> Base.equal_to i x + + let of_int x = `Lifted (Base.of_int x) + let to_int x = match x with + | `Lifted x -> Base.to_int x + | _ -> None + + let of_bool x = `Lifted (Base.of_bool x) + let to_bool x = match x with + | `Lifted x -> Base.to_bool x + | _ -> None + + let lift1 f x = match x with + | `Lifted x -> `Lifted (f x) + | x -> x + let lift2 f x y = match x,y with + | `Lifted x, `Lifted y -> `Lifted (f x y) + | `Bot, `Bot -> `Bot + | _ -> `Top + + let neg = lift1 Base.neg + let add = lift2 Base.add + let sub = lift2 Base.sub + let mul = lift2 Base.mul + let div = lift2 Base.div + let rem = lift2 Base.rem + let lt = lift2 Base.lt + let gt = lift2 Base.gt + let le = lift2 Base.le + let ge = lift2 Base.ge + let eq = lift2 Base.eq + let ne = lift2 Base.ne + let lognot = lift1 Base.lognot + let logand = lift2 Base.logand + let logor = lift2 Base.logor + let logxor = lift2 Base.logxor + let shift_left = lift2 Base.shift_left + let shift_right = lift2 Base.shift_right + let c_lognot = lift1 Base.c_lognot + let c_logand = lift2 Base.c_logand + let c_logor = lift2 Base.c_logor + + let invariant e = function + | `Lifted x -> Base.invariant e x + | `Top | `Bot -> Invariant.none +end + +module Flattened = Flat (Integers (IntOps.Int64Ops)) +module Lifted = Lift (Integers (IntOps.Int64Ops)) + +module Reverse (Base: IkindUnawareS) = +struct + include Base + include (Lattice.Reverse (Base) : Lattice.S with type t := Base.t) +end + +module SOverflowLifter (D : S) : SOverflow with type int_t = D.int_t and type t = D.t = struct + + include D + + let lift v = (v, {overflow=false; underflow=false}) + + let add ?no_ov ik x y = lift @@ D.add ?no_ov ik x y + + let sub ?no_ov ik x y = lift @@ D.sub ?no_ov ik x y + + let mul ?no_ov ik x y = lift @@ D.mul ?no_ov ik x y + + let div ?no_ov ik x y = lift @@ D.div ?no_ov ik x y + + let neg ?no_ov ik x = lift @@ D.neg ?no_ov ik x + + let cast_to ?suppress_ovwarn ?torg ?no_ov ik x = lift @@ D.cast_to ?suppress_ovwarn ?torg ?no_ov ik x + + let of_int ik x = lift @@ D.of_int ik x + + let of_interval ?suppress_ovwarn ik x = lift @@ D.of_interval ?suppress_ovwarn ik x + + let starting ?suppress_ovwarn ik x = lift @@ D.starting ?suppress_ovwarn ik x + + let ending ?suppress_ovwarn ik x = lift @@ D.ending ?suppress_ovwarn ik x + + let shift_left ik x y = lift @@ D.shift_left ik x y + + let shift_right ik x y = lift @@ D.shift_right ik x y + +end diff --git a/src/cdomain/value/cdomains/valueDomain.ml b/src/cdomain/value/cdomains/valueDomain.ml index f9f4b06ffb..b126d712bf 100644 --- a/src/cdomain/value/cdomains/valueDomain.ml +++ b/src/cdomain/value/cdomains/valueDomain.ml @@ -133,7 +133,7 @@ struct | _ -> false let is_mutex_type (t: typ): bool = match t with - | TNamed (info, attr) -> info.tname = "pthread_mutex_t" || info.tname = "spinlock_t" || info.tname = "pthread_spinlock_t" || info.tname = "pthread_cond_t" + | TNamed (info, attr) -> info.tname = "pthread_mutex_t" || info.tname = "spinlock_t" || info.tname = "pthread_spinlock_t" || info.tname = "pthread_cond_t" || info.tname = "pthread_rwlock_t" | TInt (IInt, attr) -> hasAttribute "mutex" attr | _ -> false diff --git a/src/common/util/richVarinfo.ml b/src/common/util/richVarinfo.ml index d1918c40a6..6a27339eed 100644 --- a/src/common/util/richVarinfo.ml +++ b/src/common/util/richVarinfo.ml @@ -1,9 +1,9 @@ open GoblintCil -let create_var name = Cilfacade.create_var @@ makeGlobalVar name voidType +let create_var name typ = Cilfacade.create_var @@ makeGlobalVar name typ -let single ~name = - let vi = lazy (create_var name) in +let single ~name ~typ = + let vi = lazy (create_var name typ) in fun () -> Lazy.force vi @@ -21,6 +21,7 @@ module type G = sig include Hashtbl.HashedType val name_varinfo: t -> string + val typ: t -> typ end module type H = @@ -47,7 +48,7 @@ struct try XH.find !xh x with Not_found -> - let vi = create_var (X.name_varinfo x) in + let vi = create_var (X.name_varinfo x) (X.typ x) in store_f x vi; vi diff --git a/src/common/util/richVarinfo.mli b/src/common/util/richVarinfo.mli index 4e682734ee..d1c002bf84 100644 --- a/src/common/util/richVarinfo.mli +++ b/src/common/util/richVarinfo.mli @@ -2,7 +2,7 @@ open GoblintCil -val single: name:string -> (unit -> varinfo) +val single: name:string -> typ:typ -> (unit -> varinfo) module type VarinfoMap = sig @@ -18,6 +18,7 @@ module type G = sig include Hashtbl.HashedType val name_varinfo: t -> string + val typ: t -> typ end module type H = diff --git a/src/config/options.schema.json b/src/config/options.schema.json index 12edb5bcec..43e2ad1d59 100644 --- a/src/config/options.schema.json +++ b/src/config/options.schema.json @@ -797,6 +797,18 @@ "type": "boolean", "default": true }, + "local": { + "title": "ana.base.invariant.local", + "description": "Keep local variables in invariants", + "type": "boolean", + "default": true + }, + "global": { + "title": "ana.base.invariant.global", + "description": "Keep global variables in invariants", + "type": "boolean", + "default": true + }, "blobs": { "title": "ana.base.invariant.blobs", "description": "Whether to dump assertions about all blobs. Enabling this option may lead to unsound asserts.", @@ -1166,6 +1178,26 @@ } }, "additionalProperties": false + }, + "var_eq": { + "title": "ana.var_eq", + "type": "object", + "properties": { + "invariant": { + "title": "ana.var_eq.invariant", + "type": "object", + "properties": { + "enabled": { + "title": "ana.var_eq.invariant.enabled", + "description": "Generate var_eq analysis invariants", + "type": "boolean", + "default": true + } + }, + "additionalProperties": false + } + }, + "additionalProperties": false } }, "additionalProperties": false @@ -2594,6 +2626,13 @@ "description": "Emit invariants with typedef-ed types (e.g. in casts). Our validator cannot parse these.", "type": "boolean", "default": true + }, + "flow_insensitive-as": { + "title": "witness.invariant.flow_insensitive-as", + "description": "Emit flow-insensitive invariants as location invariants at certain locations.", + "type": "string", + "enum": ["flow_insensitive_invariant", "location_invariant", "invariant_set-location_invariant"], + "default": "flow_insensitive_invariant" } }, "additionalProperties": false @@ -2614,7 +2653,8 @@ "type": "string", "enum": [ "0.1", - "2.0" + "2.0", + "2.1" ], "default": "0.1" }, @@ -2632,7 +2672,8 @@ "loop_invariant_certificate", "precondition_loop_invariant_certificate", "invariant_set", - "violation_sequence" + "violation_sequence", + "ghost_instrumentation" ] }, "default": [ diff --git a/src/domain/partitionDomain.ml b/src/domain/partitionDomain.ml index 316f4fb705..e97946e463 100644 --- a/src/domain/partitionDomain.ml +++ b/src/domain/partitionDomain.ml @@ -106,6 +106,9 @@ struct let show _ = "Partitions" + (* Top and bottom are reversed: + Bottom will be All (equations), i.e. contradiction, + Top will be empty set, i.e. no equations. *) let top = E.bot let bot = E.top let is_top = E.is_bot diff --git a/src/domains/queries.ml b/src/domains/queries.ml index b0ede0cfbf..fee44a6b24 100644 --- a/src/domains/queries.ml +++ b/src/domains/queries.ml @@ -10,6 +10,7 @@ module LS = VDQ.LS module TS = SetDomain.ToppedSet (CilType.Typ) (struct let topname = "All" end) module ES = SetDomain.Reverse (SetDomain.ToppedSet (CilType.Exp) (struct let topname = "All" end)) module VS = SetDomain.ToppedSet (CilType.Varinfo) (struct let topname = "All" end) +module NS = SetDomain.ToppedSet (Node) (struct let topname = "All" end) module NFL = WrapperFunctionAnalysis0.NodeFlatLattice module TC = WrapperFunctionAnalysis0.ThreadCreateUniqueCount @@ -62,6 +63,8 @@ type invariant_context = Invariant.context = { } [@@deriving ord, hash] +module YS = SetDomain.ToppedSet (YamlWitnessType.Entry) (struct let topname = "Top" end) + (** GADT for queries with specific result type. *) type _ t = @@ -114,6 +117,7 @@ type _ t = | MustJoinedThreads: ConcDomain.MustThreadSet.t t | ThreadsJoinedCleanly: MustBool.t t | MustProtectedVars: mustprotectedvars -> VS.t t + | MustProtectingLocks: CilType.Varinfo.t -> LockDomain.MustLockset.t t | Invariant: invariant_context -> Invariant.t t | InvariantGlobal: Obj.t -> Invariant.t t (** Argument must be of corresponding [Spec.V.t]. *) | WarnGlobal: Obj.t -> Unit.t t (** Argument must be of corresponding [Spec.V.t]. *) @@ -127,6 +131,9 @@ type _ t = | TmpSpecial: Mval.Exp.t -> ML.t t | MaySignedOverflow: exp -> MayBool.t t | GasExhausted: CilType.Fundec.t -> MustBool.t t + | YamlEntryGlobal: Obj.t * YamlWitnessType.Task.t -> YS.t t (** YAML witness entries for a global unknown ([Obj.t] represents [Spec.V.t]) and YAML witness task. *) + | GhostVarAvailable: WitnessGhostVar.t -> MayBool.t t + | InvariantGlobalNodes: NS.t t (** Nodes where YAML witness flow-insensitive invariants should be emitted as location invariants (if [witness.invariant.flow_insensitive-as] is configured to do so). *) (* [Spec.V.t] argument (as [Obj.t]) could be added, if this should be different for different flow-insensitive invariants. *) type 'a result = 'a @@ -185,6 +192,7 @@ struct | MustJoinedThreads -> (module ConcDomain.MustThreadSet) | ThreadsJoinedCleanly -> (module MustBool) | MustProtectedVars _ -> (module VS) + | MustProtectingLocks _ -> (module LockDomain.MustLockset) | Invariant _ -> (module Invariant) | InvariantGlobal _ -> (module Invariant) | WarnGlobal _ -> (module Unit) @@ -198,6 +206,9 @@ struct | TmpSpecial _ -> (module ML) | MaySignedOverflow _ -> (module MayBool) | GasExhausted _ -> (module MustBool) + | YamlEntryGlobal _ -> (module YS) + | GhostVarAvailable _ -> (module MayBool) + | InvariantGlobalNodes -> (module NS) (** Get bottom result for query. *) let bot (type a) (q: a t): a result = @@ -255,6 +266,7 @@ struct | MustJoinedThreads -> ConcDomain.MustThreadSet.top () | ThreadsJoinedCleanly -> MustBool.top () | MustProtectedVars _ -> VS.top () + | MustProtectingLocks _ -> LockDomain.MustLockset.top () | Invariant _ -> Invariant.top () | InvariantGlobal _ -> Invariant.top () | WarnGlobal _ -> Unit.top () @@ -268,6 +280,9 @@ struct | TmpSpecial _ -> ML.top () | MaySignedOverflow _ -> MayBool.top () | GasExhausted _ -> MustBool.top () + | YamlEntryGlobal _ -> YS.top () + | GhostVarAvailable _ -> MayBool.top () + | InvariantGlobalNodes -> NS.top () end (* The type any_query can't be directly defined in Any as t, @@ -335,6 +350,10 @@ struct | Any (IsAllocVar _) -> 57 | Any (MaySignedOverflow _) -> 58 | Any (GasExhausted _) -> 59 + | Any (YamlEntryGlobal _) -> 60 + | Any (MustProtectingLocks _) -> 61 + | Any (GhostVarAvailable _) -> 62 + | Any InvariantGlobalNodes -> 63 let rec compare a b = let r = Stdlib.compare (order a) (order b) in @@ -382,14 +401,17 @@ struct | Any (WarnGlobal vi1), Any (WarnGlobal vi2) -> Stdlib.compare (Hashtbl.hash vi1) (Hashtbl.hash vi2) | Any (Invariant i1), Any (Invariant i2) -> compare_invariant_context i1 i2 | Any (InvariantGlobal vi1), Any (InvariantGlobal vi2) -> Stdlib.compare (Hashtbl.hash vi1) (Hashtbl.hash vi2) + | Any (YamlEntryGlobal (vi1, task1)), Any (YamlEntryGlobal (vi2, task2)) -> Stdlib.compare (Hashtbl.hash vi1) (Hashtbl.hash vi2) (* TODO: compare task *) | Any (IterSysVars (vq1, vf1)), Any (IterSysVars (vq2, vf2)) -> VarQuery.compare vq1 vq2 (* not comparing fs *) | Any (MutexType m1), Any (MutexType m2) -> Mval.Unit.compare m1 m2 | Any (MustProtectedVars m1), Any (MustProtectedVars m2) -> compare_mustprotectedvars m1 m2 + | Any (MustProtectingLocks g1), Any (MustProtectingLocks g2) -> CilType.Varinfo.compare g1 g2 | Any (MayBeModifiedSinceSetjmp e1), Any (MayBeModifiedSinceSetjmp e2) -> JmpBufDomain.BufferEntry.compare e1 e2 | Any (MustBeSingleThreaded {since_start=s1;}), Any (MustBeSingleThreaded {since_start=s2;}) -> Stdlib.compare s1 s2 | Any (TmpSpecial lv1), Any (TmpSpecial lv2) -> Mval.Exp.compare lv1 lv2 | Any (MaySignedOverflow e1), Any (MaySignedOverflow e2) -> CilType.Exp.compare e1 e2 | Any (GasExhausted f1), Any (GasExhausted f2) -> CilType.Fundec.compare f1 f2 + | Any (GhostVarAvailable v1), Any (GhostVarAvailable v2) -> WitnessGhostVar.compare v1 v2 (* only argumentless queries should remain *) | _, _ -> Stdlib.compare (order a) (order b) @@ -427,12 +449,15 @@ struct | Any (Invariant i) -> hash_invariant_context i | Any (MutexType m) -> Mval.Unit.hash m | Any (InvariantGlobal vi) -> Hashtbl.hash vi + | Any (YamlEntryGlobal (vi, task)) -> Hashtbl.hash vi (* TODO: hash task *) | Any (MustProtectedVars m) -> hash_mustprotectedvars m + | Any (MustProtectingLocks g) -> CilType.Varinfo.hash g | Any (MayBeModifiedSinceSetjmp e) -> JmpBufDomain.BufferEntry.hash e | Any (MustBeSingleThreaded {since_start}) -> Hashtbl.hash since_start | Any (TmpSpecial lv) -> Mval.Exp.hash lv | Any (MaySignedOverflow e) -> CilType.Exp.hash e | Any (GasExhausted f) -> CilType.Fundec.hash f + | Any (GhostVarAvailable v) -> WitnessGhostVar.hash v (* IterSysVars: *) (* - argument is a function and functions cannot be compared in any meaningful way. *) (* - doesn't matter because IterSysVars is always queried from outside of the analysis, so MCP's query caching is not done for it. *) @@ -481,10 +506,12 @@ struct | Any MustJoinedThreads -> Pretty.dprintf "MustJoinedThreads" | Any ThreadsJoinedCleanly -> Pretty.dprintf "ThreadsJoinedCleanly" | Any (MustProtectedVars m) -> Pretty.dprintf "MustProtectedVars _" + | Any (MustProtectingLocks g) -> Pretty.dprintf "MustProtectingLocks _" | Any (Invariant i) -> Pretty.dprintf "Invariant _" | Any (WarnGlobal vi) -> Pretty.dprintf "WarnGlobal _" | Any (IterSysVars _) -> Pretty.dprintf "IterSysVars _" | Any (InvariantGlobal i) -> Pretty.dprintf "InvariantGlobal _" + | Any (YamlEntryGlobal (i, task)) -> Pretty.dprintf "YamlEntryGlobal _" | Any (MutexType (v,o)) -> Pretty.dprintf "MutexType _" | Any (EvalMutexAttr a) -> Pretty.dprintf "EvalMutexAttr _" | Any MayAccessed -> Pretty.dprintf "MayAccessed" @@ -497,6 +524,8 @@ struct | Any (TmpSpecial lv) -> Pretty.dprintf "TmpSpecial %a" Mval.Exp.pretty lv | Any (MaySignedOverflow e) -> Pretty.dprintf "MaySignedOverflow %a" CilType.Exp.pretty e | Any (GasExhausted f) -> Pretty.dprintf "GasExhausted %a" CilType.Fundec.pretty f + | Any (GhostVarAvailable v) -> Pretty.dprintf "GhostVarAvailable %a" WitnessGhostVar.pretty v + | Any InvariantGlobalNodes -> Pretty.dprintf "InvariantGlobalNodes" end let to_value_domain_ask (ask: ask) = diff --git a/src/dune b/src/dune index a307a237ae..10996e7ee8 100644 --- a/src/dune +++ b/src/dune @@ -88,7 +88,7 @@ (public_names goblint) (modes byte native) ; https://dune.readthedocs.io/en/stable/dune-files.html#linking-modes (modules goblint) - (libraries goblint.lib goblint.sites.dune goblint.build-info.dune goblint_std) + (libraries goblint.lib goblint_std) (preprocess (pps ppx_deriving.std ppx_deriving_hash ppx_deriving_yojson)) (flags :standard -linkall -open Goblint_std) ) @@ -96,7 +96,7 @@ (executable (name privPrecCompare) (modules privPrecCompare) - (libraries goblint.lib goblint.sites.dune goblint.build-info.dune goblint_std) + (libraries goblint.lib goblint_std) (preprocess (pps ppx_deriving.std ppx_deriving_hash ppx_deriving_yojson)) (flags :standard -linkall -open Goblint_std) ) @@ -104,7 +104,7 @@ (executable (name apronPrecCompare) (modules apronPrecCompare) - (libraries goblint.lib goblint.sites.dune goblint.build-info.dune goblint_std) + (libraries goblint.lib goblint_std) (preprocess (pps ppx_deriving.std ppx_deriving_hash ppx_deriving_yojson)) (flags :standard -linkall -open Goblint_std) ) @@ -112,7 +112,7 @@ (executable (name messagesCompare) (modules messagesCompare) - (libraries goblint.lib goblint.sites.dune goblint.build-info.dune goblint_std) + (libraries goblint.lib goblint_std) (preprocess (pps ppx_deriving.std ppx_deriving_hash ppx_deriving_yojson)) (flags :standard -linkall -open Goblint_std) ) diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index d8fd408151..415fb21605 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -109,6 +109,7 @@ module MutexAnalysis = MutexAnalysis module MayLocks = MayLocks module SymbLocks = SymbLocks module Deadlock = Deadlock +module MutexGhosts = MutexGhosts (** {3 Threads} @@ -351,6 +352,7 @@ module Graphml = Graphml module YamlWitness = YamlWitness module YamlWitnessType = YamlWitnessType +module WitnessGhost = WitnessGhost (** {3 Violation} diff --git a/src/index.mld b/src/index.mld index f0d63a0fc7..a2ef15482e 100644 --- a/src/index.mld +++ b/src/index.mld @@ -44,15 +44,9 @@ The following libraries provide [goblint] package metadata for executables. {2 Library goblint.build-info} {!modules:Goblint_build_info} -This library is virtual and has the following implementations -- goblint.build-info.dune for native executables, -- goblint.build-info.js for js_of_ocaml executables. {2 Library goblint.sites} {!modules:Goblint_sites} -This library is virtual and has the following implementations -- goblint.sites.dune for native executables, -- goblint.sites.js for js_of_ocaml executables. {1 Independent utilities} diff --git a/src/lifters/longjmpLifter.ml b/src/lifters/longjmpLifter.ml index 1a28085abe..a093f8c703 100644 --- a/src/lifters/longjmpLifter.ml +++ b/src/lifters/longjmpLifter.ml @@ -66,6 +66,14 @@ struct | _ -> Queries.Result.top q end + | YamlEntryGlobal (g, task) -> + let g: V.t = Obj.obj g in + begin match g with + | `Left g -> + S.query (conv ctx) (YamlEntryGlobal (Obj.repr g, task)) + | _ -> + Queries.Result.top q + end | IterSysVars (vq, vf) -> (* vars for S *) let vf' x = vf (Obj.repr (V.s (Obj.obj x))) in diff --git a/src/lifters/recursionTermLifter.ml b/src/lifters/recursionTermLifter.ml index 2d9f45de60..37522305b9 100644 --- a/src/lifters/recursionTermLifter.ml +++ b/src/lifters/recursionTermLifter.ml @@ -106,6 +106,14 @@ struct | `Right v -> Queries.Result.top q end + | YamlEntryGlobal (v, task) -> + let v: V.t = Obj.obj v in + begin match v with + | `Left v -> + S.query (conv ctx) (YamlEntryGlobal (Obj.repr v, task)) + | `Right v -> + Queries.Result.top q + end | _ -> S.query (conv ctx) q let branch ctx = S.branch (conv ctx) diff --git a/src/lifters/specLifters.ml b/src/lifters/specLifters.ml index e8292bedc0..39c7799395 100644 --- a/src/lifters/specLifters.ml +++ b/src/lifters/specLifters.ml @@ -737,6 +737,14 @@ struct | `Right g -> Queries.Result.top q end + | YamlEntryGlobal (g, task) -> + let g: V.t = Obj.obj g in + begin match g with + | `Left g -> + S.query (conv ctx) (YamlEntryGlobal (Obj.repr g, task)) + | `Right g -> + Queries.Result.top q + end | IterSysVars (vq, vf) -> (* vars for S *) let vf' x = vf (Obj.repr (V.s (Obj.obj x))) in diff --git a/src/sites/dune b/src/sites/dune index d8663e37fe..6de3a5a32a 100644 --- a/src/sites/dune +++ b/src/sites/dune @@ -1,12 +1,10 @@ (include_subdirs no) -; virtual library to allow js build (for gobview) without dune-site -; dune-site seems to be incompatible with js_of_ocaml -; File "gobview/src/.App.eobjs/dune_site_data.ml-gen", line 1: -; Error: Could not find the .cmi file for interface -; gobview/src/.App.eobjs/dune_site_data.ml-gen. (library (name goblint_sites) (public_name goblint.sites) - (virtual_modules goblint_sites) - (libraries fpath)) + (libraries dune-site fpath)) + +(generate_sites_module + (module dunesite) + (sites goblint)) diff --git a/src/sites/sites_dune/goblint_sites.ml b/src/sites/goblint_sites.ml similarity index 100% rename from src/sites/sites_dune/goblint_sites.ml rename to src/sites/goblint_sites.ml diff --git a/src/sites/sites_dune/dune b/src/sites/sites_dune/dune deleted file mode 100644 index b7f90a8892..0000000000 --- a/src/sites/sites_dune/dune +++ /dev/null @@ -1,12 +0,0 @@ -; goblint.sites implementation which properly uses dune-site -(library - (name goblint_sites_dune) - (public_name goblint.sites.dune) - (implements goblint.sites) - (modules goblint_sites dunesite) - (private_modules dunesite) ; must also be in modules - (libraries dune-site)) - -(generate_sites_module - (module dunesite) - (sites goblint)) diff --git a/src/sites/sites_js/dune b/src/sites/sites_js/dune deleted file mode 100644 index 4e20871974..0000000000 --- a/src/sites/sites_js/dune +++ /dev/null @@ -1,6 +0,0 @@ -; goblint.sites implementation which works with js_of_ocaml and doesn't use dune-site -(library - (name goblint_sites_js) - (public_name goblint.sites.js) - (implements goblint.sites) - (modules goblint_sites)) diff --git a/src/sites/sites_js/goblint_sites.ml b/src/sites/sites_js/goblint_sites.ml deleted file mode 100644 index 3a7b353064..0000000000 --- a/src/sites/sites_js/goblint_sites.ml +++ /dev/null @@ -1,6 +0,0 @@ -let lib = [] -let lib_stub_include = [] -let lib_stub_src = [] -let lib_runtime_include = [] -let lib_runtime_src = [] -let conf = [] diff --git a/src/solver/sLR.ml b/src/solver/sLR.ml index 3b46f36f5e..03ba9307aa 100644 --- a/src/solver/sLR.ml +++ b/src/solver/sLR.ml @@ -66,7 +66,7 @@ module SLR3 = if tracing then trace "sol" "Contrib:%a" S.Dom.pretty tmp; let tmp = if wpx then - if HM.mem globals x then S.Dom.widen old tmp + if HM.mem globals x then S.Dom.widen old (S.Dom.join old tmp) else box old tmp else tmp in @@ -527,7 +527,7 @@ let _ = Selector.add_solver ("widen2", (module PostSolver.EqIncrSolverFromEqSolver (W2))); Selector.add_solver ("widen3", (module PostSolver.EqIncrSolverFromEqSolver (W3))); let module S2 = TwoPhased (struct let ver = 1 end) in - Selector.add_solver ("two", (module PostSolver.EqIncrSolverFromEqSolver (S2))); + (* Selector.add_solver ("two", (module PostSolver.EqIncrSolverFromEqSolver (S2))); (* TODO: broken even on 00-sanity/01-assert *) *) let module S1 = Make (struct let ver = 1 end) in Selector.add_solver ("new", (module PostSolver.EqIncrSolverFromEqSolver (S1))); Selector.add_solver ("slr+", (module PostSolver.EqIncrSolverFromEqSolver (S1))) diff --git a/src/solver/topDown_space_cache_term.ml b/src/solver/topDown_space_cache_term.ml index 0022756a31..df44c376e1 100644 --- a/src/solver/topDown_space_cache_term.ml +++ b/src/solver/topDown_space_cache_term.ml @@ -170,7 +170,7 @@ module WP = ) in (* restore values for non-widening-points *) - if GobConfig.get_bool "solvers.wp.restore" then ( + if GobConfig.get_bool "solvers.td3.space_restore" then ( Logs.debug "Restoring missing values."; let restore () = let get x = diff --git a/src/solver/topDown_term.ml b/src/solver/topDown_term.ml index 9d89a42898..5560c50f4f 100644 --- a/src/solver/topDown_term.ml +++ b/src/solver/topDown_term.ml @@ -24,8 +24,8 @@ module WP = let stable = HM.create 10 in let infl = HM.create 10 in (* y -> xs *) let called = HM.create 10 in - let rho = HM.create 10 in - let rho' = HM.create 10 in + let rho = HM.create 10 in (* rho for right-hand side values *) + let rho' = HM.create 10 in (* rho for start and side effect values *) let wpoint = HM.create 10 in let add_infl y x = @@ -85,7 +85,7 @@ module WP = and side y d = let old = try HM.find rho' y with Not_found -> S.Dom.bot () in if not (S.Dom.leq d old) then ( - HM.replace rho' y (S.Dom.widen old d); + HM.replace rho' y (S.Dom.widen old (S.Dom.join old d)); HM.remove stable y; init y; solve y Widen; @@ -101,7 +101,7 @@ module WP = let set_start (x,d) = if tracing then trace "sol2" "set_start %a ## %a" S.Var.pretty_trace x S.Dom.pretty d; init x; - HM.replace rho x d; + HM.replace rho' x d; solve x Widen in diff --git a/src/util/backtrace/goblint_backtrace.ml b/src/util/backtrace/goblint_backtrace.ml index 513753bddb..21d150a470 100644 --- a/src/util/backtrace/goblint_backtrace.ml +++ b/src/util/backtrace/goblint_backtrace.ml @@ -76,12 +76,19 @@ let print_marktrace oc e = Printf.fprintf oc "Marked with %s\n" (mark_to_string m) ) ms +let print_innermost_mark oc e = + match find_marks e with + | m :: _ -> Printf.fprintf oc "Marked with %s\n" (mark_to_string m) + | [] -> () + let () = Printexc.set_uncaught_exception_handler (fun e bt -> (* Copied & modified from Printexc.default_uncaught_exception_handler. *) Printf.eprintf "Fatal error: exception %s\n" (Printexc.to_string e); (* nosemgrep: print-not-logging *) if Printexc.backtrace_status () then - print_marktrace stderr e; + print_marktrace stderr e + else + print_innermost_mark stderr e; Printexc.print_raw_backtrace stderr bt; flush stderr ) diff --git a/src/util/backtrace/goblint_backtrace.mli b/src/util/backtrace/goblint_backtrace.mli index e53bfd826a..ee7052122e 100644 --- a/src/util/backtrace/goblint_backtrace.mli +++ b/src/util/backtrace/goblint_backtrace.mli @@ -32,5 +32,10 @@ val print_marktrace: out_channel -> exn -> unit Used by default for uncaught exceptions. *) +val print_innermost_mark: out_channel -> exn -> unit +(** Print innermost mark of an exception. + + Used by default for uncaught exceptions. *) + val find_marks: exn -> mark list (** Find all marks of an exception. *) diff --git a/src/util/library/libraryFunctions.ml b/src/util/library/libraryFunctions.ml index 76c09c36a2..6643b58eef 100644 --- a/src/util/library/libraryFunctions.ml +++ b/src/util/library/libraryFunctions.ml @@ -1097,6 +1097,7 @@ let svcomp_descs_list: (string * LibraryDesc.t) list = LibraryDsl.[ ("__VERIFIER_nondet_int", unknown []); (* declare invalidate actions to prevent invalidating globals when extern in regression tests *) ("__VERIFIER_nondet_size_t", unknown []); (* cannot give it in sv-comp.c without including stdlib or similar *) ("__VERIFIER_assert", special [__ "exp" []] @@ fun exp -> Assert { exp; check = true; refine = get_bool "sem.assert.refine" }); (* only used if definition missing (e.g. in evalAssert transformed output) or extraspecial *) + ("reach_error", special [] @@ Abort); (* only used if definition missing (e.g. in evalAssert transformed output) or extraspecial *) ] [@@coverage off] diff --git a/src/witness/witnessGhost.ml b/src/witness/witnessGhost.ml new file mode 100644 index 0000000000..3eaa8ef69b --- /dev/null +++ b/src/witness/witnessGhost.ml @@ -0,0 +1,32 @@ +(** Ghost variables for YAML witnesses. *) + +let enabled () = + YamlWitness.entry_type_enabled YamlWitnessType.GhostInstrumentation.entry_type + +module Var = WitnessGhostVar + +include Var + +module Map = RichVarinfo.BiVarinfoMap.Make (Var) + +include Map + +let variable' x = + let variable = name_varinfo x in + let type_ = String.trim (CilType.Typ.show (typ x)) in (* CIL printer puts space at the end of some types *) + let initial = CilType.Exp.show (initial x) in + YamlWitness.Entry.ghost_variable' ~variable ~type_ ~initial + +let update' x e = + let variable = name_varinfo x in + let expression = CilType.Exp.show e in + YamlWitness.Entry.ghost_update' ~variable ~expression + +let location_update' ~node ~updates = + let loc = Node.location node in + let location_function = (Node.find_fundec node).svar.vname in + let location = YamlWitness.Entry.location ~location:loc ~location_function in + YamlWitness.Entry.ghost_location_update' ~location ~updates + +let instrumentation_entry ~task ~variables ~location_updates = + YamlWitness.Entry.ghost_instrumentation ~task ~variables ~location_updates diff --git a/src/witness/witnessGhostVar.ml b/src/witness/witnessGhostVar.ml new file mode 100644 index 0000000000..0d71909ba0 --- /dev/null +++ b/src/witness/witnessGhostVar.ml @@ -0,0 +1,43 @@ +(** Ghost variables for YAML witnesses. *) + +type t = + | Locked of LockDomain.MustLock.t + | Multithreaded +[@@deriving eq, ord, hash] + +let name_varinfo = function + | Locked (v, os) -> + let name = + if CilType.Varinfo.equal v LibraryFunctions.verifier_atomic_var then + invalid_arg "__VERIFIER_atomic" + else + if RichVarinfo.BiVarinfoMap.Collection.mem_varinfo v then + Printf.sprintf "alloc_%s%d" (if v.vid < 0 then "m" else "") (abs v.vid) (* turn minus into valid C name *) + else + Basetype.Variables.show v + in + let rec offs: Offset.Z.t -> string = function + | `NoOffset -> "" + | `Field (f, os') -> "_" ^ f.fname ^ offs os' + | `Index (i, os') -> + assert Z.Compare.(i >= Z.zero); "_" ^ Z.to_string i + in + name ^ offs os ^ "_locked" + | Multithreaded -> "multithreaded" + +let show = name_varinfo + +include Printable.SimpleShow (struct + type nonrec t = t + let show = show + end) + +let describe_varinfo _ _ = "" + +let typ = function + | Locked _ + | Multithreaded -> GoblintCil.intType + +let initial = function + | Locked _ + | Multithreaded -> GoblintCil.zero diff --git a/src/witness/yamlWitness.ml b/src/witness/yamlWitness.ml index 06e355068e..9d04b597fa 100644 --- a/src/witness/yamlWitness.ml +++ b/src/witness/yamlWitness.ml @@ -148,6 +148,35 @@ struct }; metadata = metadata (); } + + let ghost_variable' ~variable ~type_ ~(initial): GhostInstrumentation.Variable.t = { + name = variable; + scope = "global"; + type_; + initial = { + value = initial; + format = "c_expression"; + }; + } + + let ghost_update' ~variable ~(expression): GhostInstrumentation.Update.t = { + variable; + value = expression; + format = "c_expression"; + } + + let ghost_location_update' ~location ~(updates): GhostInstrumentation.LocationUpdate.t = { + location; + updates; + } + + let ghost_instrumentation ~task ~variables ~(location_updates): Entry.t = { + entry_type = GhostInstrumentation { + ghost_variables = variables; + ghost_updates = location_updates; + }; + metadata = metadata ~task (); + } end let yaml_entries_to_file yaml_entries file = @@ -317,14 +346,34 @@ struct entries in + let invariant_global_nodes = lazy (R.ask_global InvariantGlobalNodes) in + + let fold_flow_insensitive_as_location ~inv f acc = + (* Currently same invariants (from InvariantGlobal query) for all nodes (from InvariantGlobalNodes query). + The alternative would be querying InvariantGlobal per local unknown when looping over them to generate location invariants. + See: https://github.com/goblint/analyzer/pull/1394#discussion_r1698149514. *) + let invs = WitnessUtil.InvariantExp.process_exp inv in + Queries.NS.fold (fun n acc -> + let fundec = Node.find_fundec n in + match WitnessInvariant.location_location n with (* Not just using Node.location because it returns expression location which may be invalid for location invariant (e.g. inside conditional). *) + | Some loc -> + let location_function = fundec.svar.vname in + let location = Entry.location ~location:loc ~location_function in + List.fold_left (fun acc inv -> + f ~location ~inv acc + ) acc invs + | None -> acc + ) (Lazy.force invariant_global_nodes) acc + in + (* Generate flow-insensitive invariants *) let entries = if entry_type_enabled YamlWitnessType.FlowInsensitiveInvariant.entry_type then ( GHT.fold (fun g v acc -> match g with - | `Left g -> (* Spec global *) - begin match R.ask_global (InvariantGlobal (Obj.repr g)) with - | `Lifted inv -> + | `Left g -> (* global unknown from analysis Spec *) + begin match R.ask_global (InvariantGlobal (Obj.repr g)), GobConfig.get_string "witness.invariant.flow_insensitive-as" with + | `Lifted inv, "flow_insensitive_invariant" -> let invs = WitnessUtil.InvariantExp.process_exp inv in List.fold_left (fun acc inv -> let invariant = Entry.invariant (CilType.Exp.show inv) in @@ -332,10 +381,18 @@ struct incr cnt_flow_insensitive_invariant; entry :: acc ) acc invs - | `Bot | `Top -> (* global bot might only be possible for alloc variables, if at all, so emit nothing *) + | `Lifted inv, "location_invariant" -> + fold_flow_insensitive_as_location ~inv (fun ~location ~inv acc -> + let invariant = Entry.invariant (CilType.Exp.show inv) in + let entry = Entry.location_invariant ~task ~location ~invariant in + incr cnt_location_invariant; + entry :: acc + ) acc + | `Lifted _, _ + | `Bot, _ | `Top, _ -> (* global bot might only be possible for alloc variables, if at all, so emit nothing *) acc end - | `Right _ -> (* contexts global *) + | `Right _ -> (* global unknown for FromSpec contexts *) acc ) gh entries ) @@ -343,6 +400,33 @@ struct entries in + (* Generate flow-insensitive entries (ghost instrumentation) *) + let entries = + if entry_type_enabled YamlWitnessType.GhostInstrumentation.entry_type then ( + (* TODO: only at most one ghost_instrumentation entry can ever be produced, so this fold and deduplication is overkill *) + let module EntrySet = Queries.YS in + fst @@ GHT.fold (fun g v accs -> + match g with + | `Left g -> (* global unknown from analysis Spec *) + begin match R.ask_global (YamlEntryGlobal (Obj.repr g, task)) with + | `Lifted _ as inv -> + Queries.YS.fold (fun entry (acc, acc') -> + if EntrySet.mem entry acc' then (* deduplicate only with other global entries because local ones have different locations anyway *) + accs + else + (entry :: acc, EntrySet.add entry acc') + ) inv accs + | `Top -> + accs + end + | `Right _ -> (* global unknown for FromSpec contexts *) + accs + ) gh (entries, EntrySet.empty ()) + ) + else + entries + in + (* Generate precondition loop invariants. We do this in three steps: 1. Collect contexts for each function @@ -445,12 +529,12 @@ struct (* Generate invariant set *) let entries = - if entry_type_enabled YamlWitnessType.InvariantSet.entry_type then ( + if entry_type_enabled YamlWitnessType.InvariantSet.entry_type || entry_type_enabled YamlWitnessType.FlowInsensitiveInvariant.entry_type && GobConfig.get_string "witness.invariant.flow_insensitive-as" = "invariant_set-location_invariant" then ( let invariants = [] in (* Generate location invariants *) let invariants = - if invariant_type_enabled YamlWitnessType.InvariantSet.LocationInvariant.invariant_type then ( + if entry_type_enabled YamlWitnessType.InvariantSet.entry_type && invariant_type_enabled YamlWitnessType.InvariantSet.LocationInvariant.invariant_type then ( LH.fold (fun loc ns acc -> let inv = List.fold_left (fun acc n -> let local = try NH.find (Lazy.force nh) n with Not_found -> Spec.D.bot () in @@ -480,7 +564,7 @@ struct (* Generate loop invariants *) let invariants = - if invariant_type_enabled YamlWitnessType.InvariantSet.LoopInvariant.invariant_type then ( + if entry_type_enabled YamlWitnessType.InvariantSet.entry_type && invariant_type_enabled YamlWitnessType.InvariantSet.LoopInvariant.invariant_type then ( LH.fold (fun loc ns acc -> if WitnessInvariant.emit_loop_head then ( (* TODO: remove double condition? *) let inv = List.fold_left (fun acc n -> @@ -511,6 +595,31 @@ struct invariants in + (* Generate flow-insensitive invariants as location invariants *) + let invariants = + if entry_type_enabled YamlWitnessType.FlowInsensitiveInvariant.entry_type && GobConfig.get_string "witness.invariant.flow_insensitive-as" = "invariant_set-location_invariant" then ( + GHT.fold (fun g v acc -> + match g with + | `Left g -> (* global unknown from analysis Spec *) + begin match R.ask_global (InvariantGlobal (Obj.repr g)) with + | `Lifted inv -> + fold_flow_insensitive_as_location ~inv (fun ~location ~inv acc -> + let invariant = CilType.Exp.show inv in + let invariant = Entry.location_invariant' ~location ~invariant in + incr cnt_location_invariant; + invariant :: acc + ) acc + | `Bot | `Top -> (* global bot might only be possible for alloc variables, if at all, so emit nothing *) + acc + end + | `Right _ -> (* global unknown for FromSpec contexts *) + acc + ) gh invariants + ) + else + invariants + in + let invariants = List.rev invariants in let entry = Entry.invariant_set ~task ~invariants in entry :: entries @@ -852,7 +961,7 @@ struct None | _ -> incr cnt_unsupported; - M.info_noloc ~category:Witness "cannot validate entry of type %s" target_type; + M.warn_noloc ~category:Witness "cannot validate entry of type %s" target_type; None in @@ -864,7 +973,7 @@ struct Option.to_list yaml_certificate_entry @ yaml_entry :: yaml_entries' | Error (`Msg e) -> incr cnt_error; - M.info_noloc ~category:Witness "couldn't parse entry: %s" e; + M.error_noloc ~category:Witness "couldn't parse entry: %s" e; yaml_entry :: yaml_entries' ) [] yaml_entries in diff --git a/src/witness/yamlWitnessType.ml b/src/witness/yamlWitnessType.ml index c77fadad4c..7a57197a6f 100644 --- a/src/witness/yamlWitnessType.ml +++ b/src/witness/yamlWitnessType.ml @@ -9,6 +9,7 @@ struct command_line: string option; (* TODO: description *) } + [@@deriving eq, ord, hash] let to_yaml {name; version; command_line} = `O ([ @@ -39,6 +40,7 @@ struct language: string; specification: string option; } + [@@deriving eq, ord, hash] let to_yaml {input_files; input_file_hashes; data_model; language; specification} = `O ([ @@ -78,6 +80,7 @@ struct producer: Producer.t; task: Task.t option; } + [@@deriving eq, ord, hash] let to_yaml {format_version; uuid; creation_time; producer; task} = `O ([ @@ -111,7 +114,7 @@ struct column: int option; function_: string option; } - [@@deriving ord] + [@@deriving eq, ord, hash] let to_yaml {file_name; file_hash; line; column; function_} = `O ([ @@ -155,7 +158,7 @@ struct type_: string; format: string; } - [@@deriving ord] + [@@deriving eq, ord, hash] let to_yaml {string; type_; format} = `O [ @@ -178,7 +181,7 @@ struct location: Location.t; loop_invariant: Invariant.t; } - [@@deriving ord] + [@@deriving eq, ord, hash] let entry_type = "loop_invariant" @@ -201,7 +204,7 @@ struct location: Location.t; location_invariant: Invariant.t; } - [@@deriving ord] + [@@deriving eq, ord, hash] let entry_type = "location_invariant" @@ -223,7 +226,7 @@ struct type t = { flow_insensitive_invariant: Invariant.t; } - [@@deriving ord] + [@@deriving eq, ord, hash] let entry_type = "flow_insensitive_invariant" @@ -245,7 +248,7 @@ struct loop_invariant: Invariant.t; precondition: Invariant.t; } - [@@deriving ord] + [@@deriving eq, ord, hash] let entry_type = "precondition_loop_invariant" @@ -273,7 +276,7 @@ struct value: string; format: string; } - [@@deriving ord] + [@@deriving eq, ord, hash] let invariant_type = "loop_invariant" @@ -305,7 +308,7 @@ struct type t = | LocationInvariant of LocationInvariant.t | LoopInvariant of LoopInvariant.t - [@@deriving ord] + [@@deriving eq, ord, hash] let invariant_type = function | LocationInvariant _ -> LocationInvariant.invariant_type @@ -333,7 +336,7 @@ struct type t = { invariant_type: InvariantType.t; } - [@@deriving ord] + [@@deriving eq, ord, hash] let to_yaml {invariant_type} = `O [ @@ -352,7 +355,7 @@ struct type t = { content: Invariant.t list; } - [@@deriving ord] + [@@deriving eq, ord, hash] let entry_type = "invariant_set" @@ -372,7 +375,7 @@ struct type_: string; file_hash: string; } - [@@deriving ord] + [@@deriving eq, ord, hash] let to_yaml {uuid; type_; file_hash} = `O [ @@ -396,7 +399,7 @@ struct type_: string; format: string; } - [@@deriving ord] + [@@deriving eq, ord, hash] let to_yaml {string; type_; format} = `O [ @@ -419,7 +422,7 @@ struct target: Target.t; certification: Certification.t; } - [@@deriving ord] + [@@deriving eq, ord, hash] let entry_type = "loop_invariant_certificate" @@ -453,7 +456,7 @@ struct type t = | String of string | Int of int (* Why doesn't format consider ints (for switch branches) as strings here, like everywhere else? *) - [@@deriving ord] + [@@deriving eq, ord, hash] let to_yaml = function | String s -> GobYaml.string s @@ -471,7 +474,7 @@ struct value: Value.t; format: string option; } - [@@deriving ord] + [@@deriving eq, ord, hash] let to_yaml {value; format} = `O ([ @@ -498,7 +501,7 @@ struct action: string; constraint_: Constraint.t; } - [@@deriving ord] + [@@deriving eq, ord, hash] let waypoint_type = "assumption" @@ -523,7 +526,7 @@ struct location: Location.t; action: string; } - [@@deriving ord] + [@@deriving eq, ord, hash] let waypoint_type = "target" @@ -570,7 +573,7 @@ struct | FunctionEnter of FunctionEnter.t | FunctionReturn of FunctionReturn.t | Branching of Branching.t - [@@deriving ord] + [@@deriving eq, ord, hash] let waypoint_type = function | Assumption _ -> Assumption.waypoint_type @@ -613,7 +616,7 @@ struct type t = { waypoint_type: WaypointType.t; } - [@@deriving ord] + [@@deriving eq, ord, hash] let to_yaml {waypoint_type} = `O [ @@ -634,7 +637,7 @@ struct type t = { segment: Waypoint.t list; } - [@@deriving ord] + [@@deriving eq, ord, hash] let to_yaml {segment} = `O [("segment", `A (List.map Waypoint.to_yaml segment))] @@ -648,7 +651,7 @@ struct type t = { content: Segment.t list; } - [@@deriving ord] + [@@deriving eq, ord, hash] let entry_type = "violation_sequence" @@ -661,6 +664,126 @@ struct {content} end +module GhostInstrumentation = +struct + + module Initial = + struct + type t = { + value: string; + format: string; + } + [@@deriving eq, ord, hash] + + let to_yaml {value; format} = + `O [ + ("value", `String value); + ("format", `String format); + ] + + let of_yaml y = + let open GobYaml in + let+ value = y |> find "value" >>= to_string + and+ format = y |> find "format" >>= to_string in + {value; format} + end + + module Variable = + struct + type t = { + name: string; + scope: string; + type_: string; + initial: Initial.t; + } + [@@deriving eq, ord, hash] + + let to_yaml {name; scope; type_; initial} = + `O [ + ("name", `String name); + ("scope", `String scope); + ("type", `String type_); + ("initial", Initial.to_yaml initial); + ] + + let of_yaml y = + let open GobYaml in + let+ name = y |> find "name" >>= to_string + and+ scope = y |> find "scope" >>= to_string + and+ type_ = y |> find "type" >>= to_string + and+ initial = y |> find "initial" >>= Initial.of_yaml in + {name; scope; type_; initial} + end + + module Update = + struct + type t = { + variable: string; + value: string; + format: string; + } + [@@deriving eq, ord, hash] + + let to_yaml {variable; value; format} = + `O [ + ("variable", `String variable); + ("value", `String value); + ("format", `String format); + ] + + let of_yaml y = + let open GobYaml in + let+ variable = y |> find "variable" >>= to_string + and+ value = y |> find "value" >>= to_string + and+ format = y |> find "format" >>= to_string in + {variable; value; format} + end + + module LocationUpdate = + struct + type t = { + location: Location.t; + updates: Update.t list; + } + [@@deriving eq, ord, hash] + + let to_yaml {location; updates} = + `O [ + ("location", Location.to_yaml location); + ("updates", `A (List.map Update.to_yaml updates)); + ] + + let of_yaml y = + let open GobYaml in + let+ location = y |> find "location" >>= Location.of_yaml + and+ updates = y |> find "updates" >>= list >>= list_map Update.of_yaml in + {location; updates} + end + + type t = { + ghost_variables: Variable.t list; + ghost_updates: LocationUpdate.t list; + } + [@@deriving eq, ord, hash] + + let entry_type = "ghost_instrumentation" + + let to_yaml' {ghost_variables; ghost_updates} = + [("content", + `O [ + ("ghost_variables", `A (List.map Variable.to_yaml ghost_variables)); + ("ghost_updates", `A (List.map LocationUpdate.to_yaml ghost_updates)); + ]) + ] + + let of_yaml y = + let open GobYaml in + let* content = y |> find "content" in + let+ ghost_variables = content |> find "ghost_variables" >>= list >>= list_map Variable.of_yaml + and+ ghost_updates = content |> find "ghost_updates" >>= list >>= list_map LocationUpdate.of_yaml in + {ghost_variables; ghost_updates} +end + (* TODO: could maybe use GADT, but adds ugly existential layer to entry type pattern matching *) module EntryType = struct @@ -673,7 +796,8 @@ struct | PreconditionLoopInvariantCertificate of PreconditionLoopInvariantCertificate.t | InvariantSet of InvariantSet.t | ViolationSequence of ViolationSequence.t - [@@deriving ord] + | GhostInstrumentation of GhostInstrumentation.t + [@@deriving eq, ord, hash] let entry_type = function | LocationInvariant _ -> LocationInvariant.entry_type @@ -684,6 +808,7 @@ struct | PreconditionLoopInvariantCertificate _ -> PreconditionLoopInvariantCertificate.entry_type | InvariantSet _ -> InvariantSet.entry_type | ViolationSequence _ -> ViolationSequence.entry_type + | GhostInstrumentation _ -> GhostInstrumentation.entry_type let to_yaml' = function | LocationInvariant x -> LocationInvariant.to_yaml' x @@ -694,6 +819,7 @@ struct | PreconditionLoopInvariantCertificate x -> PreconditionLoopInvariantCertificate.to_yaml' x | InvariantSet x -> InvariantSet.to_yaml' x | ViolationSequence x -> ViolationSequence.to_yaml' x + | GhostInstrumentation x -> GhostInstrumentation.to_yaml' x let of_yaml y = let open GobYaml in @@ -722,16 +848,24 @@ struct else if entry_type = ViolationSequence.entry_type then let+ x = y |> ViolationSequence.of_yaml in ViolationSequence x + else if entry_type = GhostInstrumentation.entry_type then + let+ x = y |> GhostInstrumentation.of_yaml in + GhostInstrumentation x else - Error (`Msg "entry_type") + Error (`Msg ("entry_type " ^ entry_type)) end module Entry = struct + include Printable.StdLeaf + type t = { entry_type: EntryType.t; - metadata: Metadata.t; + metadata: Metadata.t [@equal fun _ _ -> true] [@compare fun _ _ -> 0] [@hash fun _ -> 1]; } + [@@deriving eq, ord, hash] + + let name () = "YAML entry" let to_yaml {entry_type; metadata} = `O ([ @@ -744,4 +878,10 @@ struct let+ metadata = y |> find "metadata" >>= Metadata.of_yaml and+ entry_type = y |> EntryType.of_yaml in {entry_type; metadata} + + let pp ppf x = Yaml.pp ppf (to_yaml x) + include Printable.SimpleFormat (struct + type nonrec t = t + let pp = pp + end) end diff --git a/tests/regression/00-sanity/01-assert.t b/tests/regression/00-sanity/01-assert.t index 9142f805f9..9b3b55f530 100644 --- a/tests/regression/00-sanity/01-assert.t +++ b/tests/regression/00-sanity/01-assert.t @@ -9,3 +9,275 @@ live: 7 dead: 2 total lines: 9 + + +Test ancient solvers: + + $ goblint --enable warn.deterministic --set solver WL 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + $ goblint --enable warn.deterministic --set solver effectWConEq 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + +Test topdown solvers: + + $ goblint --enable warn.deterministic --set solver topdown_deprecated 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + $ goblint --enable warn.deterministic --set solver topdown 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + $ goblint --enable warn.deterministic --set solver topdown_term 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + $ goblint --enable warn.deterministic --set solver topdown_space_cache_term 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + $ goblint --enable warn.deterministic --set solver td3 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + +Test SLR solvers: + + $ goblint --enable warn.deterministic --set solver widen1 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + $ goblint --enable warn.deterministic --set solver widen2 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + $ goblint --enable warn.deterministic --set solver widen3 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + $ goblint --enable warn.deterministic --set solver new 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + $ goblint --enable warn.deterministic --set solver slr+ 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + $ goblint --enable warn.deterministic --set solver slr1 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + $ goblint --enable warn.deterministic --set solver slr2 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + $ goblint --enable warn.deterministic --set solver slr3 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + $ goblint --enable warn.deterministic --set solver slr4 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + $ goblint --enable warn.deterministic --set solver slr1p 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + $ goblint --enable warn.deterministic --set solver slr2p 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + $ goblint --enable warn.deterministic --set solver slr3p 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + $ goblint --enable warn.deterministic --set solver slr4p 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + $ goblint --enable warn.deterministic --set solver slr3t 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 + + $ goblint --enable warn.deterministic --set solver slr3tp 01-assert.c + [Error][Assert] Assertion "fail" will fail. (01-assert.c:12:3-12:25) + [Warning][Assert] Assertion "unknown == 4" is unknown. (01-assert.c:11:3-11:33) + [Success][Assert] Assertion "success" will succeed (01-assert.c:10:3-10:28) + [Warning][Deadcode] Function 'main' does not return + [Warning][Deadcode] Function 'main' has dead code: + on lines 13..14 (01-assert.c:13-14) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 7 + dead: 2 + total lines: 9 diff --git a/tests/regression/03-practical/21-pfscan_combine_minimal.c b/tests/regression/03-practical/21-pfscan_combine_minimal.c index abdef0627b..b8fc7948b2 100644 --- a/tests/regression/03-practical/21-pfscan_combine_minimal.c +++ b/tests/regression/03-practical/21-pfscan_combine_minimal.c @@ -18,7 +18,7 @@ int pqueue_init(PQUEUE *qp) void pqueue_close(PQUEUE *qp ) { - pthread_mutex_lock(& qp->mtx); + pthread_mutex_lock(& qp->mtx); // TODO (OSX): WARN (must double locking) qp->closed = 1; pthread_mutex_unlock(& qp->mtx); return; @@ -26,7 +26,7 @@ void pqueue_close(PQUEUE *qp ) int pqueue_put(PQUEUE *qp) { - pthread_mutex_lock(& qp->mtx); + pthread_mutex_lock(& qp->mtx); // TODO (OSX): WARN (must double locking) if (qp->closed) { // pfscan actually has a bug and is missing the following unlock at early return // pthread_mutex_unlock(& qp->mtx); diff --git a/tests/regression/04-mutex/32-allfuns.c b/tests/regression/04-mutex/32-allfuns.c index b59c487c53..e6b88e47ce 100644 --- a/tests/regression/04-mutex/32-allfuns.c +++ b/tests/regression/04-mutex/32-allfuns.c @@ -8,11 +8,11 @@ pthread_mutex_t B_mutex = PTHREAD_MUTEX_INITIALIZER; void t1() { pthread_mutex_lock(&A_mutex); myglobal++; //RACE! - pthread_mutex_lock(&A_mutex); + pthread_mutex_unlock(&A_mutex); } void t2() { pthread_mutex_lock(&B_mutex); myglobal++; //RACE! - pthread_mutex_lock(&B_mutex); + pthread_mutex_unlock(&B_mutex); } diff --git a/tests/regression/06-symbeq/20-mult_accs_nr.c b/tests/regression/06-symbeq/20-mult_accs_nr.c index 7d66e3f5d2..50c8f19a62 100644 --- a/tests/regression/06-symbeq/20-mult_accs_nr.c +++ b/tests/regression/06-symbeq/20-mult_accs_nr.c @@ -15,7 +15,7 @@ void *t_fun(void *arg) { pthread_mutex_lock(&s->mutex); s->data = 5; // NORACE s->lore = 6; // NORACE - pthread_mutex_lock(&s->mutex); + pthread_mutex_unlock(&s->mutex); return NULL; } diff --git a/tests/regression/06-symbeq/21-mult_accs_rc.c b/tests/regression/06-symbeq/21-mult_accs_rc.c index 62550fab55..4acadb4a58 100644 --- a/tests/regression/06-symbeq/21-mult_accs_rc.c +++ b/tests/regression/06-symbeq/21-mult_accs_rc.c @@ -14,7 +14,7 @@ void *t_fun(void *arg) { pthread_mutex_lock(&s->mutex); s = get_s(); s->data = 5; // RACE! - pthread_mutex_lock(&s->mutex); + pthread_mutex_unlock(&s->mutex); return NULL; } diff --git a/tests/regression/06-symbeq/21-mult_accs_rc.t b/tests/regression/06-symbeq/21-mult_accs_rc.t index ca2e219b05..2eacd0382e 100644 --- a/tests/regression/06-symbeq/21-mult_accs_rc.t +++ b/tests/regression/06-symbeq/21-mult_accs_rc.t @@ -3,7 +3,7 @@ Disable info messages because race summary contains (safe) memory location count $ goblint --enable warn.deterministic --disable warn.info --enable ana.race.direct-arithmetic --set ana.activated[+] "'var_eq'" --set ana.activated[+] "'symb_locks'" 21-mult_accs_rc.c 2>&1 | tee default-output-1.txt [Warning][Behavior > Undefined > NullPointerDereference][CWE-476] May dereference NULL pointer (21-mult_accs_rc.c:14:3-14:32) [Warning][Behavior > Undefined > NullPointerDereference][CWE-476] May dereference NULL pointer (21-mult_accs_rc.c:16:3-16:14) - [Warning][Behavior > Undefined > NullPointerDereference][CWE-476] May dereference NULL pointer (21-mult_accs_rc.c:17:3-17:32) + [Warning][Behavior > Undefined > NullPointerDereference][CWE-476] May dereference NULL pointer (21-mult_accs_rc.c:17:3-17:34) [Warning][Behavior > Undefined > NullPointerDereference][CWE-476] May dereference NULL pointer (21-mult_accs_rc.c:28:3-28:16) [Warning][Behavior > Undefined > NullPointerDereference][CWE-476] May dereference NULL pointer (21-mult_accs_rc.c:29:3-29:15) [Warning][Behavior > Undefined > NullPointerDereference][CWE-476] May dereference NULL pointer (21-mult_accs_rc.c:34:3-34:9) @@ -11,7 +11,8 @@ Disable info messages because race summary contains (safe) memory location count write with thread:[main, t_fun@21-mult_accs_rc.c:31:3-31:37] (conf. 100) (exp: & s->data) (21-mult_accs_rc.c:16:3-16:14) write with [symblock:{p-lock:*.mutex}, mhp:{created={[main, t_fun@21-mult_accs_rc.c:31:3-31:37]}}, thread:[main]] (conf. 100) (exp: & *d) (21-mult_accs_rc.c:34:3-34:9) [Warning][Unknown] locking NULL mutex (21-mult_accs_rc.c:14:3-14:32) - [Warning][Unknown] locking NULL mutex (21-mult_accs_rc.c:17:3-17:32) + [Warning][Unknown] unlocking NULL mutex (21-mult_accs_rc.c:17:3-17:34) + [Warning][Unknown] unlocking unknown mutex which may not be held (21-mult_accs_rc.c:17:3-17:34) [Warning][Unknown] locking NULL mutex (21-mult_accs_rc.c:33:3-33:24) [Warning][Unknown] unlocking NULL mutex (21-mult_accs_rc.c:35:3-35:26) [Warning][Unknown] unlocking unknown mutex which may not be held (21-mult_accs_rc.c:35:3-35:26) @@ -23,14 +24,15 @@ Disable info messages because race summary contains (safe) memory location count $ goblint --enable warn.deterministic --disable warn.info --disable ana.race.direct-arithmetic --set ana.activated[+] "'var_eq'" --set ana.activated[+] "'symb_locks'" --enable allglobs 21-mult_accs_rc.c 2>&1 | tee default-output-2.txt [Warning][Behavior > Undefined > NullPointerDereference][CWE-476] May dereference NULL pointer (21-mult_accs_rc.c:14:3-14:32) [Warning][Behavior > Undefined > NullPointerDereference][CWE-476] May dereference NULL pointer (21-mult_accs_rc.c:16:3-16:14) - [Warning][Behavior > Undefined > NullPointerDereference][CWE-476] May dereference NULL pointer (21-mult_accs_rc.c:17:3-17:32) + [Warning][Behavior > Undefined > NullPointerDereference][CWE-476] May dereference NULL pointer (21-mult_accs_rc.c:17:3-17:34) [Warning][Behavior > Undefined > NullPointerDereference][CWE-476] May dereference NULL pointer (21-mult_accs_rc.c:28:3-28:16) [Warning][Behavior > Undefined > NullPointerDereference][CWE-476] May dereference NULL pointer (21-mult_accs_rc.c:29:3-29:15) [Warning][Behavior > Undefined > NullPointerDereference][CWE-476] May dereference NULL pointer (21-mult_accs_rc.c:34:3-34:9) [Success][Race] Memory location (struct s).data (safe): write with thread:[main, t_fun@21-mult_accs_rc.c:31:3-31:37] (conf. 100) (exp: & s->data) (21-mult_accs_rc.c:16:3-16:14) [Warning][Unknown] locking NULL mutex (21-mult_accs_rc.c:14:3-14:32) - [Warning][Unknown] locking NULL mutex (21-mult_accs_rc.c:17:3-17:32) + [Warning][Unknown] unlocking NULL mutex (21-mult_accs_rc.c:17:3-17:34) + [Warning][Unknown] unlocking unknown mutex which may not be held (21-mult_accs_rc.c:17:3-17:34) [Warning][Unknown] locking NULL mutex (21-mult_accs_rc.c:33:3-33:24) [Warning][Unknown] unlocking NULL mutex (21-mult_accs_rc.c:35:3-35:26) [Warning][Unknown] unlocking unknown mutex which may not be held (21-mult_accs_rc.c:35:3-35:26) diff --git a/tests/regression/06-symbeq/34-var_eq-exponential-context.c b/tests/regression/06-symbeq/34-var_eq-exponential-context.c index bc478374f0..8b9b76a89e 100644 --- a/tests/regression/06-symbeq/34-var_eq-exponential-context.c +++ b/tests/regression/06-symbeq/34-var_eq-exponential-context.c @@ -1,5 +1,5 @@ // SKIP PARAM: --set ana.activated[+] var_eq - +// NOTIMEOUT? void level0(int *p) { } diff --git a/tests/regression/06-symbeq/41-var_eq_multithread.c b/tests/regression/06-symbeq/47-var_eq_multithread.c similarity index 100% rename from tests/regression/06-symbeq/41-var_eq_multithread.c rename to tests/regression/06-symbeq/47-var_eq_multithread.c diff --git a/tests/regression/09-regions/31-equ_rc.c b/tests/regression/09-regions/31-equ_rc.c index 7cea370c58..2f3aff7f63 100644 --- a/tests/regression/09-regions/31-equ_rc.c +++ b/tests/regression/09-regions/31-equ_rc.c @@ -15,7 +15,7 @@ struct s { void *t_fun(void *arg) { pthread_mutex_lock(&A.mutex); B.datum = 5; // RACE! - pthread_mutex_lock(&A.mutex); + pthread_mutex_unlock(&A.mutex); return NULL; } diff --git a/tests/regression/09-regions/32-equ_nr.c b/tests/regression/09-regions/32-equ_nr.c index d9b909546e..a242448ba8 100644 --- a/tests/regression/09-regions/32-equ_nr.c +++ b/tests/regression/09-regions/32-equ_nr.c @@ -15,7 +15,7 @@ struct s { void *t_fun(void *arg) { pthread_mutex_lock(&A.mutex); A.datum = 5; // NORACE - pthread_mutex_lock(&A.mutex); + pthread_mutex_unlock(&A.mutex); return NULL; } diff --git a/tests/regression/13-privatized/04-priv_multi.t b/tests/regression/13-privatized/04-priv_multi.t new file mode 100644 index 0000000000..1f6dff3fdc --- /dev/null +++ b/tests/regression/13-privatized/04-priv_multi.t @@ -0,0 +1,335 @@ + $ goblint --set ana.base.privatization protection --enable witness.yaml.enabled --set ana.activated[+] mutexGhosts --set witness.yaml.entry-types '["flow_insensitive_invariant", "ghost_instrumentation"]' 04-priv_multi.c + [Success][Assert] Assertion "p == 5" will succeed (04-priv_multi.c:50:7-50:30) + [Success][Assert] Assertion "A == B" will succeed (04-priv_multi.c:71:5-71:28) + [Warning][Deadcode] Function 'dispose' has dead code: + on line 53 (04-priv_multi.c:53-53) + on line 56 (04-priv_multi.c:56-56) + [Warning][Deadcode] Function 'process' has dead code: + on line 37 (04-priv_multi.c:37-37) + on line 40 (04-priv_multi.c:40-40) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 40 + dead: 4 + total lines: 44 + [Warning][Deadcode][CWE-571] condition '1' (possibly inserted by CIL) is always true (04-priv_multi.c:25:10-25:11) + [Warning][Deadcode][CWE-571] condition 'A > 0' is always true (04-priv_multi.c:27:9-27:14) + [Warning][Deadcode][CWE-571] condition '1' (possibly inserted by CIL) is always true (04-priv_multi.c:45:10-45:11) + [Warning][Deadcode][CWE-571] condition 'B > 0' is always true (04-priv_multi.c:47:9-47:14) + [Info][Witness] witness generation summary: + location invariants: 0 + loop invariants: 0 + flow-insensitive invariants: 3 + total generation entries: 4 + [Info][Race] Memory locations race summary: + safe: 2 + vulnerable: 0 + unsafe: 0 + total memory locations: 2 + + $ yamlWitnessStrip < witness.yml | tee witness.flow_insensitive.yml + - entry_type: ghost_instrumentation + content: + ghost_variables: + - name: multithreaded + scope: global + type: int + initial: + value: "0" + format: c_expression + - name: mutex_A_locked + scope: global + type: int + initial: + value: "0" + format: c_expression + - name: mutex_B_locked + scope: global + type: int + initial: + value: "0" + format: c_expression + ghost_updates: + - location: + file_name: 04-priv_multi.c + file_hash: $FILE_HASH + line: 15 + column: 5 + function: generate + updates: + - variable: mutex_A_locked + value: "1" + format: c_expression + - location: + file_name: 04-priv_multi.c + file_hash: $FILE_HASH + line: 18 + column: 5 + function: generate + updates: + - variable: mutex_A_locked + value: "0" + format: c_expression + - location: + file_name: 04-priv_multi.c + file_hash: $FILE_HASH + line: 26 + column: 5 + function: process + updates: + - variable: mutex_A_locked + value: "1" + format: c_expression + - location: + file_name: 04-priv_multi.c + file_hash: $FILE_HASH + line: 29 + column: 7 + function: process + updates: + - variable: mutex_B_locked + value: "1" + format: c_expression + - location: + file_name: 04-priv_multi.c + file_hash: $FILE_HASH + line: 32 + column: 7 + function: process + updates: + - variable: mutex_B_locked + value: "0" + format: c_expression + - location: + file_name: 04-priv_multi.c + file_hash: $FILE_HASH + line: 34 + column: 7 + function: process + updates: + - variable: mutex_A_locked + value: "0" + format: c_expression + - location: + file_name: 04-priv_multi.c + file_hash: $FILE_HASH + line: 46 + column: 5 + function: dispose + updates: + - variable: mutex_B_locked + value: "1" + format: c_expression + - location: + file_name: 04-priv_multi.c + file_hash: $FILE_HASH + line: 49 + column: 7 + function: dispose + updates: + - variable: mutex_B_locked + value: "0" + format: c_expression + - location: + file_name: 04-priv_multi.c + file_hash: $FILE_HASH + line: 63 + column: 3 + function: main + updates: + - variable: multithreaded + value: "1" + format: c_expression + - location: + file_name: 04-priv_multi.c + file_hash: $FILE_HASH + line: 68 + column: 5 + function: main + updates: + - variable: mutex_A_locked + value: "1" + format: c_expression + - location: + file_name: 04-priv_multi.c + file_hash: $FILE_HASH + line: 69 + column: 5 + function: main + updates: + - variable: mutex_B_locked + value: "1" + format: c_expression + - location: + file_name: 04-priv_multi.c + file_hash: $FILE_HASH + line: 73 + column: 5 + function: main + updates: + - variable: mutex_B_locked + value: "0" + format: c_expression + - location: + file_name: 04-priv_multi.c + file_hash: $FILE_HASH + line: 74 + column: 5 + function: main + updates: + - variable: mutex_A_locked + value: "0" + format: c_expression + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (mutex_B_locked || (mutex_A_locked || B == 5))' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (mutex_A_locked || A == 5)' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || ((0 <= B && B <= 127) && B != 0)' + type: assertion + format: C + +Flow-insensitive invariants as location invariants. + + $ goblint --set ana.base.privatization protection --enable witness.yaml.enabled --set ana.activated[+] mutexGhosts --set witness.yaml.entry-types '["flow_insensitive_invariant", "ghost_instrumentation"]' --set witness.invariant.flow_insensitive-as location_invariant 04-priv_multi.c + [Success][Assert] Assertion "p == 5" will succeed (04-priv_multi.c:50:7-50:30) + [Success][Assert] Assertion "A == B" will succeed (04-priv_multi.c:71:5-71:28) + [Warning][Deadcode] Function 'dispose' has dead code: + on line 53 (04-priv_multi.c:53-53) + on line 56 (04-priv_multi.c:56-56) + [Warning][Deadcode] Function 'process' has dead code: + on line 37 (04-priv_multi.c:37-37) + on line 40 (04-priv_multi.c:40-40) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 40 + dead: 4 + total lines: 44 + [Warning][Deadcode][CWE-571] condition '1' (possibly inserted by CIL) is always true (04-priv_multi.c:25:10-25:11) + [Warning][Deadcode][CWE-571] condition 'A > 0' is always true (04-priv_multi.c:27:9-27:14) + [Warning][Deadcode][CWE-571] condition '1' (possibly inserted by CIL) is always true (04-priv_multi.c:45:10-45:11) + [Warning][Deadcode][CWE-571] condition 'B > 0' is always true (04-priv_multi.c:47:9-47:14) + [Info][Witness] witness generation summary: + location invariants: 9 + loop invariants: 0 + flow-insensitive invariants: 0 + total generation entries: 10 + [Info][Race] Memory locations race summary: + safe: 2 + vulnerable: 0 + unsafe: 0 + total memory locations: 2 + + $ yamlWitnessStrip < witness.yml > witness.location.yml + +Location invariant at `for` loop in `main` should be on column 3, not 7. + + $ diff witness.flow_insensitive.yml witness.location.yml + 153,154c153,160 + < - entry_type: flow_insensitive_invariant + < flow_insensitive_invariant: + --- + > - entry_type: location_invariant + > location: + > file_name: 04-priv_multi.c + > file_hash: $FILE_HASH + > line: 67 + > column: 3 + > function: main + > location_invariant: + 158,159c164,171 + < - entry_type: flow_insensitive_invariant + < flow_insensitive_invariant: + --- + > - entry_type: location_invariant + > location: + > file_name: 04-priv_multi.c + > file_hash: $FILE_HASH + > line: 67 + > column: 3 + > function: main + > location_invariant: + 163,164c175,248 + < - entry_type: flow_insensitive_invariant + < flow_insensitive_invariant: + --- + > - entry_type: location_invariant + > location: + > file_name: 04-priv_multi.c + > file_hash: $FILE_HASH + > line: 67 + > column: 3 + > function: main + > location_invariant: + > string: '! multithreaded || ((0 <= B && B <= 127) && B != 0)' + > type: assertion + > format: C + > - entry_type: location_invariant + > location: + > file_name: 04-priv_multi.c + > file_hash: $FILE_HASH + > line: 65 + > column: 3 + > function: main + > location_invariant: + > string: '! multithreaded || (mutex_B_locked || (mutex_A_locked || B == 5))' + > type: assertion + > format: C + > - entry_type: location_invariant + > location: + > file_name: 04-priv_multi.c + > file_hash: $FILE_HASH + > line: 65 + > column: 3 + > function: main + > location_invariant: + > string: '! multithreaded || (mutex_A_locked || A == 5)' + > type: assertion + > format: C + > - entry_type: location_invariant + > location: + > file_name: 04-priv_multi.c + > file_hash: $FILE_HASH + > line: 65 + > column: 3 + > function: main + > location_invariant: + > string: '! multithreaded || ((0 <= B && B <= 127) && B != 0)' + > type: assertion + > format: C + > - entry_type: location_invariant + > location: + > file_name: 04-priv_multi.c + > file_hash: $FILE_HASH + > line: 64 + > column: 3 + > function: main + > location_invariant: + > string: '! multithreaded || (mutex_B_locked || (mutex_A_locked || B == 5))' + > type: assertion + > format: C + > - entry_type: location_invariant + > location: + > file_name: 04-priv_multi.c + > file_hash: $FILE_HASH + > line: 64 + > column: 3 + > function: main + > location_invariant: + > string: '! multithreaded || (mutex_A_locked || A == 5)' + > type: assertion + > format: C + > - entry_type: location_invariant + > location: + > file_name: 04-priv_multi.c + > file_hash: $FILE_HASH + > line: 64 + > column: 3 + > function: main + > location_invariant: + [1] diff --git a/tests/regression/13-privatized/25-struct_nr.t b/tests/regression/13-privatized/25-struct_nr.t new file mode 100644 index 0000000000..fa00b2a5a5 --- /dev/null +++ b/tests/regression/13-privatized/25-struct_nr.t @@ -0,0 +1,97 @@ + $ goblint --set ana.base.privatization protection --enable witness.yaml.enabled --set ana.activated[+] mutexGhosts --set witness.yaml.entry-types '["flow_insensitive_invariant", "ghost_instrumentation"]' 25-struct_nr.c + [Success][Assert] Assertion "glob1 == 5" will succeed (25-struct_nr.c:26:3-26:30) + [Success][Assert] Assertion "t == 5" will succeed (25-struct_nr.c:16:3-16:26) + [Success][Assert] Assertion "glob1 == -10" will succeed (25-struct_nr.c:18:3-18:32) + [Success][Assert] Assertion "glob1 == 6" will succeed (25-struct_nr.c:30:3-30:30) + [Info][Deadcode] Logical lines of code (LLoC) summary: + live: 19 + dead: 0 + total lines: 19 + [Info][Witness] witness generation summary: + location invariants: 0 + loop invariants: 0 + flow-insensitive invariants: 2 + total generation entries: 3 + [Info][Race] Memory locations race summary: + safe: 1 + vulnerable: 0 + unsafe: 0 + total memory locations: 1 + + $ yamlWitnessStrip < witness.yml + - entry_type: ghost_instrumentation + content: + ghost_variables: + - name: lock1_mutex_locked + scope: global + type: int + initial: + value: "0" + format: c_expression + - name: multithreaded + scope: global + type: int + initial: + value: "0" + format: c_expression + ghost_updates: + - location: + file_name: 25-struct_nr.c + file_hash: $FILE_HASH + line: 14 + column: 3 + function: t_fun + updates: + - variable: lock1_mutex_locked + value: "1" + format: c_expression + - location: + file_name: 25-struct_nr.c + file_hash: $FILE_HASH + line: 20 + column: 3 + function: t_fun + updates: + - variable: lock1_mutex_locked + value: "0" + format: c_expression + - location: + file_name: 25-struct_nr.c + file_hash: $FILE_HASH + line: 27 + column: 3 + function: main + updates: + - variable: multithreaded + value: "1" + format: c_expression + - location: + file_name: 25-struct_nr.c + file_hash: $FILE_HASH + line: 28 + column: 3 + function: main + updates: + - variable: lock1_mutex_locked + value: "1" + format: c_expression + - location: + file_name: 25-struct_nr.c + file_hash: $FILE_HASH + line: 32 + column: 3 + function: main + updates: + - variable: lock1_mutex_locked + value: "0" + format: c_expression + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (lock1_mutex_locked || glob1 == 5)' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || ((-128 <= glob1 && glob1 <= 127) && glob1 != 0)' + type: assertion + format: C diff --git a/tests/regression/13-privatized/74-mutex.t b/tests/regression/13-privatized/74-mutex.t new file mode 100644 index 0000000000..4b370db387 --- /dev/null +++ b/tests/regression/13-privatized/74-mutex.t @@ -0,0 +1,395 @@ + $ goblint --enable ana.sv-comp.functions --set ana.base.privatization protection --enable witness.yaml.enabled --set ana.activated[+] mutexGhosts --set witness.yaml.entry-types '["flow_insensitive_invariant", "ghost_instrumentation"]' 74-mutex.c + [Success][Assert] Assertion "used == 0" will succeed (74-mutex.c:37:3-37:29) + [Warning][Deadcode] Function 'producer' has dead code: + on line 26 (74-mutex.c:26-26) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 14 + dead: 1 + total lines: 15 + [Warning][Deadcode][CWE-571] condition '1' (possibly inserted by CIL) is always true (74-mutex.c:19:10-19:11) + [Info][Witness] witness generation summary: + location invariants: 0 + loop invariants: 0 + flow-insensitive invariants: 2 + total generation entries: 3 + [Info][Race] Memory locations race summary: + safe: 1 + vulnerable: 0 + unsafe: 0 + total memory locations: 1 + + $ yamlWitnessStrip < witness.yml | tee witness.flow_insensitive.yml + - entry_type: ghost_instrumentation + content: + ghost_variables: + - name: m_locked + scope: global + type: int + initial: + value: "0" + format: c_expression + - name: multithreaded + scope: global + type: int + initial: + value: "0" + format: c_expression + ghost_updates: + - location: + file_name: 74-mutex.c + file_hash: $FILE_HASH + line: 20 + column: 5 + function: producer + updates: + - variable: m_locked + value: "1" + format: c_expression + - location: + file_name: 74-mutex.c + file_hash: $FILE_HASH + line: 23 + column: 5 + function: producer + updates: + - variable: m_locked + value: "0" + format: c_expression + - location: + file_name: 74-mutex.c + file_hash: $FILE_HASH + line: 34 + column: 3 + function: main + updates: + - variable: multithreaded + value: "1" + format: c_expression + - location: + file_name: 74-mutex.c + file_hash: $FILE_HASH + line: 36 + column: 3 + function: main + updates: + - variable: m_locked + value: "1" + format: c_expression + - location: + file_name: 74-mutex.c + file_hash: $FILE_HASH + line: 38 + column: 3 + function: main + updates: + - variable: m_locked + value: "0" + format: c_expression + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (m_locked || used == 0)' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (0 <= used && used <= 1)' + type: assertion + format: C + +Flow-insensitive invariants as location invariants. + + $ goblint --enable ana.sv-comp.functions --set ana.base.privatization protection --enable witness.yaml.enabled --set ana.activated[+] mutexGhosts --set witness.yaml.entry-types '["flow_insensitive_invariant", "ghost_instrumentation"]' --set witness.invariant.flow_insensitive-as location_invariant 74-mutex.c + [Success][Assert] Assertion "used == 0" will succeed (74-mutex.c:37:3-37:29) + [Warning][Deadcode] Function 'producer' has dead code: + on line 26 (74-mutex.c:26-26) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 14 + dead: 1 + total lines: 15 + [Warning][Deadcode][CWE-571] condition '1' (possibly inserted by CIL) is always true (74-mutex.c:19:10-19:11) + [Info][Witness] witness generation summary: + location invariants: 2 + loop invariants: 0 + flow-insensitive invariants: 0 + total generation entries: 3 + [Info][Race] Memory locations race summary: + safe: 1 + vulnerable: 0 + unsafe: 0 + total memory locations: 1 + + $ yamlWitnessStrip < witness.yml > witness.location.yml + + $ diff witness.flow_insensitive.yml witness.location.yml + 67,68c67,74 + < - entry_type: flow_insensitive_invariant + < flow_insensitive_invariant: + --- + > - entry_type: location_invariant + > location: + > file_name: 74-mutex.c + > file_hash: $FILE_HASH + > line: 36 + > column: 3 + > function: main + > location_invariant: + 72,73c78,85 + < - entry_type: flow_insensitive_invariant + < flow_insensitive_invariant: + --- + > - entry_type: location_invariant + > location: + > file_name: 74-mutex.c + > file_hash: $FILE_HASH + > line: 36 + > column: 3 + > function: main + > location_invariant: + [1] + +Should also work with earlyglobs. +Earlyglobs shouldn't cause protected writes in multithreaded mode from being immediately published to protected invariant. + + $ goblint --enable ana.sv-comp.functions --set ana.base.privatization protection --enable exp.earlyglobs 74-mutex.c + [Success][Assert] Assertion "used == 0" will succeed (74-mutex.c:37:3-37:29) + [Warning][Deadcode] Function 'producer' has dead code: + on line 26 (74-mutex.c:26-26) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 14 + dead: 1 + total lines: 15 + [Warning][Deadcode][CWE-571] condition '1' (possibly inserted by CIL) is always true (74-mutex.c:19:10-19:11) + [Info][Race] Memory locations race summary: + safe: 1 + vulnerable: 0 + unsafe: 0 + total memory locations: 1 + +Same with ghost_instrumentation and invariant_set entries. + + $ goblint --enable ana.sv-comp.functions --set ana.base.privatization protection --enable witness.yaml.enabled --set ana.activated[+] mutexGhosts --set witness.yaml.entry-types '["flow_insensitive_invariant", "ghost_instrumentation"]' --set witness.invariant.flow_insensitive-as invariant_set-location_invariant 74-mutex.c + [Success][Assert] Assertion "used == 0" will succeed (74-mutex.c:37:3-37:29) + [Warning][Deadcode] Function 'producer' has dead code: + on line 26 (74-mutex.c:26-26) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 14 + dead: 1 + total lines: 15 + [Warning][Deadcode][CWE-571] condition '1' (possibly inserted by CIL) is always true (74-mutex.c:19:10-19:11) + [Info][Witness] witness generation summary: + location invariants: 2 + loop invariants: 0 + flow-insensitive invariants: 0 + total generation entries: 2 + [Info][Race] Memory locations race summary: + safe: 1 + vulnerable: 0 + unsafe: 0 + total memory locations: 1 + + $ yamlWitnessStrip < witness.yml + - entry_type: ghost_instrumentation + content: + ghost_variables: + - name: m_locked + scope: global + type: int + initial: + value: "0" + format: c_expression + - name: multithreaded + scope: global + type: int + initial: + value: "0" + format: c_expression + ghost_updates: + - location: + file_name: 74-mutex.c + file_hash: $FILE_HASH + line: 20 + column: 5 + function: producer + updates: + - variable: m_locked + value: "1" + format: c_expression + - location: + file_name: 74-mutex.c + file_hash: $FILE_HASH + line: 23 + column: 5 + function: producer + updates: + - variable: m_locked + value: "0" + format: c_expression + - location: + file_name: 74-mutex.c + file_hash: $FILE_HASH + line: 34 + column: 3 + function: main + updates: + - variable: multithreaded + value: "1" + format: c_expression + - location: + file_name: 74-mutex.c + file_hash: $FILE_HASH + line: 36 + column: 3 + function: main + updates: + - variable: m_locked + value: "1" + format: c_expression + - location: + file_name: 74-mutex.c + file_hash: $FILE_HASH + line: 38 + column: 3 + function: main + updates: + - variable: m_locked + value: "0" + format: c_expression + - entry_type: invariant_set + content: + - invariant: + type: location_invariant + location: + file_name: 74-mutex.c + file_hash: $FILE_HASH + line: 36 + column: 3 + function: main + value: '! multithreaded || (0 <= used && used <= 1)' + format: c_expression + - invariant: + type: location_invariant + location: + file_name: 74-mutex.c + file_hash: $FILE_HASH + line: 36 + column: 3 + function: main + value: '! multithreaded || (m_locked || used == 0)' + format: c_expression + +Same with mutex-meet. + + $ goblint --enable ana.sv-comp.functions --set ana.base.privatization mutex-meet --enable witness.yaml.enabled --set ana.activated[+] mutexGhosts --set witness.yaml.entry-types '["flow_insensitive_invariant", "ghost_instrumentation"]' 74-mutex.c + [Success][Assert] Assertion "used == 0" will succeed (74-mutex.c:37:3-37:29) + [Warning][Deadcode] Function 'producer' has dead code: + on line 26 (74-mutex.c:26-26) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 14 + dead: 1 + total lines: 15 + [Warning][Deadcode][CWE-571] condition '1' (possibly inserted by CIL) is always true (74-mutex.c:19:10-19:11) + [Info][Witness] witness generation summary: + location invariants: 0 + loop invariants: 0 + flow-insensitive invariants: 2 + total generation entries: 3 + [Info][Race] Memory locations race summary: + safe: 1 + vulnerable: 0 + unsafe: 0 + total memory locations: 1 + + $ yamlWitnessStrip < witness.yml + - entry_type: ghost_instrumentation + content: + ghost_variables: + - name: m_locked + scope: global + type: int + initial: + value: "0" + format: c_expression + - name: multithreaded + scope: global + type: int + initial: + value: "0" + format: c_expression + ghost_updates: + - location: + file_name: 74-mutex.c + file_hash: $FILE_HASH + line: 20 + column: 5 + function: producer + updates: + - variable: m_locked + value: "1" + format: c_expression + - location: + file_name: 74-mutex.c + file_hash: $FILE_HASH + line: 23 + column: 5 + function: producer + updates: + - variable: m_locked + value: "0" + format: c_expression + - location: + file_name: 74-mutex.c + file_hash: $FILE_HASH + line: 34 + column: 3 + function: main + updates: + - variable: multithreaded + value: "1" + format: c_expression + - location: + file_name: 74-mutex.c + file_hash: $FILE_HASH + line: 36 + column: 3 + function: main + updates: + - variable: m_locked + value: "1" + format: c_expression + - location: + file_name: 74-mutex.c + file_hash: $FILE_HASH + line: 38 + column: 3 + function: main + updates: + - variable: m_locked + value: "0" + format: c_expression + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (m_locked || used == 0)' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (0 <= used && used <= 1)' + type: assertion + format: C + +Should also work with earlyglobs. + + $ goblint --enable ana.sv-comp.functions --set ana.base.privatization mutex-meet --enable exp.earlyglobs 74-mutex.c + [Success][Assert] Assertion "used == 0" will succeed (74-mutex.c:37:3-37:29) + [Warning][Deadcode] Function 'producer' has dead code: + on line 26 (74-mutex.c:26-26) + [Warning][Deadcode] Logical lines of code (LLoC) summary: + live: 14 + dead: 1 + total lines: 15 + [Warning][Deadcode][CWE-571] condition '1' (possibly inserted by CIL) is always true (74-mutex.c:19:10-19:11) + [Info][Race] Memory locations race summary: + safe: 1 + vulnerable: 0 + unsafe: 0 + total memory locations: 1 diff --git a/tests/regression/13-privatized/92-idx_priv.c b/tests/regression/13-privatized/92-idx_priv.c new file mode 100644 index 0000000000..ed0e8d3228 --- /dev/null +++ b/tests/regression/13-privatized/92-idx_priv.c @@ -0,0 +1,26 @@ +#include +#include + +int data; +pthread_mutex_t m[10]; + +void *t_fun(void *arg) { + pthread_mutex_lock(&m[4]); + data++; // NORACE + data--; // NORACE + pthread_mutex_unlock(&m[4]); + return NULL; +} + +int main() { + for (int i = 0; i < 10; i++) + pthread_mutex_init(&m[i], NULL); + + pthread_t id; + pthread_create(&id, NULL, t_fun, NULL); + pthread_mutex_lock(&m[4]); + __goblint_check(data == 0); // NORACE + pthread_mutex_unlock(&m[4]); + return 0; +} + diff --git a/tests/regression/13-privatized/92-idx_priv.t b/tests/regression/13-privatized/92-idx_priv.t new file mode 100644 index 0000000000..7b3adc5e0b --- /dev/null +++ b/tests/regression/13-privatized/92-idx_priv.t @@ -0,0 +1,45 @@ + $ goblint --set ana.base.privatization protection --enable witness.yaml.enabled --set ana.activated[+] mutexGhosts --set witness.yaml.entry-types '["flow_insensitive_invariant", "ghost_instrumentation"]' 92-idx_priv.c + [Success][Assert] Assertion "data == 0" will succeed (92-idx_priv.c:22:3-22:29) + [Info][Deadcode] Logical lines of code (LLoC) summary: + live: 14 + dead: 0 + total lines: 14 + [Info][Witness] witness generation summary: + location invariants: 0 + loop invariants: 0 + flow-insensitive invariants: 1 + total generation entries: 2 + [Info][Race] Memory locations race summary: + safe: 1 + vulnerable: 0 + unsafe: 0 + total memory locations: 1 + + $ yamlWitnessStrip < witness.yml + - entry_type: ghost_instrumentation + content: + ghost_variables: + - name: multithreaded + scope: global + type: int + initial: + value: "0" + format: c_expression + ghost_updates: + - location: + file_name: 92-idx_priv.c + file_hash: $FILE_HASH + line: 20 + column: 3 + function: main + updates: + - variable: multithreaded + value: "1" + format: c_expression + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (0 <= data && data <= 1)' + type: assertion + format: C + +TODO: protected invariant with m_4_locked without making 56-witness/68-ghost-ambiguous-idx unsound diff --git a/tests/regression/13-privatized/dune b/tests/regression/13-privatized/dune index 23c0dd3290..9227128b15 100644 --- a/tests/regression/13-privatized/dune +++ b/tests/regression/13-privatized/dune @@ -1,2 +1,6 @@ (cram (deps (glob_files *.c))) + +(cram + (applies_to 04-priv_multi) + (enabled_if (<> %{system} macosx))) diff --git a/tests/regression/29-svcomp/16-atomic_priv.t b/tests/regression/29-svcomp/16-atomic_priv.t new file mode 100644 index 0000000000..1662f881b7 --- /dev/null +++ b/tests/regression/29-svcomp/16-atomic_priv.t @@ -0,0 +1,111 @@ + $ goblint --enable ana.sv-comp.functions --set ana.base.privatization protection-atomic --enable witness.yaml.enabled --set ana.activated[+] mutexGhosts --set witness.yaml.entry-types '["flow_insensitive_invariant", "ghost_instrumentation"]' 16-atomic_priv.c + [Success][Assert] Assertion "myglobal == 5" will succeed (16-atomic_priv.c:12:3-12:33) + [Success][Assert] Assertion "myglobal == 6" will succeed (16-atomic_priv.c:14:3-14:33) + [Success][Assert] Assertion "myglobal == 5" will succeed (16-atomic_priv.c:16:3-16:33) + [Success][Assert] Assertion "myglobal == 5" will succeed (16-atomic_priv.c:24:3-24:33) + [Success][Assert] Assertion "myglobal == 5" will succeed (16-atomic_priv.c:26:3-26:33) + [Info][Deadcode] Logical lines of code (LLoC) summary: + live: 17 + dead: 0 + total lines: 17 + [Warning][Race] Memory location myglobal (race with conf. 110): (16-atomic_priv.c:8:5-8:17) + write with [lock:{[__VERIFIER_atomic]}, thread:[main, t_fun@16-atomic_priv.c:23:3-23:40]] (conf. 110) (exp: & myglobal) (16-atomic_priv.c:13:3-13:13) + write with [lock:{[__VERIFIER_atomic]}, thread:[main, t_fun@16-atomic_priv.c:23:3-23:40]] (conf. 110) (exp: & myglobal) (16-atomic_priv.c:15:3-15:13) + read with [mhp:{created={[main, t_fun@16-atomic_priv.c:23:3-23:40]}}, thread:[main]] (conf. 110) (exp: & myglobal) (16-atomic_priv.c:24:3-24:33) + [Info][Witness] witness generation summary: + location invariants: 0 + loop invariants: 0 + flow-insensitive invariants: 1 + total generation entries: 2 + [Info][Race] Memory locations race summary: + safe: 0 + vulnerable: 0 + unsafe: 1 + total memory locations: 1 + + $ yamlWitnessStrip < witness.yml + - entry_type: ghost_instrumentation + content: + ghost_variables: + - name: multithreaded + scope: global + type: int + initial: + value: "0" + format: c_expression + ghost_updates: + - location: + file_name: 16-atomic_priv.c + file_hash: $FILE_HASH + line: 23 + column: 3 + function: main + updates: + - variable: multithreaded + value: "1" + format: c_expression + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || myglobal == 5' + type: assertion + format: C + +Non-atomic privatization: + + $ goblint --enable ana.sv-comp.functions --set ana.base.privatization protection --enable witness.yaml.enabled --set ana.activated[+] mutexGhosts --set witness.yaml.entry-types '["flow_insensitive_invariant", "ghost_instrumentation"]' 16-atomic_priv.c + [Success][Assert] Assertion "myglobal == 5" will succeed (16-atomic_priv.c:12:3-12:33) + [Success][Assert] Assertion "myglobal == 6" will succeed (16-atomic_priv.c:14:3-14:33) + [Success][Assert] Assertion "myglobal == 5" will succeed (16-atomic_priv.c:16:3-16:33) + [Warning][Assert] Assertion "myglobal == 5" is unknown. (16-atomic_priv.c:24:3-24:33) + [Success][Assert] Assertion "myglobal == 5" will succeed (16-atomic_priv.c:26:3-26:33) + [Info][Deadcode] Logical lines of code (LLoC) summary: + live: 17 + dead: 0 + total lines: 17 + [Warning][Race] Memory location myglobal (race with conf. 110): (16-atomic_priv.c:8:5-8:17) + write with [lock:{[__VERIFIER_atomic]}, thread:[main, t_fun@16-atomic_priv.c:23:3-23:40]] (conf. 110) (exp: & myglobal) (16-atomic_priv.c:13:3-13:13) + write with [lock:{[__VERIFIER_atomic]}, thread:[main, t_fun@16-atomic_priv.c:23:3-23:40]] (conf. 110) (exp: & myglobal) (16-atomic_priv.c:15:3-15:13) + read with [mhp:{created={[main, t_fun@16-atomic_priv.c:23:3-23:40]}}, thread:[main]] (conf. 110) (exp: & myglobal) (16-atomic_priv.c:24:3-24:33) + [Info][Witness] witness generation summary: + location invariants: 0 + loop invariants: 0 + flow-insensitive invariants: 2 + total generation entries: 3 + [Info][Race] Memory locations race summary: + safe: 0 + vulnerable: 0 + unsafe: 1 + total memory locations: 1 + + $ yamlWitnessStrip < witness.yml + - entry_type: ghost_instrumentation + content: + ghost_variables: + - name: multithreaded + scope: global + type: int + initial: + value: "0" + format: c_expression + ghost_updates: + - location: + file_name: 16-atomic_priv.c + file_hash: $FILE_HASH + line: 23 + column: 3 + function: main + updates: + - variable: multithreaded + value: "1" + format: c_expression + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || myglobal == 5' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || ((0 <= myglobal && myglobal <= 127) && myglobal != + 0)' + type: assertion + format: C diff --git a/tests/regression/29-svcomp/dune b/tests/regression/29-svcomp/dune index 95ac66a5ec..9b2396b313 100644 --- a/tests/regression/29-svcomp/dune +++ b/tests/regression/29-svcomp/dune @@ -17,4 +17,4 @@ (cram (applies_to 36-svcomp-arch) - (enabled_if (<> %{system} macosx))) ; https://dune.readthedocs.io/en/stable/reference/boolean-language.html + (enabled_if %{read:../../util/multilibAvailable})) ; https://dune.readthedocs.io/en/stable/reference/boolean-language.html diff --git a/tests/regression/36-apron/12-traces-min-rpb1.t b/tests/regression/36-apron/12-traces-min-rpb1.t index d0cebd6d1c..2a760c0dcb 100644 --- a/tests/regression/36-apron/12-traces-min-rpb1.t +++ b/tests/regression/36-apron/12-traces-min-rpb1.t @@ -57,3 +57,123 @@ string: (0LL - (long long )g) + (long long )h == 0LL type: assertion format: C + + + $ goblint --enable warn.deterministic --set ana.activated[+] apron --set ana.path_sens[+] threadflag --enable ana.sv-comp.functions --enable witness.yaml.enabled --set ana.activated[+] mutexGhosts --set witness.yaml.entry-types '["flow_insensitive_invariant", "ghost_instrumentation"]' 12-traces-min-rpb1.c --enable ana.apron.invariant.diff-box + [Warning][Assert] Assertion "g == h" is unknown. (12-traces-min-rpb1.c:27:3-27:26) + [Success][Assert] Assertion "g == h" will succeed (12-traces-min-rpb1.c:16:3-16:26) + [Success][Assert] Assertion "g == h" will succeed (12-traces-min-rpb1.c:29:3-29:26) + [Warning][Race] Memory location g (race with conf. 110): (12-traces-min-rpb1.c:7:5-7:10) + write with [lock:{A}, thread:[main, t_fun@12-traces-min-rpb1.c:25:3-25:40]] (conf. 110) (exp: & g) (12-traces-min-rpb1.c:14:3-14:8) + read with [mhp:{created={[main, t_fun@12-traces-min-rpb1.c:25:3-25:40]}}, thread:[main]] (conf. 110) (exp: & g) (12-traces-min-rpb1.c:27:3-27:26) + [Warning][Race] Memory location h (race with conf. 110): (12-traces-min-rpb1.c:8:5-8:10) + write with [lock:{A}, thread:[main, t_fun@12-traces-min-rpb1.c:25:3-25:40]] (conf. 110) (exp: & h) (12-traces-min-rpb1.c:15:3-15:8) + read with [mhp:{created={[main, t_fun@12-traces-min-rpb1.c:25:3-25:40]}}, thread:[main]] (conf. 110) (exp: & h) (12-traces-min-rpb1.c:27:3-27:26) + [Info][Race] Memory locations race summary: + safe: 0 + vulnerable: 0 + unsafe: 2 + total memory locations: 2 + [Info][Deadcode] Logical lines of code (LLoC) summary: + live: 18 + dead: 0 + total lines: 18 + [Info][Witness] witness generation summary: + location invariants: 0 + loop invariants: 0 + flow-insensitive invariants: 1 + total generation entries: 2 + + $ yamlWitnessStrip < witness.yml + - entry_type: ghost_instrumentation + content: + ghost_variables: + - name: A_locked + scope: global + type: int + initial: + value: "0" + format: c_expression + - name: multithreaded + scope: global + type: int + initial: + value: "0" + format: c_expression + ghost_updates: + - location: + file_name: 12-traces-min-rpb1.c + file_hash: $FILE_HASH + line: 13 + column: 3 + function: t_fun + updates: + - variable: A_locked + value: "1" + format: c_expression + - location: + file_name: 12-traces-min-rpb1.c + file_hash: $FILE_HASH + line: 17 + column: 3 + function: t_fun + updates: + - variable: A_locked + value: "0" + format: c_expression + - location: + file_name: 12-traces-min-rpb1.c + file_hash: $FILE_HASH + line: 18 + column: 3 + function: t_fun + updates: + - variable: A_locked + value: "1" + format: c_expression + - location: + file_name: 12-traces-min-rpb1.c + file_hash: $FILE_HASH + line: 19 + column: 3 + function: t_fun + updates: + - variable: A_locked + value: "0" + format: c_expression + - location: + file_name: 12-traces-min-rpb1.c + file_hash: $FILE_HASH + line: 25 + column: 3 + function: main + updates: + - variable: multithreaded + value: "1" + format: c_expression + - location: + file_name: 12-traces-min-rpb1.c + file_hash: $FILE_HASH + line: 28 + column: 3 + function: main + updates: + - variable: A_locked + value: "1" + format: c_expression + - location: + file_name: 12-traces-min-rpb1.c + file_hash: $FILE_HASH + line: 30 + column: 3 + function: main + updates: + - variable: A_locked + value: "0" + format: c_expression + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (A_locked || ((0LL - (long long )g) + (long long )h + >= 0LL && (long long )g - (long long )h >= 0LL))' + type: assertion + format: C diff --git a/tests/regression/56-witness/64-ghost-multiple-protecting.c b/tests/regression/56-witness/64-ghost-multiple-protecting.c new file mode 100644 index 0000000000..a9fa3310e4 --- /dev/null +++ b/tests/regression/56-witness/64-ghost-multiple-protecting.c @@ -0,0 +1,41 @@ +// PARAM: --set ana.activated[+] mutexGhosts +#include +#include +int g1, g2; +pthread_mutex_t m1 = PTHREAD_MUTEX_INITIALIZER; +pthread_mutex_t m2 = PTHREAD_MUTEX_INITIALIZER; +// CRAM +void *t_fun(void *arg) { + pthread_mutex_lock(&m1); + pthread_mutex_lock(&m2); + g1 = 1; + g1 = 0; + pthread_mutex_unlock(&m2); + pthread_mutex_unlock(&m1); + + pthread_mutex_lock(&m1); + pthread_mutex_lock(&m2); + g2 = 1; + pthread_mutex_unlock(&m2); + pthread_mutex_lock(&m2); + g2 = 0; + pthread_mutex_unlock(&m2); + pthread_mutex_unlock(&m1); + return NULL; +} + +int main() { + pthread_t id; + pthread_create(&id, NULL, t_fun, NULL); + + /* pthread_mutex_lock(&m1); + __goblint_check(g1 == 0); // NOWARN (commented out) + __goblint_check(g2 == 0); // NOWARN (commented out) + pthread_mutex_unlock(&m1); + + pthread_mutex_lock(&m2); + __goblint_check(g1 == 0); // NOWARN (commented out) + __goblint_check(g2 == 0); // NOWARN (commented out) + pthread_mutex_unlock(&m2); */ + return 0; +} diff --git a/tests/regression/56-witness/64-ghost-multiple-protecting.t b/tests/regression/56-witness/64-ghost-multiple-protecting.t new file mode 100644 index 0000000000..cfa3995005 --- /dev/null +++ b/tests/regression/56-witness/64-ghost-multiple-protecting.t @@ -0,0 +1,508 @@ + $ goblint --set ana.base.privatization protection --enable witness.yaml.enabled --set ana.activated[+] mutexGhosts --set witness.yaml.entry-types '["flow_insensitive_invariant", "ghost_instrumentation"]' 64-ghost-multiple-protecting.c + [Info][Deadcode] Logical lines of code (LLoC) summary: + live: 19 + dead: 0 + total lines: 19 + [Info][Witness] witness generation summary: + location invariants: 0 + loop invariants: 0 + flow-insensitive invariants: 3 + total generation entries: 4 + [Info][Race] Memory locations race summary: + safe: 2 + vulnerable: 0 + unsafe: 0 + total memory locations: 2 + +protection doesn't have precise protected invariant for g2. + + $ yamlWitnessStrip < witness.yml + - entry_type: ghost_instrumentation + content: + ghost_variables: + - name: m1_locked + scope: global + type: int + initial: + value: "0" + format: c_expression + - name: m2_locked + scope: global + type: int + initial: + value: "0" + format: c_expression + - name: multithreaded + scope: global + type: int + initial: + value: "0" + format: c_expression + ghost_updates: + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 9 + column: 3 + function: t_fun + updates: + - variable: m1_locked + value: "1" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 10 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "1" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 13 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "0" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 14 + column: 3 + function: t_fun + updates: + - variable: m1_locked + value: "0" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 16 + column: 3 + function: t_fun + updates: + - variable: m1_locked + value: "1" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 17 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "1" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 19 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "0" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 20 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "1" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 22 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "0" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 23 + column: 3 + function: t_fun + updates: + - variable: m1_locked + value: "0" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 29 + column: 3 + function: main + updates: + - variable: multithreaded + value: "1" + format: c_expression + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (m2_locked || (m1_locked || g1 == 0))' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (0 <= g2 && g2 <= 1)' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (0 <= g1 && g1 <= 1)' + type: assertion + format: C + + $ goblint --set ana.base.privatization protection-read --enable witness.yaml.enabled --set ana.activated[+] mutexGhosts --set witness.yaml.entry-types '["flow_insensitive_invariant", "ghost_instrumentation"]' 64-ghost-multiple-protecting.c + [Info][Deadcode] Logical lines of code (LLoC) summary: + live: 19 + dead: 0 + total lines: 19 + [Info][Witness] witness generation summary: + location invariants: 0 + loop invariants: 0 + flow-insensitive invariants: 4 + total generation entries: 5 + [Info][Race] Memory locations race summary: + safe: 2 + vulnerable: 0 + unsafe: 0 + total memory locations: 2 + +protection-read has precise protected invariant for g2. + + $ yamlWitnessStrip < witness.yml + - entry_type: ghost_instrumentation + content: + ghost_variables: + - name: m1_locked + scope: global + type: int + initial: + value: "0" + format: c_expression + - name: m2_locked + scope: global + type: int + initial: + value: "0" + format: c_expression + - name: multithreaded + scope: global + type: int + initial: + value: "0" + format: c_expression + ghost_updates: + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 9 + column: 3 + function: t_fun + updates: + - variable: m1_locked + value: "1" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 10 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "1" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 13 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "0" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 14 + column: 3 + function: t_fun + updates: + - variable: m1_locked + value: "0" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 16 + column: 3 + function: t_fun + updates: + - variable: m1_locked + value: "1" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 17 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "1" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 19 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "0" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 20 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "1" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 22 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "0" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 23 + column: 3 + function: t_fun + updates: + - variable: m1_locked + value: "0" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 29 + column: 3 + function: main + updates: + - variable: multithreaded + value: "1" + format: c_expression + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (m2_locked || (m1_locked || g2 == 0))' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (m2_locked || (m1_locked || g1 == 0))' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (0 <= g2 && g2 <= 1)' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (0 <= g1 && g1 <= 1)' + type: assertion + format: C + + $ goblint --set ana.base.privatization mutex-meet --enable witness.yaml.enabled --set ana.activated[+] mutexGhosts --set witness.yaml.entry-types '["flow_insensitive_invariant", "ghost_instrumentation"]' 64-ghost-multiple-protecting.c + [Info][Deadcode] Logical lines of code (LLoC) summary: + live: 19 + dead: 0 + total lines: 19 + [Info][Witness] witness generation summary: + location invariants: 0 + loop invariants: 0 + flow-insensitive invariants: 4 + total generation entries: 5 + [Info][Race] Memory locations race summary: + safe: 2 + vulnerable: 0 + unsafe: 0 + total memory locations: 2 + + $ yamlWitnessStrip < witness.yml + - entry_type: ghost_instrumentation + content: + ghost_variables: + - name: m1_locked + scope: global + type: int + initial: + value: "0" + format: c_expression + - name: m2_locked + scope: global + type: int + initial: + value: "0" + format: c_expression + - name: multithreaded + scope: global + type: int + initial: + value: "0" + format: c_expression + ghost_updates: + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 9 + column: 3 + function: t_fun + updates: + - variable: m1_locked + value: "1" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 10 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "1" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 13 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "0" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 14 + column: 3 + function: t_fun + updates: + - variable: m1_locked + value: "0" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 16 + column: 3 + function: t_fun + updates: + - variable: m1_locked + value: "1" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 17 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "1" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 19 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "0" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 20 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "1" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 22 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "0" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 23 + column: 3 + function: t_fun + updates: + - variable: m1_locked + value: "0" + format: c_expression + - location: + file_name: 64-ghost-multiple-protecting.c + file_hash: $FILE_HASH + line: 29 + column: 3 + function: main + updates: + - variable: multithreaded + value: "1" + format: c_expression + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (m2_locked || ((0 <= g2 && g2 <= 1) && g1 == 0))' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (m1_locked || (g1 == 0 && g2 == 0))' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (0 <= g2 && g2 <= 1)' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (0 <= g1 && g1 <= 1)' + type: assertion + format: C diff --git a/tests/regression/56-witness/65-ghost-ambiguous-lock.c b/tests/regression/56-witness/65-ghost-ambiguous-lock.c new file mode 100644 index 0000000000..7719c0cec4 --- /dev/null +++ b/tests/regression/56-witness/65-ghost-ambiguous-lock.c @@ -0,0 +1,44 @@ +// PARAM: --set ana.activated[+] mutexGhosts +#include +#include +// CRAM +int g1, g2; +pthread_mutex_t m1 = PTHREAD_MUTEX_INITIALIZER; +pthread_mutex_t m2 = PTHREAD_MUTEX_INITIALIZER; + +void *t_fun(void *arg) { + pthread_mutex_lock(&m1); + g1 = 1; + g1 = 0; + pthread_mutex_unlock(&m1); + pthread_mutex_lock(&m2); + g2 = 1; + g2 = 0; + pthread_mutex_unlock(&m2); + return NULL; +} + +void fun(pthread_mutex_t *m) { + pthread_mutex_lock(m); + // what g2 can read? + pthread_mutex_unlock(m); +} + +int main() { + pthread_t id; + pthread_create(&id, NULL, t_fun, NULL); + + pthread_mutex_t *m; + int r; // rand + m = r ? &m1 : &m2; + + pthread_mutex_lock(m); + // what g1 can read? + pthread_mutex_unlock(m); + + if (r) + fun(&m1); + else + fun(&m2); + return 0; +} diff --git a/tests/regression/56-witness/65-ghost-ambiguous-lock.t b/tests/regression/56-witness/65-ghost-ambiguous-lock.t new file mode 100644 index 0000000000..36df2e4576 --- /dev/null +++ b/tests/regression/56-witness/65-ghost-ambiguous-lock.t @@ -0,0 +1,47 @@ + $ goblint --set ana.base.privatization protection --enable witness.yaml.enabled --set ana.activated[+] mutexGhosts --set witness.yaml.entry-types '["flow_insensitive_invariant", "ghost_instrumentation"]' 65-ghost-ambiguous-lock.c + [Info][Deadcode] Logical lines of code (LLoC) summary: + live: 23 + dead: 0 + total lines: 23 + [Info][Witness] witness generation summary: + location invariants: 0 + loop invariants: 0 + flow-insensitive invariants: 2 + total generation entries: 3 + [Info][Race] Memory locations race summary: + safe: 2 + vulnerable: 0 + unsafe: 0 + total memory locations: 2 + + $ yamlWitnessStrip < witness.yml + - entry_type: ghost_instrumentation + content: + ghost_variables: + - name: multithreaded + scope: global + type: int + initial: + value: "0" + format: c_expression + ghost_updates: + - location: + file_name: 65-ghost-ambiguous-lock.c + file_hash: $FILE_HASH + line: 29 + column: 3 + function: main + updates: + - variable: multithreaded + value: "1" + format: c_expression + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (0 <= g2 && g2 <= 1)' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (0 <= g1 && g1 <= 1)' + type: assertion + format: C diff --git a/tests/regression/56-witness/66-ghost-alloc-lock.c b/tests/regression/56-witness/66-ghost-alloc-lock.c new file mode 100644 index 0000000000..073540b9db --- /dev/null +++ b/tests/regression/56-witness/66-ghost-alloc-lock.c @@ -0,0 +1,37 @@ +// PARAM: --set ana.activated[+] mutexGhosts --set ana.malloc.unique_address_count 1 +#include +#include + +int g1, g2; +pthread_mutex_t *m1; +pthread_mutex_t *m2; + +void *t_fun(void *arg) { + pthread_mutex_lock(m1); + g1 = 1; + g1 = 0; + pthread_mutex_unlock(m1); + pthread_mutex_lock(m2); + g2 = 1; + g2 = 0; + pthread_mutex_unlock(m2); + return NULL; +} + +int main() { + m1 = malloc(sizeof(pthread_mutex_t)); + pthread_mutex_init(m1, NULL); + m2 = malloc(sizeof(pthread_mutex_t)); + pthread_mutex_init(m2, NULL); + + pthread_t id; + pthread_create(&id, NULL, t_fun, NULL); + + pthread_mutex_lock(m1); + __goblint_check(g1 == 0); + pthread_mutex_unlock(m1); + pthread_mutex_lock(m2); + __goblint_check(g2 == 0); + pthread_mutex_unlock(m2); + return 0; +} diff --git a/tests/regression/56-witness/66-ghost-alloc-lock.t b/tests/regression/56-witness/66-ghost-alloc-lock.t new file mode 100644 index 0000000000..09c7c4250b --- /dev/null +++ b/tests/regression/56-witness/66-ghost-alloc-lock.t @@ -0,0 +1,151 @@ + $ goblint --set ana.base.privatization protection --enable witness.yaml.enabled --set ana.activated[+] mutexGhosts --set ana.malloc.unique_address_count 1 --set witness.yaml.entry-types '["flow_insensitive_invariant", "ghost_instrumentation"]' 66-ghost-alloc-lock.c + [Success][Assert] Assertion "g1 == 0" will succeed (66-ghost-alloc-lock.c:31:3-31:27) + [Success][Assert] Assertion "g2 == 0" will succeed (66-ghost-alloc-lock.c:34:3-34:27) + [Info][Deadcode] Logical lines of code (LLoC) summary: + live: 23 + dead: 0 + total lines: 23 + [Info][Witness] witness generation summary: + location invariants: 0 + loop invariants: 0 + flow-insensitive invariants: 4 + total generation entries: 5 + [Info][Race] Memory locations race summary: + safe: 4 + vulnerable: 0 + unsafe: 0 + total memory locations: 4 + + $ yamlWitnessStrip < witness.yml + - entry_type: ghost_instrumentation + content: + ghost_variables: + - name: alloc_m559918035_locked + scope: global + type: int + initial: + value: "0" + format: c_expression + - name: alloc_m861095507_locked + scope: global + type: int + initial: + value: "0" + format: c_expression + - name: multithreaded + scope: global + type: int + initial: + value: "0" + format: c_expression + ghost_updates: + - location: + file_name: 66-ghost-alloc-lock.c + file_hash: $FILE_HASH + line: 10 + column: 3 + function: t_fun + updates: + - variable: alloc_m559918035_locked + value: "1" + format: c_expression + - location: + file_name: 66-ghost-alloc-lock.c + file_hash: $FILE_HASH + line: 13 + column: 3 + function: t_fun + updates: + - variable: alloc_m559918035_locked + value: "0" + format: c_expression + - location: + file_name: 66-ghost-alloc-lock.c + file_hash: $FILE_HASH + line: 14 + column: 3 + function: t_fun + updates: + - variable: alloc_m861095507_locked + value: "1" + format: c_expression + - location: + file_name: 66-ghost-alloc-lock.c + file_hash: $FILE_HASH + line: 17 + column: 3 + function: t_fun + updates: + - variable: alloc_m861095507_locked + value: "0" + format: c_expression + - location: + file_name: 66-ghost-alloc-lock.c + file_hash: $FILE_HASH + line: 28 + column: 3 + function: main + updates: + - variable: multithreaded + value: "1" + format: c_expression + - location: + file_name: 66-ghost-alloc-lock.c + file_hash: $FILE_HASH + line: 30 + column: 3 + function: main + updates: + - variable: alloc_m559918035_locked + value: "1" + format: c_expression + - location: + file_name: 66-ghost-alloc-lock.c + file_hash: $FILE_HASH + line: 32 + column: 3 + function: main + updates: + - variable: alloc_m559918035_locked + value: "0" + format: c_expression + - location: + file_name: 66-ghost-alloc-lock.c + file_hash: $FILE_HASH + line: 33 + column: 3 + function: main + updates: + - variable: alloc_m861095507_locked + value: "1" + format: c_expression + - location: + file_name: 66-ghost-alloc-lock.c + file_hash: $FILE_HASH + line: 35 + column: 3 + function: main + updates: + - variable: alloc_m861095507_locked + value: "0" + format: c_expression + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (alloc_m861095507_locked || g2 == 0)' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (alloc_m559918035_locked || g1 == 0)' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (0 <= g2 && g2 <= 1)' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (0 <= g1 && g1 <= 1)' + type: assertion + format: C diff --git a/tests/regression/56-witness/67-ghost-no-unlock.c b/tests/regression/56-witness/67-ghost-no-unlock.c new file mode 100644 index 0000000000..69ad571118 --- /dev/null +++ b/tests/regression/56-witness/67-ghost-no-unlock.c @@ -0,0 +1,27 @@ +// PARAM: --set ana.activated[+] mutexGhosts +#include +#include + +int g1; +pthread_mutex_t m1 = PTHREAD_MUTEX_INITIALIZER; + +void *t_fun(void *arg) { + pthread_mutex_lock(&m1); + g1 = 1; + g1 = 0; + pthread_mutex_unlock(&m1); + return NULL; +} + +int main() { + + + + pthread_t id; + pthread_create(&id, NULL, t_fun, NULL); + + pthread_mutex_lock(&m1); + __goblint_check(g1 == 0); + // no unlock + return 0; // there should be no ghost updates for unlock here +} diff --git a/tests/regression/56-witness/67-ghost-no-unlock.t b/tests/regression/56-witness/67-ghost-no-unlock.t new file mode 100644 index 0000000000..c49daf3e24 --- /dev/null +++ b/tests/regression/56-witness/67-ghost-no-unlock.t @@ -0,0 +1,84 @@ + $ goblint --set ana.base.privatization protection --enable witness.yaml.enabled --set ana.activated[+] mutexGhosts --set witness.yaml.entry-types '["flow_insensitive_invariant", "ghost_instrumentation"]' 67-ghost-no-unlock.c + [Success][Assert] Assertion "g1 == 0" will succeed (67-ghost-no-unlock.c:24:3-24:27) + [Info][Deadcode] Logical lines of code (LLoC) summary: + live: 11 + dead: 0 + total lines: 11 + [Info][Witness] witness generation summary: + location invariants: 0 + loop invariants: 0 + flow-insensitive invariants: 2 + total generation entries: 3 + [Info][Race] Memory locations race summary: + safe: 1 + vulnerable: 0 + unsafe: 0 + total memory locations: 1 + + $ yamlWitnessStrip < witness.yml + - entry_type: ghost_instrumentation + content: + ghost_variables: + - name: m1_locked + scope: global + type: int + initial: + value: "0" + format: c_expression + - name: multithreaded + scope: global + type: int + initial: + value: "0" + format: c_expression + ghost_updates: + - location: + file_name: 67-ghost-no-unlock.c + file_hash: $FILE_HASH + line: 9 + column: 3 + function: t_fun + updates: + - variable: m1_locked + value: "1" + format: c_expression + - location: + file_name: 67-ghost-no-unlock.c + file_hash: $FILE_HASH + line: 12 + column: 3 + function: t_fun + updates: + - variable: m1_locked + value: "0" + format: c_expression + - location: + file_name: 67-ghost-no-unlock.c + file_hash: $FILE_HASH + line: 21 + column: 3 + function: main + updates: + - variable: multithreaded + value: "1" + format: c_expression + - location: + file_name: 67-ghost-no-unlock.c + file_hash: $FILE_HASH + line: 23 + column: 3 + function: main + updates: + - variable: m1_locked + value: "1" + format: c_expression + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (m1_locked || g1 == 0)' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (0 <= g1 && g1 <= 1)' + type: assertion + format: C diff --git a/tests/regression/56-witness/68-ghost-ambiguous-idx.c b/tests/regression/56-witness/68-ghost-ambiguous-idx.c new file mode 100644 index 0000000000..7babbe003c --- /dev/null +++ b/tests/regression/56-witness/68-ghost-ambiguous-idx.c @@ -0,0 +1,28 @@ +#include +#include + +int data; +pthread_mutex_t m[10]; + +void *t_fun(void *arg) { + pthread_mutex_lock(&m[4]); + data++; + data--; + pthread_mutex_unlock(&m[4]); + return NULL; +} + +int main() { + for (int i = 0; i < 10; i++) + pthread_mutex_init(&m[i], NULL); + + pthread_t id; + pthread_create(&id, NULL, t_fun, NULL); + int r; + int j = r ? 4 : 5; + pthread_mutex_lock(&m[r]); + __goblint_check(data == 0); // UNKNOWN! + pthread_mutex_unlock(&m[4]); + return 0; +} + diff --git a/tests/regression/56-witness/68-ghost-ambiguous-idx.t b/tests/regression/56-witness/68-ghost-ambiguous-idx.t new file mode 100644 index 0000000000..40025acf17 --- /dev/null +++ b/tests/regression/56-witness/68-ghost-ambiguous-idx.t @@ -0,0 +1,48 @@ + $ goblint --set ana.base.privatization protection --enable witness.yaml.enabled --set ana.activated[+] mutexGhosts --set witness.yaml.entry-types '["flow_insensitive_invariant", "ghost_instrumentation"]' 68-ghost-ambiguous-idx.c + [Warning][Assert] Assertion "data == 0" is unknown. (68-ghost-ambiguous-idx.c:24:3-24:29) + [Warning][Unknown] unlocking mutex (m[4]) which may not be held (68-ghost-ambiguous-idx.c:25:3-25:30) + [Info][Deadcode] Logical lines of code (LLoC) summary: + live: 15 + dead: 0 + total lines: 15 + [Warning][Race] Memory location data (race with conf. 110): (68-ghost-ambiguous-idx.c:4:5-4:9) + write with [lock:{m[4]}, thread:[main, t_fun@68-ghost-ambiguous-idx.c:20:3-20:40]] (conf. 110) (exp: & data) (68-ghost-ambiguous-idx.c:9:3-9:9) + write with [lock:{m[4]}, thread:[main, t_fun@68-ghost-ambiguous-idx.c:20:3-20:40]] (conf. 110) (exp: & data) (68-ghost-ambiguous-idx.c:10:3-10:9) + read with [mhp:{created={[main, t_fun@68-ghost-ambiguous-idx.c:20:3-20:40]}}, thread:[main]] (conf. 110) (exp: & data) (68-ghost-ambiguous-idx.c:24:3-24:29) + [Info][Witness] witness generation summary: + location invariants: 0 + loop invariants: 0 + flow-insensitive invariants: 1 + total generation entries: 2 + [Info][Race] Memory locations race summary: + safe: 0 + vulnerable: 0 + unsafe: 1 + total memory locations: 1 + + $ yamlWitnessStrip < witness.yml + - entry_type: ghost_instrumentation + content: + ghost_variables: + - name: multithreaded + scope: global + type: int + initial: + value: "0" + format: c_expression + ghost_updates: + - location: + file_name: 68-ghost-ambiguous-idx.c + file_hash: $FILE_HASH + line: 20 + column: 3 + function: main + updates: + - variable: multithreaded + value: "1" + format: c_expression + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (0 <= data && data <= 1)' + type: assertion + format: C diff --git a/tests/regression/56-witness/69-ghost-ptr-protection.c b/tests/regression/56-witness/69-ghost-ptr-protection.c new file mode 100644 index 0000000000..f5557f3fc8 --- /dev/null +++ b/tests/regression/56-witness/69-ghost-ptr-protection.c @@ -0,0 +1,30 @@ +// PARAM: --set ana.activated[+] mutexGhosts +// CRAM +#include +#include + +int g = 0; +int *p = &g; +pthread_mutex_t m1 = PTHREAD_MUTEX_INITIALIZER; +pthread_mutex_t m2 = PTHREAD_MUTEX_INITIALIZER; + +void *t_fun(void *arg) { + int x = 10; + pthread_mutex_lock(&m2); + p = &x; + p = &g; + pthread_mutex_unlock(&m2); + return NULL; +} + +int main() { + pthread_t id; + pthread_create(&id, NULL, t_fun, NULL); + pthread_mutex_lock(&m1); + g = 1; + // m2_locked || (p == & g && *p == 0) would be violated here + __goblint_check(*p != 0); // 1 from g or 10 from x in t_fun + g = 0; + pthread_mutex_unlock(&m1); + return 0; +} diff --git a/tests/regression/56-witness/69-ghost-ptr-protection.t b/tests/regression/56-witness/69-ghost-ptr-protection.t new file mode 100644 index 0000000000..53aa7dd34a --- /dev/null +++ b/tests/regression/56-witness/69-ghost-ptr-protection.t @@ -0,0 +1,116 @@ + $ goblint --set ana.base.privatization protection --enable witness.yaml.enabled --set ana.activated[+] mutexGhosts --set witness.yaml.entry-types '["flow_insensitive_invariant", "ghost_instrumentation"]' 69-ghost-ptr-protection.c + [Success][Assert] Assertion "*p != 0" will succeed (69-ghost-ptr-protection.c:26:3-26:27) + [Info][Deadcode] Logical lines of code (LLoC) summary: + live: 15 + dead: 0 + total lines: 15 + [Warning][Race] Memory location p (race with conf. 110): (69-ghost-ptr-protection.c:7:5-7:12) + write with [lock:{m2}, thread:[main, t_fun@69-ghost-ptr-protection.c:22:3-22:40]] (conf. 110) (exp: & p) (69-ghost-ptr-protection.c:14:3-14:9) + write with [lock:{m2}, thread:[main, t_fun@69-ghost-ptr-protection.c:22:3-22:40]] (conf. 110) (exp: & p) (69-ghost-ptr-protection.c:15:3-15:9) + read with [mhp:{created={[main, t_fun@69-ghost-ptr-protection.c:22:3-22:40]}}, lock:{m1}, thread:[main]] (conf. 110) (exp: & p) (69-ghost-ptr-protection.c:26:3-26:27) + [Info][Witness] witness generation summary: + location invariants: 0 + loop invariants: 0 + flow-insensitive invariants: 4 + total generation entries: 5 + [Info][Race] Memory locations race summary: + safe: 2 + vulnerable: 0 + unsafe: 1 + total memory locations: 3 + +Should not contain unsound flow-insensitive invariant m2_locked || (p == & g && *p == 0): + + $ yamlWitnessStrip < witness.yml + - entry_type: ghost_instrumentation + content: + ghost_variables: + - name: m1_locked + scope: global + type: int + initial: + value: "0" + format: c_expression + - name: m2_locked + scope: global + type: int + initial: + value: "0" + format: c_expression + - name: multithreaded + scope: global + type: int + initial: + value: "0" + format: c_expression + ghost_updates: + - location: + file_name: 69-ghost-ptr-protection.c + file_hash: $FILE_HASH + line: 13 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "1" + format: c_expression + - location: + file_name: 69-ghost-ptr-protection.c + file_hash: $FILE_HASH + line: 16 + column: 3 + function: t_fun + updates: + - variable: m2_locked + value: "0" + format: c_expression + - location: + file_name: 69-ghost-ptr-protection.c + file_hash: $FILE_HASH + line: 22 + column: 3 + function: main + updates: + - variable: multithreaded + value: "1" + format: c_expression + - location: + file_name: 69-ghost-ptr-protection.c + file_hash: $FILE_HASH + line: 23 + column: 3 + function: main + updates: + - variable: m1_locked + value: "1" + format: c_expression + - location: + file_name: 69-ghost-ptr-protection.c + file_hash: $FILE_HASH + line: 28 + column: 3 + function: main + updates: + - variable: m1_locked + value: "0" + format: c_expression + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (m2_locked || ((0 <= *p && *p <= 1) && p == & g))' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (m1_locked || g == 0)' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (0 <= g && g <= 1)' + type: assertion + format: C + - entry_type: flow_insensitive_invariant + flow_insensitive_invariant: + string: '! multithreaded || (*p == 10 || ((0 <= *p && *p <= 1) && p == & g))' + type: assertion + format: C diff --git a/tests/regression/56-witness/64-apron-unassume-set-tokens.c b/tests/regression/56-witness/70-apron-unassume-set-tokens.c similarity index 88% rename from tests/regression/56-witness/64-apron-unassume-set-tokens.c rename to tests/regression/56-witness/70-apron-unassume-set-tokens.c index 75a6b5eee5..6ff07f6064 100644 --- a/tests/regression/56-witness/64-apron-unassume-set-tokens.c +++ b/tests/regression/56-witness/70-apron-unassume-set-tokens.c @@ -1,4 +1,4 @@ -// SKIP PARAM: --set ana.activated[+] apron --set ana.activated[+] unassume --set witness.yaml.unassume 64-apron-unassume-set-tokens.yml --set ana.apron.domain polyhedra --enable ana.widen.tokens +// SKIP PARAM: --set ana.activated[+] apron --set ana.activated[+] unassume --set witness.yaml.unassume 70-apron-unassume-set-tokens.yml --set ana.apron.domain polyhedra --enable ana.widen.tokens #include // Uses polyhedra instead of octagon such that widening tokens are actually needed by test instead of narrowing. // Copied & extended from 56-witness/12-apron-unassume-branch. diff --git a/tests/regression/56-witness/64-apron-unassume-set-tokens.yml b/tests/regression/56-witness/70-apron-unassume-set-tokens.yml similarity index 82% rename from tests/regression/56-witness/64-apron-unassume-set-tokens.yml rename to tests/regression/56-witness/70-apron-unassume-set-tokens.yml index 8411ed045f..1fdc29067c 100644 --- a/tests/regression/56-witness/64-apron-unassume-set-tokens.yml +++ b/tests/regression/56-witness/70-apron-unassume-set-tokens.yml @@ -8,19 +8,19 @@ version: heads/yaml-witness-unassume-0-g48503c690-dirty command_line: '''./goblint'' ''--enable'' ''dbg.debug'' ''--enable'' ''dbg.regression'' ''--html'' ''--set'' ''ana.activated[+]'' ''apron'' ''--enable'' ''witness.yaml.enabled'' - ''64-apron-unassume-set-tokens.c''' + ''70-apron-unassume-set-tokens.c''' task: input_files: - - 64-apron-unassume-set-tokens.c + - 70-apron-unassume-set-tokens.c input_file_hashes: - 64-apron-unassume-set-tokens.c: 71e40ed99b5217343d0831e293e7207e5bd30ce53f6ab73f0c1ef6ced1afcc60 + 70-apron-unassume-set-tokens.c: 71e40ed99b5217343d0831e293e7207e5bd30ce53f6ab73f0c1ef6ced1afcc60 data_model: LP64 language: C content: - invariant: type: location_invariant location: - file_name: 64-apron-unassume-set-tokens.c + file_name: 70-apron-unassume-set-tokens.c file_hash: 71e40ed99b5217343d0831e293e7207e5bd30ce53f6ab73f0c1ef6ced1afcc60 line: 8 column: 3 @@ -30,7 +30,7 @@ - invariant: type: location_invariant location: - file_name: 64-apron-unassume-set-tokens.c + file_name: 70-apron-unassume-set-tokens.c file_hash: 71e40ed99b5217343d0831e293e7207e5bd30ce53f6ab73f0c1ef6ced1afcc60 line: 8 column: 3 @@ -40,7 +40,7 @@ - invariant: type: location_invariant location: - file_name: 64-apron-unassume-set-tokens.c + file_name: 70-apron-unassume-set-tokens.c file_hash: 71e40ed99b5217343d0831e293e7207e5bd30ce53f6ab73f0c1ef6ced1afcc60 line: 14 column: 3 @@ -50,7 +50,7 @@ - invariant: type: location_invariant location: - file_name: 64-apron-unassume-set-tokens.c + file_name: 70-apron-unassume-set-tokens.c file_hash: 71e40ed99b5217343d0831e293e7207e5bd30ce53f6ab73f0c1ef6ced1afcc60 line: 14 column: 3 diff --git a/tests/regression/cfg/util/dune b/tests/regression/cfg/util/dune index fb3c5e6899..8ab300b531 100644 --- a/tests/regression/cfg/util/dune +++ b/tests/regression/cfg/util/dune @@ -5,7 +5,5 @@ goblint_logs goblint_common goblint_lib ; TODO: avoid: extract LoopUnrolling and WitnessUtil node predicates from goblint_lib - fpath - goblint.sites.dune - goblint.build-info.dune) + fpath) (preprocess (pps ppx_deriving.std))) diff --git a/tests/unit/dune b/tests/unit/dune index 5f0b909a77..07c87e7822 100644 --- a/tests/unit/dune +++ b/tests/unit/dune @@ -2,7 +2,7 @@ (test (name mainTest) - (libraries ounit2 qcheck-ounit goblint.std goblint.common goblint.lib goblint.constraint goblint.solver goblint.cdomain.value goblint.sites.dune goblint.build-info.dune) + (libraries ounit2 qcheck-ounit goblint.std goblint.common goblint.lib goblint.constraint goblint.solver goblint.cdomain.value) (preprocess (pps ppx_deriving.std ppx_deriving_hash ppx_deriving_yojson)) (flags :standard -linkall)) diff --git a/tests/util/dune b/tests/util/dune index 0e32304d4f..00ae40a0b9 100644 --- a/tests/util/dune +++ b/tests/util/dune @@ -1,11 +1,14 @@ (executables - (names yamlWitnessStrip yamlWitnessStripDiff) + (names yamlWitnessStrip yamlWitnessStripDiff multilibConfigure) (libraries batteries.unthreaded + goblint-cil goblint_std goblint_lib - yaml - goblint.sites.dune - goblint.build-info.dune) + yaml) (flags :standard -open Goblint_std) (preprocess (pps ppx_deriving.std))) + +(rule + (target multilibAvailable) + (action (with-stdout-to %{target} (run ./multilibConfigure.exe)))) diff --git a/tests/util/multilibConfigure.ml b/tests/util/multilibConfigure.ml new file mode 100644 index 0000000000..96cf9a706a --- /dev/null +++ b/tests/util/multilibConfigure.ml @@ -0,0 +1,4 @@ +open GoblintCil + +let () = + Printf.printf "%B" (Option.is_some Machdep.gcc32 && Option.is_some Machdep.gcc64) diff --git a/tests/util/yamlWitnessStripCommon.ml b/tests/util/yamlWitnessStripCommon.ml index d1656d3ddc..39bc231d72 100644 --- a/tests/util/yamlWitnessStripCommon.ml +++ b/tests/util/yamlWitnessStripCommon.ml @@ -50,6 +50,12 @@ struct let segment_strip_file_hash ({segment}: ViolationSequence.Segment.t): ViolationSequence.Segment.t = {segment = List.map waypoint_strip_file_hash segment} in + let ghost_location_update_strip_file_hash (x: GhostInstrumentation.LocationUpdate.t): GhostInstrumentation.LocationUpdate.t = + { + location = location_strip_file_hash x.location; + updates = List.sort GhostInstrumentation.Update.compare x.updates + } + in let entry_type: EntryType.t = match entry_type with | LocationInvariant x -> @@ -65,9 +71,14 @@ struct | PreconditionLoopInvariantCertificate x -> PreconditionLoopInvariantCertificate {x with target = target_strip_file_hash x.target} | InvariantSet x -> - InvariantSet {content = List.map invariant_strip_file_hash x.content} + InvariantSet {content = List.sort InvariantSet.Invariant.compare (List.map invariant_strip_file_hash x.content)} (* Sort, so order is deterministic regardless of Goblint. *) | ViolationSequence x -> ViolationSequence {content = List.map segment_strip_file_hash x.content} + | GhostInstrumentation x -> + GhostInstrumentation { (* Sort, so order is deterministic regardless of Goblint. *) + ghost_variables = List.sort GhostInstrumentation.Variable.compare x.ghost_variables; + ghost_updates = List.sort GhostInstrumentation.LocationUpdate.compare (List.map ghost_location_update_strip_file_hash x.ghost_updates); + } in {entry_type}