diff --git a/.github/workflows/coverage.yml b/.github/workflows/coverage.yml index 0208af7c7a..4b47a66e15 100644 --- a/.github/workflows/coverage.yml +++ b/.github/workflows/coverage.yml @@ -88,7 +88,7 @@ jobs: COVERALLS_REPO_TOKEN: ${{ secrets.COVERALLS_REPO_TOKEN }} PULL_REQUEST_NUMBER: ${{ github.event.number }} - - uses: actions/upload-artifact@v3 + - uses: actions/upload-artifact@v4 if: always() with: name: suite_result diff --git a/.github/workflows/docs.yml b/.github/workflows/docs.yml index e1648904c3..1d73e037f4 100644 --- a/.github/workflows/docs.yml +++ b/.github/workflows/docs.yml @@ -46,7 +46,7 @@ jobs: - name: Setup Pages id: pages - uses: actions/configure-pages@v3 + uses: actions/configure-pages@v4 - name: Install dependencies run: opam install . --deps-only --locked --with-doc @@ -68,4 +68,4 @@ jobs: steps: - name: Deploy to GitHub Pages id: deployment - uses: actions/deploy-pages@v2 + uses: actions/deploy-pages@v3 diff --git a/.github/workflows/locked.yml b/.github/workflows/locked.yml index 8604e7f52c..e25ccfcea1 100644 --- a/.github/workflows/locked.yml +++ b/.github/workflows/locked.yml @@ -82,10 +82,10 @@ jobs: - name: Test incremental regression with cfg comparison run: ruby scripts/update_suite.rb -c - - uses: actions/upload-artifact@v3 + - uses: actions/upload-artifact@v4 if: always() with: - name: suite_result + name: suite_result-${{ matrix.os }} path: tests/suite_result/ extraction: diff --git a/.github/workflows/options.yml b/.github/workflows/options.yml index 94c49e4bf6..7ef8b6929e 100644 --- a/.github/workflows/options.yml +++ b/.github/workflows/options.yml @@ -26,10 +26,10 @@ jobs: run: npm install -g ajv-cli - name: Migrate schema # https://github.com/ajv-validator/ajv-cli/issues/199 - run: ajv migrate -s src/common/util/options.schema.json + run: ajv migrate -s src/config/options.schema.json - name: Validate conf - run: ajv validate -s src/common/util/options.schema.json -d "conf/**/*.json" + run: ajv validate -s src/config/options.schema.json -d "conf/**/*.json" - name: Validate incremental tests - run: ajv validate -s src/common/util/options.schema.json -d "tests/incremental/*/*.json" + run: ajv validate -s src/config/options.schema.json -d "tests/incremental/*/*.json" diff --git a/.github/workflows/semgrep.yml b/.github/workflows/semgrep.yml index bd2dfd285c..c22eee5181 100644 --- a/.github/workflows/semgrep.yml +++ b/.github/workflows/semgrep.yml @@ -22,7 +22,7 @@ jobs: run: semgrep scan --config .semgrep/ --sarif > semgrep.sarif - name: Upload SARIF file to GitHub Advanced Security Dashboard - uses: github/codeql-action/upload-sarif@v2 + uses: github/codeql-action/upload-sarif@v3 with: sarif_file: semgrep.sarif if: always() diff --git a/.gitignore b/.gitignore index 75bd23d36b..faf1513653 100644 --- a/.gitignore +++ b/.gitignore @@ -29,7 +29,6 @@ linux-headers .goblint*/ goblint_temp_*/ -src/spec/graph .vagrant g2html.jar diff --git a/.readthedocs.yaml b/.readthedocs.yaml index 08044d195c..22f9c86121 100644 --- a/.readthedocs.yaml +++ b/.readthedocs.yaml @@ -20,4 +20,4 @@ build: - pip install json-schema-for-humans post_build: - mkdir _readthedocs/html/jsfh/ - - generate-schema-doc --config-file jsfh.yml src/common/util/options.schema.json _readthedocs/html/jsfh/ + - generate-schema-doc --config-file jsfh.yml src/config/options.schema.json _readthedocs/html/jsfh/ diff --git a/docs/developer-guide/messaging.md b/docs/developer-guide/messaging.md index 28f24bc49c..0028d51f87 100644 --- a/docs/developer-guide/messaging.md +++ b/docs/developer-guide/messaging.md @@ -47,16 +47,3 @@ The `~loc` argument is optional and defaults to the current location, but allows The `_noloc` suffixed functions allow general messages without any location (not even current). By convention, may-warnings (the usual case) should use warning severity and must-warnings should use error severity. - -### Spec analysis - -Warnings inside `.spec` files are converted to warnings. -They parsed from string warnings: the first space-delimited substring determines the category and the rest determines the text. - -For example: -``` -w1 "behavior.undefined.use_after_free" -w2 "integer.overflow" -w3 "unknown my message" -w4 "integer.overflow some text describing the warning" -``` diff --git a/docs/developer-guide/releasing.md b/docs/developer-guide/releasing.md index fcf69ea533..d875c0d3bf 100644 --- a/docs/developer-guide/releasing.md +++ b/docs/developer-guide/releasing.md @@ -70,7 +70,7 @@ This is required such that the created archive would have everything in a single directory called `goblint`. -4. Update SV-COMP year in `sv-comp/archive.sh`. +4. Update SV-COMP year in `scripts/sv-comp/archive.sh`. This includes: git tag name, git tag message and zipped conf file. @@ -83,9 +83,9 @@ 2. Make sure you have nothing valuable that would be deleted by `make clean`. 3. Delete git tag from previous prerun: `git tag -d svcompXY`. -4. Create archive: `./sv-comp/archive.sh`. +4. Create archive: `./scripts/sv-comp/archive.sh`. - The resulting archive is `sv-comp/goblint.zip`. + The resulting archive is `scripts/sv-comp/goblint.zip`. 5. Check unextracted archive in latest SV-COMP container image: . diff --git a/docs/user-guide/configuring.md b/docs/user-guide/configuring.md index 9a32a14a4c..cae57fc8cd 100644 --- a/docs/user-guide/configuring.md +++ b/docs/user-guide/configuring.md @@ -24,7 +24,7 @@ In `.vscode/settings.json` add the following: "/conf/*.json", "/tests/incremental/*/*.json" ], - "url": "/src/common/util/options.schema.json" + "url": "/src/config/options.schema.json" } ] } diff --git a/docs/user-guide/inspecting.md b/docs/user-guide/inspecting.md index f4f6036f1b..266a4866c6 100644 --- a/docs/user-guide/inspecting.md +++ b/docs/user-guide/inspecting.md @@ -23,3 +23,20 @@ To build GobView (also for development): `./_build/default/gobview/goblint-http-server/goblint_http.exe -with-goblint ../analyzer/goblint -goblint --set files[+] "../analyzer/tests/regression/00-sanity/01-assert.c"` 4. Visit + +## Witnesses + +### GraphML + +#### yEd + +1. Open (Ctrl+o) `witness.graphml` from Goblint root directory. +2. Click menu "Edit" → "Properties Mapper". + 1. _First time:_ Click button "Imports additional configurations" and open `scripts/sv-comp/yed-sv-comp.cnfx`. + 2. Select "SV-COMP (Node)" and click "Apply". + 3. Select "SV-COMP (Edge)" and click "Ok". +3. Click menu "Layout" → "Hierarchial" (Alt+shift+h). + 1. _First time:_ Click tab "Labeling", select "Hierarchic" in "Edge Labeling". + 2. Click "Ok". + +yEd manual for the Properties Mapper: . diff --git a/docs/user-guide/running.md b/docs/user-guide/running.md index 97d2587be8..aac1c21ca6 100644 --- a/docs/user-guide/running.md +++ b/docs/user-guide/running.md @@ -67,3 +67,20 @@ Here is a list of issues and workarounds for different compilation database gene #### bear 1. Bear 2.3.11 from Ubuntu 18.04 produces incomplete database (, ). * Bear 3.0.8 seems fine. + + +## SV-COMP +The most up-to-date SV-COMP configuration is in `conf/svcomp.json`. +There are also per-year configurations (e.g. `conf/svcomp24.json`) which try to reflect that year's submission using current option names. +Due to unconfigurable changes (e.g. bug fixes) these do not _exactly_ behave as that year's submission. +See SV-COMP submissions in GitHub releases for exact submitted versions. + +In SV-COMP Goblint is run as follows: +```console +./goblint --conf conf/svcomp.json --set ana.specification property.prp --set exp.architecture {32bit,64bit} input.c +``` + +Goblint YAML correctness witness validator is run as: +```console +./goblint --conf conf/svcomp.json --set ana.specification property.prp --set exp.architecture {32bit,64bit} --set witness.yaml.unassume witness.yml --set witness.yaml.validate witness.yml input.c +``` diff --git a/dune-project b/dune-project index 81c8d2f091..37e81f4199 100644 --- a/dune-project +++ b/dune-project @@ -25,7 +25,7 @@ (depends (ocaml (>= 4.10)) (goblint-cil (>= 2.0.3)) ; TODO no way to define as pin-depends? Used goblint.opam.template to add it for now. https://github.com/ocaml/dune/issues/3231. Alternatively, removing this line and adding cil as a git submodule and `(vendored_dirs cil)` as ./dune also works. This way, no more need to reinstall the pinned cil opam package on changes. However, then cil is cleaned and has to be rebuild together with goblint. - (batteries (>= 3.5.0)) + (batteries (>= 3.5.1)) (zarith (>= 1.8)) (yojson (>= 2.0.0)) (qcheck-core (>= 0.19)) diff --git a/goblint.opam b/goblint.opam index 669b2d9c40..b5f1f360dc 100644 --- a/goblint.opam +++ b/goblint.opam @@ -22,7 +22,7 @@ depends: [ "dune" {>= "3.7"} "ocaml" {>= "4.10"} "goblint-cil" {>= "2.0.3"} - "batteries" {>= "3.5.0"} + "batteries" {>= "3.5.1"} "zarith" {>= "1.8"} "yojson" {>= "2.0.0"} "qcheck-core" {>= "0.19"} diff --git a/gobview b/gobview index d4eb66b9eb..c8fcb09e9a 160000 --- a/gobview +++ b/gobview @@ -1 +1 @@ -Subproject commit d4eb66b9eb277349a75141cb01899dbab9d3ef5d +Subproject commit c8fcb09e9a3e27de22d4803606d5784f667a542a diff --git a/scripts/goblint-lib-modules.py b/scripts/goblint-lib-modules.py index 5f02271616..8ae3b4b3eb 100755 --- a/scripts/goblint-lib-modules.py +++ b/scripts/goblint-lib-modules.py @@ -8,6 +8,7 @@ goblint_lib_paths = [ src_root_path / "goblint_lib.ml", + src_root_path / "solver" / "goblint_solver.ml", src_root_path / "util" / "std" / "goblint_std.ml", ] goblint_lib_modules = set() @@ -30,20 +31,19 @@ "MessagesCompare", "PrivPrecCompare", "ApronPrecCompare", - "Mainspec", # libraries "Goblint_std", + "Goblint_solver", "Goblint_timing", "Goblint_backtrace", + "Goblint_tracing", "Goblint_sites", "Goblint_build_info", "Dune_build_info", "MessageCategory", # included in Messages "PreValueDomain", # included in ValueDomain - "SpecCore", # spec stuff - "SpecUtil", # spec stuff "ConfigVersion", "ConfigProfile", diff --git a/scripts/regression2sv-benchmarks.py b/scripts/regression2sv-benchmarks.py index 8f74a70f52..7bcc1c7ea3 100755 --- a/scripts/regression2sv-benchmarks.py +++ b/scripts/regression2sv-benchmarks.py @@ -31,7 +31,6 @@ "09-regions_34-escape_rc", # duplicate of 04/45 "09-regions_35-list2_rc-offsets-thread", # duplicate of 09/03 "10-synch_17-glob_fld_nr", # duplicate of 05/08 - "19-spec_02-mutex_rc", # duplicate of 04/01 "29-svcomp_01-race-2_3b-container_of", # duplicate sv-benchmarks "29-svcomp_01-race-2_4b-container_of", # duplicate sv-benchmarks diff --git a/scripts/spec/check.sh b/scripts/spec/check.sh deleted file mode 100755 index 57b63edfd2..0000000000 --- a/scripts/spec/check.sh +++ /dev/null @@ -1,27 +0,0 @@ -export OCAMLRUNPARAM=b -# file to analyze -file=${1-"tests/file.c"} -# analysis to run or spec file -ana=${2-"tests/regression/18-file/file.optimistic.spec"} -debug=${debug-"true"} -if [ $ana == "file" ]; then - ana="file" - opt="--set ana.file.optimistic true" -else - spec=$ana - ana="spec" - opt="--set ana.spec.file $spec" -fi -cmd="./goblint --set ana.activated[0][+] $ana $opt --html --set warn.debug $debug $file" -echo -e "$(tput setaf 6)$cmd$(tput sgr 0)" -$cmd - - -# # focuses Firefox and reloads current tab -# if false && command -v xdotool >/dev/null 2>&1; then -# WID=`xdotool search --name "Mozilla Firefox" | head -1` -# xdotool windowactivate $WID -# #xdotool key F5 -# # reload is done by add-on Auto Reload (reload result/* on change of report.html) -# # https://addons.mozilla.org/en-US/firefox/addon/auto-reload/?src=api -# fi diff --git a/scripts/spec/regression.py b/scripts/spec/regression.py deleted file mode 100755 index dc9f9fa276..0000000000 --- a/scripts/spec/regression.py +++ /dev/null @@ -1,61 +0,0 @@ -# import fileinput -# for line in fileinput.input(): -# pass - -import sys, os -import re - -if len(sys.argv) != 2: - print("Stdin: output from goblint, 1. argument: C source-file") - sys.exit(1) -path = sys.argv[1] - -goblint = {} -for line in sys.stdin.readlines(): - line = re.sub(r"\033.*?m", "", line) - m = re.match(r"(.+) \("+re.escape(path)+":(.+)\)", line) - if m: goblint[int(m.group(2))] = m.group(1) - -source = {} -lines = open(path).readlines() -for i,line in zip(range(1, len(lines)+1), lines): - m = re.match(r".+ // WARN: (.+)", line) - if m: source[i] = m.group(1) - -diff = {}; -for k,v in sorted(set.union(set(goblint.items()), set(source.items()))): - if k in diff: continue - if k in goblint and k in source and goblint[k]!=source[k]: - diff[k] = ('D', [goblint[k], source[k]]) - elif (k,v) in goblint.items() and (k,v) not in source.items(): - diff[k] = ('G', [goblint[k]]) - elif (k,v) not in goblint.items() and (k,v) in source.items(): - diff[k] = ('S', [source[k]]) - -if not len(diff): - sys.exit(0) - -print("#"*50) -print(path) -print("file://"+os.getcwd()+"/result/"+os.path.basename(path)+".html") - -if len(goblint): - print("## Goblint warnings:") - for k,v in sorted(goblint.items()): - print("{} \t {}".format(k, v)) - print - -if len(source): - print("## Source warnings:") - for k,v in source.items(): - print("{} \t {}".format(k, v)) - print - -if len(diff): - print("## Diff (G..only goblint, S..only source, D..different):") - for k,(s,v) in sorted(diff.items()): - print("{} {} \t {}".format(s, k, v[0])) - for v in v[1:]: print("\t {}".format(v)) - -print -sys.exit(1) \ No newline at end of file diff --git a/scripts/spec/regression.sh b/scripts/spec/regression.sh deleted file mode 100755 index 6dc740ca75..0000000000 --- a/scripts/spec/regression.sh +++ /dev/null @@ -1,18 +0,0 @@ -debug_tmp=$debug -export debug=false # temporarily disable debug output -n=0 -c=0 -dir=${2-"tests/regression/18-file"} -for f in $dir/*.c; do - ./scripts/spec/check.sh $f ${1-"file"} 2>/dev/null | python scripts/spec/regression.py $f && ((c++)) - ((n++)) -done -debug=$debug_tmp -msg="passed $c/$n tests" -echo $msg -if [ $c -eq $n ]; then - exit 0 -else - notify-send -i stop "$msg" - exit 1 -fi diff --git a/scripts/spec/spec.sh b/scripts/spec/spec.sh deleted file mode 100755 index 03abe9a0c7..0000000000 --- a/scripts/spec/spec.sh +++ /dev/null @@ -1,10 +0,0 @@ -# print all states the parser goes through -#export OCAMLRUNPARAM='p' -bin=src/mainspec.native -spec=${1-"tests/regression/18-file/file.spec"} -ocamlbuild -yaccflag -v -X webapp -no-links -use-ocamlfind $bin \ - && (./_build/$bin $spec \ - || (echo "$spec failed, running interactive now..."; - rlwrap ./_build/$bin - ) - ) diff --git a/sv-comp/archive.sh b/scripts/sv-comp/archive.sh similarity index 93% rename from sv-comp/archive.sh rename to scripts/sv-comp/archive.sh index 5d8605dc70..37fa2758d9 100755 --- a/sv-comp/archive.sh +++ b/scripts/sv-comp/archive.sh @@ -23,9 +23,9 @@ wget -O lib/LICENSE.APRON https://raw.githubusercontent.com/antoinemine/apron/ma # done outside to ensure archive contains goblint/ directory cd .. -rm goblint/sv-comp/goblint.zip +rm goblint/scripts/sv-comp/goblint.zip -zip goblint/sv-comp/goblint.zip \ +zip goblint/scripts/sv-comp/goblint.zip \ goblint/goblint \ goblint/lib/libapron.so \ goblint/lib/liboctD.so \ diff --git a/sv-comp/sv-comp-run-no-overflow.py b/scripts/sv-comp/sv-comp-run-no-overflow.py similarity index 100% rename from sv-comp/sv-comp-run-no-overflow.py rename to scripts/sv-comp/sv-comp-run-no-overflow.py diff --git a/sv-comp/sv-comp-run.py b/scripts/sv-comp/sv-comp-run.py similarity index 100% rename from sv-comp/sv-comp-run.py rename to scripts/sv-comp/sv-comp-run.py diff --git a/sv-comp/witness-isomorphism.py b/scripts/sv-comp/witness-isomorphism.py similarity index 100% rename from sv-comp/witness-isomorphism.py rename to scripts/sv-comp/witness-isomorphism.py diff --git a/sv-comp/yed-sv-comp.cnfx b/scripts/sv-comp/yed-sv-comp.cnfx similarity index 100% rename from sv-comp/yed-sv-comp.cnfx rename to scripts/sv-comp/yed-sv-comp.cnfx diff --git a/src/analyses/accessAnalysis.ml b/src/analyses/accessAnalysis.ml index b181a1c70e..efad8b4c2e 100644 --- a/src/analyses/accessAnalysis.ml +++ b/src/analyses/accessAnalysis.ml @@ -29,7 +29,7 @@ struct let init _ = collect_local := get_bool "witness.yaml.enabled" && get_bool "witness.invariant.accessed"; let activated = get_string_list "ana.activated" in - emit_single_threaded := List.mem (ModifiedSinceLongjmp.Spec.name ()) activated || List.mem (PoisonVariables.Spec.name ()) activated + emit_single_threaded := List.mem (ModifiedSinceSetjmp.Spec.name ()) activated || List.mem (PoisonVariables.Spec.name ()) activated let do_access (ctx: (D.t, G.t, C.t, V.t) ctx) (kind:AccessKind.t) (reach:bool) (e:exp) = if M.tracing then M.trace "access" "do_access %a %a %B\n" d_exp e AccessKind.pretty kind reach; diff --git a/src/analyses/apron/affineEqualityAnalysis.apron.ml b/src/analyses/apron/affineEqualityAnalysis.apron.ml index 03a9ecdb57..ce859d87b7 100644 --- a/src/analyses/apron/affineEqualityAnalysis.apron.ml +++ b/src/analyses/apron/affineEqualityAnalysis.apron.ml @@ -11,7 +11,6 @@ let spec_module: (module MCPSpec) Lazy.t = let module AD = AffineEqualityDomain.D2 (VectorMatrix.ArrayVector) (VectorMatrix.ArrayMatrix) in let module RD: RelationDomain.RD = struct - module Var = AffineEqualityDomain.Var module V = AffineEqualityDomain.V include AD end diff --git a/src/analyses/apron/apronAnalysis.apron.ml b/src/analyses/apron/apronAnalysis.apron.ml index 29e295a662..0ba17cdb35 100644 --- a/src/analyses/apron/apronAnalysis.apron.ml +++ b/src/analyses/apron/apronAnalysis.apron.ml @@ -12,10 +12,9 @@ let spec_module: (module MCPSpec) Lazy.t = let module AD = (val if diff_box then (module ApronDomain.BoxProd (AD): ApronDomain.S3) else (module AD)) in let module RD: RelationDomain.RD = struct - module Var = ApronDomain.Var module V = ApronDomain.V include AD - type var = ApronDomain.Var.t + type var = Apron.Var.t end in let module Priv = (val RelationPriv.get_priv ()) in diff --git a/src/analyses/apron/relationAnalysis.apron.ml b/src/analyses/apron/relationAnalysis.apron.ml index d2fe7eab9e..e572755930 100644 --- a/src/analyses/apron/relationAnalysis.apron.ml +++ b/src/analyses/apron/relationAnalysis.apron.ml @@ -283,8 +283,9 @@ struct let pass_to_callee fundec any_local_reachable var = (* TODO: currently, we pass all locals of the caller to the callee, provided one of them is reachbale to preserve relationality *) (* there should be smarter ways to do this, e.g. by keeping track of which values are written etc. ... *) + (* See, e.g, Beckschulze E, Kowalewski S, Brauer J (2012) Access-based localization for octagons. Electron Notes Theor Comput Sci 287:29–40 *) (* Also, a local *) - let vname = RD.Var.to_string var in + let vname = Apron.Var.to_string var in let locals = fundec.sformals @ fundec.slocals in match List.find_opt (fun v -> VM.var_name (Local v) = vname) locals with (* TODO: optimize *) | None -> true @@ -295,8 +296,7 @@ struct let st = ctx.local in let arg_assigns = GobList.combine_short f.sformals args (* TODO: is it right to ignore missing formals/args? *) - |> List.filter (fun (x, _) -> RD.Tracked.varinfo_tracked x) - |> List.map (Tuple2.map1 RV.arg) + |> List.filter_map (fun (x, e) -> if RD.Tracked.varinfo_tracked x then Some (RV.arg x, e) else None) in let arg_vars = List.map fst arg_assigns in let new_rel = RD.add_vars st.rel arg_vars in @@ -318,7 +318,7 @@ struct RD.remove_filter_with new_rel (fun var -> match RV.find_metadata var with | Some (Local _) when not (pass_to_callee fundec any_local_reachable var) -> true (* remove caller locals provided they are unreachable *) - | Some (Arg _) when not (List.mem_cmp RD.Var.compare var arg_vars) -> true (* remove caller args, but keep just added args *) + | Some (Arg _) when not (List.mem_cmp Apron.Var.compare var arg_vars) -> true (* remove caller args, but keep just added args *) | _ -> false (* keep everything else (just added args, globals, global privs) *) ); if M.tracing then M.tracel "combine" "relation enter newd: %a\n" RD.pretty new_rel; @@ -404,7 +404,7 @@ struct in let any_local_reachable = any_local_reachable fundec reachable_from_args in let arg_vars = f.sformals |> List.filter (RD.Tracked.varinfo_tracked) |> List.map RV.arg in - if M.tracing then M.tracel "combine" "relation remove vars: %a\n" (docList (fun v -> Pretty.text (RD.Var.to_string v))) arg_vars; + if M.tracing then M.tracel "combine" "relation remove vars: %a\n" (docList (fun v -> Pretty.text (Apron.Var.to_string v))) arg_vars; RD.remove_vars_with new_fun_rel arg_vars; (* fine to remove arg vars that also exist in caller because unify from new_rel adds them back with proper constraints *) let tainted = f_ask.f Queries.MayBeTainted in let tainted_vars = TaintPartialContexts.conv_varset tainted in @@ -609,7 +609,7 @@ struct |> 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 || Apron.Linexpr0.get_size lincons1.lincons0.linexpr0 >= 2) && (exact || Apron.Lincons1.get_typ lincons1 <> EQ) then + if (one_var || GobApron.Lincons1.num_vars lincons1 >= 2) && (exact || Apron.Lincons1.get_typ lincons1 <> EQ) then RD.cil_exp_of_lincons1 lincons1 |> Option.map e_inv |> Option.filter (fun exp -> not (InvariantCil.exp_contains_tmp exp) && InvariantCil.exp_is_in_scope scope exp) diff --git a/src/analyses/apron/relationPriv.apron.ml b/src/analyses/apron/relationPriv.apron.ml index b386af162b..f073ae274b 100644 --- a/src/analyses/apron/relationPriv.apron.ml +++ b/src/analyses/apron/relationPriv.apron.ml @@ -195,8 +195,7 @@ struct end module AV = struct - include RelationDomain.VarMetadataTbl (VM) (RD.Var) - + include RelationDomain.VarMetadataTbl (VM) let local g = make_var (Local g) let unprot g = make_var (Unprot g) @@ -1011,17 +1010,17 @@ struct ) ) else ( - match ConcDomain.ThreadSet.elements tids with - | [tid] -> - let lmust',l' = G.thread (getg (V.thread tid)) in - {st with priv = (w, LMust.union lmust' lmust, L.join l l')} - | _ -> - (* To match the paper more closely, one would have to join in the non-definite case too *) - (* Given how we handle lmust (for initialization), doing this might actually be beneficial given that it grows lmust *) - st - | exception SetDomain.Unsupported _ -> - (* elements throws if the thread set is top *) + if ConcDomain.ThreadSet.is_top tids then st + else + match ConcDomain.ThreadSet.elements tids with + | [tid] -> + let lmust',l' = G.thread (getg (V.thread tid)) in + {st with priv = (w, LMust.union lmust' lmust, L.join l l')} + | _ -> + (* To match the paper more closely, one would have to join in the non-definite case too *) + (* Given how we handle lmust (for initialization), doing this might actually be beneficial given that it grows lmust *) + st ) let thread_return ask getg sideg tid (st: relation_components_t) = diff --git a/src/analyses/base.ml b/src/analyses/base.ml index 3630395282..c470bca026 100644 --- a/src/analyses/base.ml +++ b/src/analyses/base.ml @@ -54,7 +54,7 @@ struct module G = struct - include Lattice.Lift2 (Priv.G) (VD) (Printable.DefaultNames) + include Lattice.Lift2Conf (struct include Printable.DefaultConf let expand1 = false let expand2 = false end) (Priv.G) (VD) let priv = function | `Bot -> Priv.G.bot () @@ -1417,7 +1417,7 @@ struct (** [set st addr val] returns a state where [addr] is set to [val] * it is always ok to put None for lval_raw and rval_raw, this amounts to not using/maintaining * precise information about arrays. *) - let set (a: Q.ask) ~(ctx: _ ctx) ?(invariant=false) ?lval_raw ?rval_raw ?t_override (gs:glob_fun) (st: store) (lval: AD.t) (lval_type: Cil.typ) (value: value) : store = + let set (a: Q.ask) ~(ctx: _ ctx) ?(invariant=false) ?(blob_destructive=false) ?lval_raw ?rval_raw ?t_override (gs:glob_fun) (st: store) (lval: AD.t) (lval_type: Cil.typ) (value: value) : store = let update_variable x t y z = if M.tracing then M.tracel "set" ~var:x.vname "update_variable: start '%s' '%a'\nto\n%a\n\n" x.vname VD.pretty y CPA.pretty z; let r = update_variable x t y z in (* refers to defintion that is outside of set *) @@ -1450,7 +1450,7 @@ struct let update_offset old_value = (* Projection globals to highest Precision *) let projected_value = project_val (Queries.to_value_domain_ask a) None None value (is_global a x) in - let new_value = VD.update_offset (Queries.to_value_domain_ask a) old_value offs projected_value lval_raw ((Var x), cil_offset) t in + let new_value = VD.update_offset ~blob_destructive (Queries.to_value_domain_ask a) old_value offs projected_value lval_raw ((Var x), cil_offset) t in if WeakUpdates.mem x st.weak then VD.join old_value new_value else if invariant then ( @@ -1486,7 +1486,7 @@ struct Priv.read_global a priv_getg st x in let new_value = update_offset old_value in - M.tracel "hgh" "update_offset %a -> %a\n" VD.pretty old_value VD.pretty new_value; + if M.tracing then M.tracel "set" "update_offset %a -> %a\n" VD.pretty old_value VD.pretty new_value; let r = Priv.write_global ~invariant a priv_getg (priv_sideg ctx.sideg) st x new_value in if M.tracing then M.tracel "set" ~var:x.vname "update_one_addr: updated a global var '%s' \nstate:%a\n\n" x.vname D.pretty r; r @@ -1878,7 +1878,7 @@ struct let invalidate ?(deep=true) ~ctx ask (gs:glob_fun) (st:store) (exps: exp list): store = if M.tracing && exps <> [] then M.tracel "invalidate" "Will invalidate expressions [%a]\n" (d_list ", " d_plainexp) exps; - if exps <> [] then M.info ~category:Imprecise "Invalidating expressions: %a" (d_list ", " d_plainexp) exps; + if exps <> [] then M.info ~category:Imprecise "Invalidating expressions: %a" (d_list ", " d_exp) exps; (* To invalidate a single address, we create a pair with its corresponding * top value. *) let invalidate_address st a = @@ -2189,24 +2189,90 @@ struct (* do nothing if all characters are needed *) | _ -> None in - let string_manipulation s1 s2 lv all op = - let s1_a, s1_typ = addr_type_of_exp s1 in - let s2_a, s2_typ = addr_type_of_exp s2 in - match lv, op with - | Some lv_val, Some f -> - (* when whished types coincide, compute result of operation op, otherwise use top *) - let lv_a = eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val in - let lv_typ = Cilfacade.typeOfLval lv_val in - if all && typeSig s1_typ = typeSig s2_typ && typeSig s2_typ = typeSig lv_typ then (* all types need to coincide *) - lv_a, lv_typ, (f s1_a s2_a) - else if not all && typeSig s1_typ = typeSig s2_typ then (* only the types of s1 and s2 need to coincide *) - lv_a, lv_typ, (f s1_a s2_a) - else - lv_a, lv_typ, (VD.top_value (unrollType lv_typ)) - | _ -> - (* check if s1 is potentially a string literal as writing to it would be undefined behavior; then return top *) - let _ = AD.string_writing_defined s1_a in - s1_a, s1_typ, VD.top_value (unrollType s1_typ) + let address_from_value (v:value) = match v with + | Address a -> + (* TODO: is it fine to just drop the last index unconditionally? https://github.com/goblint/analyzer/pull/1076#discussion_r1408975611 *) + let rec lo = function + | `Index (i, `NoOffset) -> `NoOffset + | `NoOffset -> `NoOffset + | `Field (f, o) -> `Field (f, lo o) + | `Index (i, o) -> `Index (i, lo o) in + let rmLastOffset = function + | Addr.Addr (v, o) -> Addr.Addr (v, lo o) + | other -> other in + AD.map rmLastOffset a + | _ -> raise (Failure "String function: not an address") + in + let string_manipulation s1 s2 lv all op_addr op_array = + let s1_v = eval_rv (Analyses.ask_of_ctx ctx) gs st s1 in + let s1_a = address_from_value s1_v in + let s1_typ = AD.type_of s1_a in + let s2_v = eval_rv (Analyses.ask_of_ctx ctx) gs st s2 in + let s2_a = address_from_value s2_v in + let s2_typ = AD.type_of s2_a in + (* compute value in string literals domain if s1 and s2 are both string literals *) + (* TODO: is this reliable? there could be a char* which isn't StrPtr *) + if CilType.Typ.equal s1_typ charPtrType && CilType.Typ.equal s2_typ charPtrType then + begin match lv, op_addr with + | Some lv_val, Some f -> + (* when whished types coincide, compute result of operation op_addr, otherwise use top *) + let lv_a = eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val in + let lv_typ = Cilfacade.typeOfLval lv_val in + if all && typeSig s1_typ = typeSig s2_typ && typeSig s2_typ = typeSig lv_typ then (* all types need to coincide *) + set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (f s1_a s2_a) + else if not all && typeSig s1_typ = typeSig s2_typ then (* only the types of s1 and s2 need to coincide *) + set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (f s1_a s2_a) + else + set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (VD.top_value (unrollType lv_typ)) + | _ -> + (* check if s1 is potentially a string literal as writing to it would be undefined behavior; then return top *) + let _ = AD.string_writing_defined s1_a in + set ~ctx (Analyses.ask_of_ctx ctx) gs st s1_a s1_typ (VD.top_value (unrollType s1_typ)) + end + (* else compute value in array domain *) + else + let lv_a, lv_typ = match lv with + | Some lv_val -> eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val, Cilfacade.typeOfLval lv_val + | None -> s1_a, s1_typ in + begin match (get (Analyses.ask_of_ctx ctx) gs st s1_a None), get (Analyses.ask_of_ctx ctx) gs st s2_a None with + | Array array_s1, Array array_s2 -> set ~ctx ~blob_destructive:true (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) + | Array array_s1, _ when CilType.Typ.equal s2_typ charPtrType -> + let s2_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s2_a) in + let array_s2 = List.fold_left CArrays.join (CArrays.bot ()) s2_null_bytes in + set ~ctx ~blob_destructive:true (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) + | Bot, Array array_s2 -> + (* If we have bot inside here, we assume the blob is used as a char array and create one inside *) + let ptrdiff_ik = Cilfacade.ptrdiff_ikind () in + let size = ctx.ask (Q.BlobSize {exp = s1; base_address = false}) in + let s_id = + try ValueDomainQueries.ID.unlift (ID.cast_to ptrdiff_ik) size + with Failure _ -> ID.top_of ptrdiff_ik in + let empty_array = CArrays.make s_id (Int (ID.top_of IChar)) in + set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array empty_array array_s2) + | Bot , _ when CilType.Typ.equal s2_typ charPtrType -> + (* If we have bot inside here, we assume the blob is used as a char array and create one inside *) + let ptrdiff_ik = Cilfacade.ptrdiff_ikind () in + let size = ctx.ask (Q.BlobSize {exp = s1; base_address = false}) in + let s_id = + try ValueDomainQueries.ID.unlift (ID.cast_to ptrdiff_ik) size + with Failure _ -> ID.top_of ptrdiff_ik in + let empty_array = CArrays.make s_id (Int (ID.top_of IChar)) in + let s2_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s2_a) in + let array_s2 = List.fold_left CArrays.join (CArrays.bot ()) s2_null_bytes in + set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array empty_array array_s2) + | _, Array array_s2 when CilType.Typ.equal s1_typ charPtrType -> + (* if s1 is string literal, str(n)cpy and str(n)cat are undefined *) + if op_addr = None then + (* triggers warning, function only evaluated for side-effects *) + let _ = AD.string_writing_defined s1_a in + set ~ctx (Analyses.ask_of_ctx ctx) gs st s1_a s1_typ (VD.top_value (unrollType s1_typ)) + else + let s1_null_bytes = List.map CArrays.to_null_byte_domain (AD.to_string s1_a) in + let array_s1 = List.fold_left CArrays.join (CArrays.bot ()) s1_null_bytes in + set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (op_array array_s1 array_s2) + | _ -> + set ~ctx (Analyses.ask_of_ctx ctx) gs st lv_a lv_typ (VD.top_value (unrollType lv_typ)) + end in let st = match desc.special args, f.vname with | Memset { dest; ch; count; }, _ -> @@ -2229,53 +2295,51 @@ struct set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value | Memcpy { dest = dst; src; n; }, _ -> (* TODO: use n *) memory_copying dst src (Some n) - (* strcpy(dest, src); *) - | Strcpy { dest = dst; src; n = None }, _ -> - let dest_a, dest_typ = addr_type_of_exp dst in - (* when dest surely isn't a string literal, try copying src to dest *) - if AD.string_writing_defined dest_a then - memory_copying dst src None - else - (* else return top (after a warning was issued) *) - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ (VD.top_value (unrollType dest_typ)) - (* strncpy(dest, src, n); *) - | Strcpy { dest = dst; src; n }, _ -> - begin match eval_n n with - | Some num -> - let dest_a, dest_typ, value = string_manipulation dst src None false None in - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value - | None -> failwith "already handled in case above" - end - | Strcat { dest = dst; src; n }, _ -> - let dest_a, dest_typ, value = string_manipulation dst src None false None in - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value + | Strcpy { dest = dst; src; n }, _ -> string_manipulation dst src None false None (fun ar1 ar2 -> Array (CArrays.string_copy ar1 ar2 (eval_n n))) + | Strcat { dest = dst; src; n }, _ -> string_manipulation dst src None false None (fun ar1 ar2 -> Array (CArrays.string_concat ar1 ar2 (eval_n n))) | Strlen s, _ -> begin match lv with | Some lv_val -> let dest_a = eval_lv (Analyses.ask_of_ctx ctx) gs st lv_val in let dest_typ = Cilfacade.typeOfLval lv_val in - let lval = mkMem ~addr:(Cil.stripCasts s) ~off:NoOffset in - let address = eval_lv (Analyses.ask_of_ctx ctx) gs st lval in - let (value:value) = Int(AD.to_string_length address) in + let v = eval_rv (Analyses.ask_of_ctx ctx) gs st s in + let a = address_from_value v in + let value:value = + (* if s string literal, compute strlen in string literals domain *) + (* TODO: is this reliable? there could be a char* which isn't StrPtr *) + if CilType.Typ.equal (AD.type_of a) charPtrType then + Int (AD.to_string_length a) + (* else compute strlen in array domain *) + else + begin match get (Analyses.ask_of_ctx ctx) gs st a None with + | Array array_s -> Int (CArrays.to_string_length array_s) + | _ -> VD.top_value (unrollType dest_typ) + end in set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value | None -> st end | Strstr { haystack; needle }, _ -> begin match lv with - | Some _ -> - (* when haystack, needle and dest type coincide, check if needle is a substring of haystack: - if that is the case, assign the substring of haystack starting at the first occurrence of needle to dest, - else use top *) - let dest_a, dest_typ, value = string_manipulation haystack needle lv true (Some (fun h_a n_a -> Address(AD.substring_extraction h_a n_a))) in - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value + | Some lv_val -> + (* check if needle is a substring of haystack in string literals domain if haystack and needle are string literals, + else check in null bytes domain if both haystack and needle are / can be transformed to an array domain representation; + if needle is substring, assign the substring of haystack starting at the first occurrence of needle to dest, + if it surely isn't, assign a null_ptr *) + string_manipulation haystack needle lv true (Some (fun h_a n_a -> Address (AD.substring_extraction h_a n_a))) + (fun h_ar n_ar -> match CArrays.substring_extraction h_ar n_ar with + | CArrays.IsNotSubstr -> Address (AD.null_ptr) + | CArrays.IsSubstrAtIndex0 -> Address (eval_lv (Analyses.ask_of_ctx ctx) gs st (mkMem ~addr:(Cil.stripCasts haystack) ~off:NoOffset)) + | CArrays.IsMaybeSubstr -> Address (AD.join (eval_lv (Analyses.ask_of_ctx ctx) gs st + (mkMem ~addr:(Cil.stripCasts haystack) ~off:(Index (Offset.Index.Exp.any, NoOffset)))) (AD.null_ptr))) | None -> st end | Strcmp { s1; s2; n }, _ -> begin match lv with | Some _ -> - (* when s1 and s2 type coincide, compare both both strings completely or their first n characters, otherwise use top *) - let dest_a, dest_typ, value = string_manipulation s1 s2 lv false (Some (fun s1_a s2_a -> Int(AD.string_comparison s1_a s2_a (eval_n n)))) in - set ~ctx (Analyses.ask_of_ctx ctx) gs st dest_a dest_typ value + (* when s1 and s2 are string literals, compare both completely or their first n characters in the string literals domain; + else compare them in the null bytes array domain if they are / can be transformed to an array domain representation *) + string_manipulation s1 s2 lv false (Some (fun s1_a s2_a -> Int (AD.string_comparison s1_a s2_a (eval_n n)))) + (fun s1_ar s2_ar -> Int (CArrays.string_comparison s1_ar s2_ar (eval_n n))) | None -> st end | Abort, _ -> raise Deadcode @@ -2397,10 +2461,12 @@ struct (* handling thread joins... sort of *) | ThreadJoin { thread = id; ret_var }, _ -> let st' = + (* TODO: should invalidate shallowly? https://github.com/goblint/analyzer/pull/1224#discussion_r1405826773 *) match (eval_rv (Analyses.ask_of_ctx ctx) gs st ret_var) with | Int n when GobOption.exists (BI.equal BI.zero) (ID.to_int n) -> st | Address ret_a -> begin match eval_rv (Analyses.ask_of_ctx ctx) gs st id with + | Thread a when ValueDomain.Threads.is_top a -> invalidate ~ctx (Analyses.ask_of_ctx ctx) gs st [ret_var] | Thread a -> let v = List.fold VD.join (VD.bot ()) (List.map (fun x -> G.thread (ctx.global (V.thread x))) (ValueDomain.Threads.elements a)) in (* TODO: is this type right? *) @@ -2805,7 +2871,7 @@ struct | "once" -> f (D.bot ()) | "fixpoint" -> - let module DFP = LocalFixpoint.Make (D) in + let module DFP = Goblint_solver.LocalFixpoint.Make (D) in DFP.lfp f | _ -> assert false diff --git a/src/analyses/baseInvariant.ml b/src/analyses/baseInvariant.ml index f391231628..f18eeed24f 100644 --- a/src/analyses/baseInvariant.ml +++ b/src/analyses/baseInvariant.ml @@ -243,12 +243,12 @@ struct refine_lv_fallback ctx a gs st lval value tv | None -> if M.tracing then M.traceu "invariant" "Doing nothing.\n"; - M.debug ~category:Analyzer "Invariant failed: expression \"%a\" not understood." d_plainexp exp; + M.debug ~category:Analyzer "Invariant failed: expression \"%a\" not understood." d_exp exp; st let invariant ctx a gs st exp tv: D.t = let fallback reason st = - if M.tracing then M.tracel "inv" "Can't handle %a.\n%s\n" d_plainexp exp reason; + if M.tracing then M.tracel "inv" "Can't handle %a.\n%t\n" d_plainexp exp reason; invariant_fallback ctx a gs st exp tv in (* inverse values for binary operation a `op` b == c *) @@ -689,7 +689,7 @@ struct (* Mixed Float and Int cases should never happen, as there are no binary operators with one float and one int parameter ?!*) | Int _, Float _ | Float _, Int _ -> failwith "ill-typed program"; (* | Address a, Address b -> ... *) - | a1, a2 -> fallback (GobPretty.sprintf "binop: got abstract values that are not Int: %a and %a" VD.pretty a1 VD.pretty a2) st) + | a1, a2 -> fallback (fun () -> Pretty.dprintf "binop: got abstract values that are not Int: %a and %a" VD.pretty a1 VD.pretty a2) st) (* use closures to avoid unused casts *) in (match c_typed with | Int c -> invert_binary_op c ID.pretty (fun ik -> ID.cast_to ik c) (fun fk -> FD.of_int fk c) @@ -709,18 +709,22 @@ struct | _ -> Int c in (* handle special calls *) - begin match t with - | TInt (ik, _) -> - begin match x with - | ((Var v), offs) -> - if M.tracing then M.trace "invSpecial" "qry Result: %a\n" Queries.ML.pretty (ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs))); - let tv_opt = ID.to_bool c in - begin match tv_opt with + begin match x, t with + | (Var v, offs), TInt (ik, _) -> + let tmpSpecial = ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) in + if M.tracing then M.trace "invSpecial" "qry Result: %a\n" Queries.ML.pretty tmpSpecial; + begin match tmpSpecial with + | `Lifted (Abs (ik, xInt)) -> + let c' = ID.cast_to ik c in (* different ik! *) + inv_exp (Int (ID.join c' (ID.neg c'))) xInt st + | tmpSpecial -> + begin match ID.to_bool c with | Some tv -> - begin match ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) with + begin match tmpSpecial with | `Lifted (Isfinite xFloat) when tv -> inv_exp (Float (FD.finite (unroll_fk_of_exp xFloat))) xFloat st | `Lifted (Isnan xFloat) when tv -> inv_exp (Float (FD.nan_of (unroll_fk_of_exp xFloat))) xFloat st (* should be correct according to C99 standard*) + (* The following do to_bool and of_bool to convert Not{0} into 1 for downstream float inversions *) | `Lifted (Isgreater (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Gt, xFloat, yFloat, (typeOf xFloat))) st | `Lifted (Isgreaterequal (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Ge, xFloat, yFloat, (typeOf xFloat))) st | `Lifted (Isless (xFloat, yFloat)) -> inv_exp (Int (ID.of_bool ik tv)) (BinOp (Lt, xFloat, yFloat, (typeOf xFloat))) st @@ -730,9 +734,8 @@ struct end | None -> update_lval c x c' ID.pretty end - | _ -> update_lval c x c' ID.pretty end - | _ -> update_lval c x c' ID.pretty + | _, _ -> update_lval c x c' ID.pretty end | Float c -> let c' = match t with @@ -744,22 +747,19 @@ struct | _ -> Float c in (* handle special calls *) - begin match t with - | TFloat (fk, _) -> - begin match x with - | ((Var v), offs) -> - if M.tracing then M.trace "invSpecial" "qry Result: %a\n" Queries.ML.pretty (ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs))); - begin match ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) with - | `Lifted (Ceil (ret_fk, xFloat)) -> inv_exp (Float (FD.inv_ceil (FD.cast_to ret_fk c))) xFloat st - | `Lifted (Floor (ret_fk, xFloat)) -> inv_exp (Float (FD.inv_floor (FD.cast_to ret_fk c))) xFloat st - | `Lifted (Fabs (ret_fk, xFloat)) -> - let inv = FD.inv_fabs (FD.cast_to ret_fk c) in - if FD.is_bot inv then - raise Analyses.Deadcode - else - inv_exp (Float inv) xFloat st - | _ -> update_lval c x c' FD.pretty - end + begin match x, t with + | (Var v, offs), TFloat (fk, _) -> + let tmpSpecial = ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil offs)) in + if M.tracing then M.trace "invSpecial" "qry Result: %a\n" Queries.ML.pretty tmpSpecial; + begin match tmpSpecial with + | `Lifted (Ceil (ret_fk, xFloat)) -> inv_exp (Float (FD.inv_ceil (FD.cast_to ret_fk c))) xFloat st + | `Lifted (Floor (ret_fk, xFloat)) -> inv_exp (Float (FD.inv_floor (FD.cast_to ret_fk c))) xFloat st + | `Lifted (Fabs (ret_fk, xFloat)) -> + let inv = FD.inv_fabs (FD.cast_to ret_fk c) in + if FD.is_bot inv then + raise Analyses.Deadcode + else + inv_exp (Float inv) xFloat st | _ -> update_lval c x c' FD.pretty end | _ -> update_lval c x c' FD.pretty @@ -778,7 +778,7 @@ struct | TFloat (fk, _), FLongDouble | TFloat (FDouble as fk, _), FDouble | TFloat (FFloat as fk, _), FFloat -> inv_exp (Float (FD.cast_to fk c)) e st - | _ -> fallback ("CastE: incompatible types") st) + | _ -> fallback (fun () -> Pretty.text "CastE: incompatible types") st) | CastE ((TInt (ik, _)) as t, e), Int c | CastE ((TEnum ({ekind = ik; _ }, _)) as t, e), Int c -> (* Can only meet the t part of an Lval in e with c (unless we meet with all overflow possibilities)! Since there is no good way to do this, we only continue if e has no values outside of t. *) (match eval e st with @@ -791,11 +791,11 @@ struct let c' = ID.cast_to ik_e (ID.meet c (ID.cast_to ik (ID.top_of ik_e))) in (* TODO: cast without overflow, is this right for normal invariant? *) if M.tracing then M.tracel "inv" "cast: %a from %a to %a: i = %a; cast c = %a to %a = %a\n" d_exp e d_ikind ik_e d_ikind ik ID.pretty i ID.pretty c d_ikind ik_e ID.pretty c'; inv_exp (Int c') e st - | x -> fallback (GobPretty.sprintf "CastE: e did evaluate to Int, but the type did not match %a" CilType.Typ.pretty t) st + | x -> fallback (fun () -> Pretty.dprintf "CastE: e did evaluate to Int, but the type did not match %a" CilType.Typ.pretty t) st else - fallback (GobPretty.sprintf "CastE: %a evaluates to %a which is bigger than the type it is cast to which is %a" d_plainexp e ID.pretty i CilType.Typ.pretty t) st - | v -> fallback (GobPretty.sprintf "CastE: e did not evaluate to Int, but %a" VD.pretty v) st) - | e, _ -> fallback (GobPretty.sprintf "%a not implemented" d_plainexp e) st + fallback (fun () -> Pretty.dprintf "CastE: %a evaluates to %a which is bigger than the type it is cast to which is %a" d_plainexp e ID.pretty i CilType.Typ.pretty t) st + | v -> fallback (fun () -> Pretty.dprintf "CastE: e did not evaluate to Int, but %a" VD.pretty v) st) + | e, _ -> fallback (fun () -> Pretty.dprintf "%a not implemented" d_plainexp e) st in if eval_bool exp st = Some (not tv) then contra st (* we already know that the branch is dead *) else @@ -821,31 +821,4 @@ struct FD.top_of fk in inv_exp (Float ftv) exp st - - let invariant ctx a gs st exp tv: D.t = - let refine0 = invariant ctx a gs st exp tv in - (* bodge for abs(...); To be removed once we have a clean solution *) - let refineAbs op absargexp valexp = - let flip op = match op with | Le -> Ge | Lt -> Gt | _ -> failwith "impossible" in - (* e.g. |arg| <= 40 *) - (* arg <= e (arg <= 40) *) - let le = BinOp (op, absargexp, valexp, intType) in - (* arg >= -e (arg >= -40) *) - let gt = BinOp(flip op, absargexp, UnOp (Neg, valexp, Cilfacade.typeOf valexp), intType) in - let one = invariant ctx (Analyses.ask_of_ctx ctx) ctx.global refine0 le tv in - invariant ctx (Analyses.ask_of_ctx ctx) ctx.global one gt tv - in - match exp with - | BinOp ((Lt|Le) as op, CastE(t, Lval (Var v, NoOffset)), e,_) when tv -> - begin match ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil NoOffset)) with - | `Lifted (Abs (ik, arg)) -> refineAbs op (CastE (t, arg)) e - | _ -> refine0 - end - | BinOp ((Lt|Le) as op, Lval (Var v, NoOffset), e, _) when tv -> - begin match ctx.ask (Queries.TmpSpecial (v, Offset.Exp.of_cil NoOffset)) with - | `Lifted (Abs (ik, arg)) -> refineAbs op arg e - | _ -> refine0 - end - | _ -> refine0 - end diff --git a/src/analyses/basePriv.ml b/src/analyses/basePriv.ml index 3843dda300..10deaa4d16 100644 --- a/src/analyses/basePriv.ml +++ b/src/analyses/basePriv.ml @@ -211,12 +211,12 @@ struct let thread_join ?(force=false) ask get e st = st let thread_return ask get set tid st = st - let invariant_global getg g = - match g with - | `Left _ -> (* mutex *) - Invariant.none + let invariant_global getg = function | `Right g' -> (* global *) ValueDomain.invariant_global (read_unprotected_global getg) g' + | _ -> (* mutex *) + Invariant.none + end module PerMutexOplusPriv: S = @@ -230,7 +230,7 @@ struct CPA.find x st.cpa (* let read_global ask getg cpa x = let (cpa', v) as r = read_global ask getg cpa x in - ignore (Pretty.printf "READ GLOBAL %a (%a, %B) = %a\n" CilType.Varinfo.pretty x CilType.Location.pretty !Tracing.current_loc (is_unprotected ask x) VD.pretty v); + ignore (Pretty.printf "READ GLOBAL %a (%a, %B) = %a\n" CilType.Varinfo.pretty x CilType.Location.pretty !Goblint_tracing.current_loc (is_unprotected ask x) VD.pretty v); r *) let write_global ?(invariant=false) ask getg sideg (st: BaseComponents (D).t) x v = let cpa' = CPA.add x v st.cpa in @@ -544,17 +544,17 @@ struct ) ) else ( - match ConcDomain.ThreadSet.elements tids with - | [tid] -> - let lmust',l' = G.thread (getg (V.thread tid)) in - {st with priv = (w, LMust.union lmust' lmust, L.join l l')} - | _ -> - (* To match the paper more closely, one would have to join in the non-definite case too *) - (* Given how we handle lmust (for initialization), doing this might actually be beneficial given that it grows lmust *) - st - | exception SetDomain.Unsupported _ -> - (* elements throws if the thread set is top *) + if ConcDomain.ThreadSet.is_top tids then st + else + match ConcDomain.ThreadSet.elements tids with + | [tid] -> + let lmust',l' = G.thread (getg (V.thread tid)) in + {st with priv = (w, LMust.union lmust' lmust, L.join l l')} + | _ -> + (* To match the paper more closely, one would have to join in the non-definite case too *) + (* Given how we handle lmust (for initialization), doing this might actually be beneficial given that it grows lmust *) + st ) let thread_return ask getg sideg tid (st: BaseComponents (D).t) = @@ -625,13 +625,11 @@ struct let get_mutex_inits' = CPA.find x get_mutex_inits in VD.join get_mutex_global_x' get_mutex_inits' - let invariant_global getg g = - match g with - | `Left (`Left _) -> (* mutex *) - Invariant.none - | `Left (`Right g') -> (* global *) - ValueDomain.invariant_global (read_unprotected_global getg) g' - | `Right _ -> (* thread *) + let invariant_global getg = function + | `Middle g -> (* global *) + ValueDomain.invariant_global (read_unprotected_global getg) g + | `Left _ + | `Right _ -> (* mutex or thread *) Invariant.none end @@ -662,21 +660,11 @@ struct struct include VarinfoV (* [g]' *) let name () = "unprotected" - let show x = show x ^ ":unprotected" (* distinguishable variant names for html *) - include Printable.SimpleShow (struct - type nonrec t = t - let show = show - end) end module VProt = struct include VarinfoV (* [g] *) let name () = "protected" - let show x = show x ^ ":protected" (* distinguishable variant names for html *) - include Printable.SimpleShow (struct - type nonrec t = t - let show = show - end) end module V = struct @@ -811,7 +799,7 @@ struct struct (* weak: G -> (2^M -> WeakRange) *) (* sync: M -> (2^M -> SyncRange) *) - include Lattice.Lift2 (GWeak) (GSync) (Printable.DefaultNames) + include Lattice.Lift2Conf (struct include Printable.DefaultConf let expand1 = false let expand2 = false end) (GWeak) (GSync) let weak = function | `Bot -> GWeak.bot () @@ -847,16 +835,15 @@ struct open Locksets - let invariant_global getg g = - match g with - | `Left _ -> (* mutex *) - Invariant.none + let invariant_global getg = function | `Right g' -> (* global *) ValueDomain.invariant_global (fun x -> GWeak.fold (fun s' tm acc -> WeakRange.fold_weak VD.join tm acc ) (G.weak (getg (V.global x))) (VD.bot ()) ) g' + | _ -> (* mutex *) + Invariant.none let invariant_vars ask getg st = let module VS = Set.Make (CilType.Varinfo) in @@ -1668,7 +1655,7 @@ struct let read_global ask getg st x = let v = Priv.read_global ask getg st x in if !AnalysisState.postsolving && !is_dumping then - LVH.modify_def (VD.bot ()) (!Tracing.current_loc, x) (VD.join v) lvh; + LVH.modify_def (VD.bot ()) (!Goblint_tracing.current_loc, x) (VD.join v) lvh; v let dump () = diff --git a/src/analyses/commonPriv.ml b/src/analyses/commonPriv.ml index 88181000b9..90e5b28f82 100644 --- a/src/analyses/commonPriv.ml +++ b/src/analyses/commonPriv.ml @@ -74,22 +74,19 @@ struct struct include LockDomain.Addr let name () = "mutex" - let show x = show x ^ ":mutex" (* distinguishable variant names for html *) end module VMutexInits = Printable.UnitConf (struct let name = "MUTEX_INITS" end) module VGlobal = struct include VarinfoV let name () = "global" - let show x = show x ^ ":global" (* distinguishable variant names for html *) end module V = struct - (* TODO: Either3? *) - include Printable.Either (struct include Printable.Either (VMutex) (VMutexInits) let name () = "mutex" end) (VGlobal) + include Printable.Either3Conf (struct include Printable.DefaultConf let expand2 = false end) (VMutex) (VMutexInits) (VGlobal) let name () = "MutexGlobals" - let mutex x: t = `Left (`Left x) - let mutex_inits: t = `Left (`Right ()) + let mutex x: t = `Left x + let mutex_inits: t = `Middle () let global x: t = `Right x end @@ -174,7 +171,7 @@ struct module V = struct - include Printable.Either (MutexGlobals.V) (TID) + include Printable.EitherConf (struct let expand1 = false let expand2 = true end) (MutexGlobals.V) (TID) let mutex x = `Left (MutexGlobals.V.mutex x) let mutex_inits = `Left MutexGlobals.V.mutex_inits let global x = `Left (MutexGlobals.V.global x) @@ -201,7 +198,7 @@ struct module G = struct - include Lattice.Lift2 (GMutex) (GThread) (Printable.DefaultNames) + include Lattice.Lift2Conf (struct include Printable.DefaultConf let expand1 = false let expand2 = false end) (GMutex) (GThread) let mutex = function | `Bot -> GMutex.bot () diff --git a/src/analyses/extractPthread.ml b/src/analyses/extractPthread.ml index f084a21edb..8412a65683 100644 --- a/src/analyses/extractPthread.ml +++ b/src/analyses/extractPthread.ml @@ -220,7 +220,7 @@ module Tbls = struct let make_new_val table k = (* TODO: all same key occurrences instead *) let line = -5 - all_keys_count table in - let loc = { !Tracing.current_loc with line } in + let loc = { !Goblint_tracing.current_loc with line } in MyCFG.Statement { (mkStmtOneInstr @@ Set (var dummyFunDec.svar, zero, loc, loc)) with sid = new_sid () diff --git a/src/analyses/fileUse.ml b/src/analyses/fileUse.ml deleted file mode 100644 index 58257b7843..0000000000 --- a/src/analyses/fileUse.ml +++ /dev/null @@ -1,296 +0,0 @@ -(** Analysis of correct file handle usage ([file]). - - @see Vogler, R. Verifying Regular Safety Properties of C Programs Using the Static Analyzer Goblint. Section 3.*) - -open Batteries -open GoblintCil -open Analyses - -module Spec = -struct - include Analyses.DefaultSpec - - let name () = "file" - module D = FileDomain.Dom - module C = FileDomain.Dom - - (* special variables *) - let return_var = Cilfacade.create_var @@ Cil.makeVarinfo false "@return" Cil.voidType, `NoOffset - let unclosed_var = Cilfacade.create_var @@ Cil.makeVarinfo false "@unclosed" Cil.voidType, `NoOffset - - (* keys that were already warned about; needed for multiple returns (i.e. can't be kept in D) *) - let warned_unclosed = ref Set.empty - - (* queries *) - let query ctx (type a) (q: a Queries.t) = - match q with - | Queries.MayPointTo exp -> if M.tracing then M.tracel "file" "query MayPointTo: %a" d_plainexp exp; Queries.Result.top q - | _ -> Queries.Result.top q - - let query_ad (ask: Queries.ask) exp = - match ask.f (Queries.MayPointTo exp) with - | ad when not (Queries.AD.is_top ad) -> Queries.AD.elements ad - | _ -> [] - let print_query_lv ?msg:(msg="") ask exp = - let addrs = query_ad ask exp in (* MayPointTo -> LValSet *) - let pretty_key = function - | Queries.AD.Addr.Addr (v,o) -> Pretty.text (D.string_of_key (v, ValueDomain.Addr.Offs.to_exp o)) - | _ -> Pretty.text "" in - if M.tracing then M.tracel "file" "%s MayPointTo %a = [%a]" msg d_exp exp (Pretty.docList ~sep:(Pretty.text ", ") pretty_key) addrs - - let eval_fv ask exp: varinfo option = - match query_ad ask exp with - | [addr] -> Queries.AD.Addr.to_var_may addr - | _ -> None - - - (* transfer functions *) - let assign ctx (lval:lval) (rval:exp) : D.t = - let m = ctx.local in - (* ignore(printf "%a = %a\n" d_plainlval lval d_plainexp rval); *) - let saveOpened ?unknown:(unknown=false) k m = (* save maybe opened files in the domain to warn about maybe unclosed files at the end *) - if D.may k D.opened m && not (D.is_unknown k m) then (* if unknown we don't have any location for the warning and have handled it already anyway *) - let mustOpen, mayOpen = D.filter_records k D.opened m in - let mustOpen, mayOpen = if unknown then Set.empty, mayOpen else mustOpen, Set.diff mayOpen mustOpen in - D.extend_value unclosed_var (mustOpen, mayOpen) m - else m - in - let key_from_exp = function - | Lval x -> Some (D.key_from_lval x) - | _ -> None - in - match key_from_exp (Lval lval), key_from_exp (stripCasts rval) with (* we just care about Lval assignments *) - | Some k1, Some k2 when k1=k2 -> m (* do nothing on self-assignment *) - | Some k1, Some k2 when D.mem k1 m && D.mem k2 m -> (* both in D *) - if M.tracing then M.tracel "file" "assign (both in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); - saveOpened k1 m |> D.remove' k1 |> D.alias k1 k2 - | Some k1, Some k2 when D.mem k1 m -> (* only k1 in D *) - if M.tracing then M.tracel "file" "assign (only k1 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); - saveOpened k1 m |> D.remove' k1 - | Some k1, Some k2 when D.mem k2 m -> (* only k2 in D *) - if M.tracing then M.tracel "file" "assign (only k2 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); - D.alias k1 k2 m - | Some k1, _ when D.mem k1 m -> (* k1 in D and assign something unknown *) - if M.tracing then M.tracel "file" "assign (only k1 in D): %s = %a" (D.string_of_key k1) d_exp rval; - D.warn @@ "[Unsound]changed pointer "^D.string_of_key k1^" (no longer safe)"; - saveOpened ~unknown:true k1 m |> D.unknown k1 - | _ -> (* no change in D for other things *) - if M.tracing then M.tracel "file" "assign (none in D): %a = %a [%a]" d_lval lval d_exp rval d_plainexp rval; - m - - let branch ctx (exp:exp) (tv:bool) : D.t = - let m = ctx.local in - (* ignore(printf "if %a = %B (line %i)\n" d_plainexp exp tv (!Tracing.current_loc).line); *) - let check a b tv = - (* ignore(printf "check: %a = %a, %B\n" d_plainexp a d_plainexp b tv); *) - match a, b with - | Const (CInt(i, kind, str)), Lval lval - | Lval lval, Const (CInt(i, kind, str)) -> - (* ignore(printf "branch(%s==%i, %B)\n" v.vname (Int64.to_int i) tv); *) - let k = D.key_from_lval lval in - if Z.compare i Z.zero = 0 && tv then ( - (* ignore(printf "error-branch\n"); *) - D.error k m - )else - D.success k m - | _ -> M.debug ~category:Analyzer "nothing matched the given BinOp: %a = %a" d_plainexp a d_plainexp b; m - in - match stripCasts (constFold true exp) with - (* somehow there are a lot of casts inside the BinOp which stripCasts only removes when called on the subparts - -> matching as in flagMode didn't work *) - (* | BinOp (Eq, Const (CInt64(i, kind, str)), Lval (Var v, NoOffset), _) - | BinOp (Eq, Lval (Var v, NoOffset), Const (CInt64(i, kind, str)), _) -> - ignore(printf "%s %i\n" v.vname (Int64.to_int i)); m *) - | BinOp (Eq, a, b, _) -> check (stripCasts a) (stripCasts b) tv - | BinOp (Ne, a, b, _) -> check (stripCasts a) (stripCasts b) (not tv) - | e -> M.debug ~category:Analyzer "branch: nothing matched the given exp: %a" d_plainexp e; m - - let body ctx (f:fundec) : D.t = - ctx.local - - let return ctx (exp:exp option) (f:fundec) : D.t = - (* TODO check One Return transformation: oneret.ml *) - let m = ctx.local in - (* if f.svar.vname <> "main" && BatList.is_empty (callstack m) then M.write ("\n\t!!! call stack is empty for function "^f.svar.vname^" !!!"); *) - if f.svar.vname = "main" then ( - let mustOpen, mayOpen = D.union (D.filter_values D.opened m) (D.get_value unclosed_var m) in - if Set.cardinal mustOpen > 0 then ( - D.warn @@ "unclosed files: "^D.string_of_keys mustOpen; - Set.iter (fun v -> D.warn ~loc:(D.V.loc v) "file is never closed") mustOpen; - (* add warnings about currently open files (don't include overwritten or changed file handles!) *) - warned_unclosed := Set.union !warned_unclosed (fst (D.filter_values D.opened m)) (* can't save in domain b/c it wouldn't reach the other return *) - ); - (* go through files "never closed" and recheck for current return *) - Set.iter (fun v -> if D.must (D.V.key v) D.closed m then D.warn ~may:true ~loc:(D.V.loc v) "file is never closed") !warned_unclosed; - (* let mustOpenVars = List.map (fun x -> x.key) mustOpen in *) - (* let mayOpen = List.filter (fun x -> not (List.mem x.key mustOpenVars)) mayOpen in (* ignore values that are already in mustOpen *) *) - let mayOpen = Set.diff mayOpen mustOpen in - if Set.cardinal mayOpen > 0 then - D.warn ~may:true @@ "unclosed files: "^D.string_of_keys mayOpen; - Set.iter (fun v -> D.warn ~may:true ~loc:(D.V.loc v) "file is never closed") mayOpen - ); - (* take care of return value *) - let au = match exp with - | Some(Lval lval) when D.mem (D.key_from_lval lval) m -> (* we return a var in D *) - let k = D.key_from_lval lval in - let varinfo,offset = k in - if varinfo.vglob then - D.alias return_var k m (* if var is global, we alias it *) - else - D.add return_var (D.find' k m) m (* if var is local, we make a copy *) - | _ -> m - in - (* remove formals and locals *) - (* this is not a good approach, what if we added a key foo.fp? -> just keep the globals *) - List.fold_left (fun m var -> D.remove' (var, `NoOffset) m) au (f.sformals @ f.slocals) - (* D.only_globals au *) - - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - let m = if f.svar.vname <> "main" then - (* push current location onto stack *) - D.edit_callstack (BatList.cons (Option.get !Node.current_node)) ctx.local - else ctx.local in - (* we need to remove all variables that are neither globals nor special variables from the domain for f *) - (* problem: we need to be able to check aliases of globals in check_overwrite_open -> keep those in too :/ *) - (* TODO see Base.make_entry, reachable vars > globals? *) - (* [m, D.only_globals m] *) - [m, m] (* this is [caller, callee] *) - - let check_overwrite_open k m = (* used in combine and special *) - if List.is_empty (D.get_aliases k m) then ( - (* there are no other variables pointing to the file handle - and it is opened again without being closed before *) - D.report k D.opened ("overwriting still opened file handle "^D.string_of_key k) m; - let mustOpen, mayOpen = D.filter_records k D.opened m in - let mayOpen = Set.diff mayOpen mustOpen in - (* save opened files in the domain to warn about unclosed files at the end *) - D.extend_value unclosed_var (mustOpen, mayOpen) m - ) else m - - let combine_env ctx lval fexp f args fc au f_ask = - let m = ctx.local in - (* pop the last location off the stack *) - let m = D.edit_callstack List.tl m in (* TODO could it be problematic to keep this in the caller instead of callee domain? if we only add the stack for the callee in enter, then there would be no need to pop a location anymore... *) - (* TODO add all globals from au to m (since we remove formals and locals on return, we can just add everything except special vars?) *) - D.without_special_vars au |> D.add_all m - - let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = - let m = ctx.local in - let return_val = D.find_option return_var au in - match lval, return_val with - | Some lval, Some v -> - let k = D.key_from_lval lval in - (* handle potential overwrites *) - let m = check_overwrite_open k m in - (* if v.key is still in D, then it must be a global and we need to alias instead of rebind *) - (* TODO what if there is a local with the same name as the global? *) - if D.V.is_top v then (* returned a local that was top -> just add k as top *) - D.add' k v m - else (* v is now a local which is not top or a global which is aliased *) - let vvar = D.V.get_alias v in (* this is also ok if v is not an alias since it chooses an element from the May-Set which is never empty (global top gets aliased) *) - if D.mem vvar au then (* returned variable was a global TODO what if local had the same name? -> seems to work *) - D.alias k vvar m - else (* returned variable was a local *) - let v = D.V.set_key k v in (* adjust var-field to lval *) - D.add' k v m - | _ -> m - - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = - (* is f a pointer to a function we look out for? *) - let f = eval_fv (Analyses.ask_of_ctx ctx) (Lval (Var f, NoOffset)) |? f in - let m = ctx.local in - let loc = (Option.get !Node.current_node)::(D.callstack m) in - let arglist = List.map (Cil.stripCasts) arglist in (* remove casts, TODO safe? *) - let split_err_branch lval dom = - (* type? NULL = 0 = 0-ptr? Cil.intType, Cil.intPtrType, Cil.voidPtrType -> no difference *) - if not (GobConfig.get_bool "ana.file.optimistic") then - ctx.split dom [Events.SplitBranch ((Cil.BinOp (Cil.Eq, Cil.Lval lval, Cil.integer 0, Cil.intType)), true)]; - dom - in - (* fold possible keys on domain *) - let ret_all f lval = - let xs = D.keys_from_lval lval (Analyses.ask_of_ctx ctx) in (* get all possible keys for a given lval *) - if xs = [] then (D.warn @@ GobPretty.sprintf "could not resolve %a" CilType.Lval.pretty lval; m) - else if List.compare_length_with xs 1 = 0 then f (List.hd xs) m true - (* else List.fold_left (fun m k -> D.join m (f k m)) m xs *) - else - (* if there is more than one key, join all values and do warnings on the result *) - let v = List.fold_left (fun v k -> match v, D.find_option k m with - | None, None -> None - | Some a, None - | None, Some a -> Some a - | Some a, Some b -> Some (D.V.join a b)) None xs in - (* set all of the keys to the computed joined value *) - (* let m' = Option.map_default (fun v -> List.fold_left (fun m k -> D.add' k v m) m xs) m v in *) - (* then check each key *) - (* List.iter (fun k -> ignore(f k m')) xs; *) - (* get Mval.Exp from lval *) - let k' = D.key_from_lval lval in - (* add joined value for that key *) - let m' = Option.map_default (fun v -> D.add' k' v m) m v in - (* check for warnings *) - ignore(f k' m' true); - (* and join the old domain without issuing warnings *) - List.fold_left (fun m k -> D.join m (f k m false)) m xs - in - match lval, f.vname, arglist with - | None, "fopen", _ -> - D.warn "file handle is not saved!"; m - | Some lval, "fopen", _ -> - let f k m w = - let m = check_overwrite_open k m in - (match arglist with - | Const(CStr(filename,_))::Const(CStr(mode,_))::[] -> - (* M.debug ~category:Analyzer @@ "fopen(\""^filename^"\", \""^mode^"\")"; *) - D.fopen k loc filename mode m |> split_err_branch lval (* TODO k instead of lval? *) - | e::Const(CStr(mode,_))::[] -> - (* ignore(printf "CIL: %a\n" d_plainexp e); *) - (match ctx.ask (Queries.EvalStr e) with - | `Lifted filename -> D.fopen k loc filename mode m - | _ -> D.warn "[Unsound]unknown filename"; D.fopen k loc "???" mode m - ) - | xs -> - let args = (String.concat ", " (List.map CilType.Exp.show xs)) in - M.debug ~category:Analyzer "fopen args: %s" args; - (* List.iter (fun exp -> ignore(printf "%a\n" d_plainexp exp)) xs; *) - D.warn @@ "[Program]fopen needs two strings as arguments, given: "^args; m - ) - in ret_all f lval - - | _, "fclose", [Lval fp] -> - let f k m w = - if w then D.reports k [ - false, D.closed, "closeing already closed file handle "^D.string_of_key k; - true, D.opened, "closeing unopened file handle "^D.string_of_key k - ] m; - D.fclose k loc m - in ret_all f fp - | _, "fclose", _ -> - D.warn "fclose needs exactly one argument"; m - - | _, "fprintf", (Lval fp)::_::_ -> - let f k m w = - if w then D.reports k [ - false, D.closed, "writing to closed file handle "^D.string_of_key k; - true, D.opened, "writing to unopened file handle "^D.string_of_key k; - true, D.writable, "writing to read-only file handle "^D.string_of_key k; - ] m; - m - in ret_all f fp - | _, "fprintf", fp::_::_ -> - (* List.iter (fun exp -> ignore(printf "%a\n" d_plainexp exp)) arglist; *) - print_query_lv ~msg:"fprintf(?, ...): " (Analyses.ask_of_ctx ctx) fp; - D.warn "[Program]first argument to printf must be a Lval"; m - | _, "fprintf", _ -> - D.warn "[Program]fprintf needs at least two arguments"; m - - | _ -> m - - let startstate v = D.bot () - let threadenter ctx ~multiple lval f args = [D.bot ()] - let threadspawn ctx ~multiple lval f args fctx = ctx.local - let exitstate v = D.bot () -end - -let _ = - MCP.register_analysis (module Spec : MCPSpec) diff --git a/src/analyses/loopTermination.ml b/src/analyses/loopTermination.ml index 10e0f5c5f4..857b6189d0 100644 --- a/src/analyses/loopTermination.ml +++ b/src/analyses/loopTermination.ml @@ -19,7 +19,7 @@ let check_bounded ctx varinfo = (** We want to record termination information of loops and use the loop * statements for that. We use this lifting because we need to have a * lattice. *) -module Statements = Lattice.Flat (CilType.Stmt) (Printable.DefaultNames) +module Statements = Lattice.Flat (CilType.Stmt) (** The termination analysis considering loops and gotos *) module Spec : Analyses.MCPSpec = diff --git a/src/analyses/mCPRegistry.ml b/src/analyses/mCPRegistry.ml index 810da827ff..3961bc4d60 100644 --- a/src/analyses/mCPRegistry.ml +++ b/src/analyses/mCPRegistry.ml @@ -215,7 +215,7 @@ struct let arbitrary () = let arbs = map (fun (n, (module D: Printable.S)) -> QCheck.map ~rev:(fun (_, o) -> obj o) (fun x -> (n, repr x)) @@ D.arbitrary ()) @@ domain_list () in - MyCheck.Arbitrary.sequence arbs + GobQCheck.Arbitrary.sequence arbs let relift = unop_map (fun (module S: Printable.S) x -> Obj.repr (S.relift (Obj.obj x))) end @@ -426,7 +426,7 @@ end module DomVariantLattice (DLSpec : DomainListLatticeSpec) = struct - include Lattice.Lift (DomVariantLattice0 (DLSpec)) (Printable.DefaultNames) + include Lattice.LiftConf (struct include Printable.DefaultConf let expand1 = false end) (DomVariantLattice0 (DLSpec)) let name () = "MCP.G" end diff --git a/src/analyses/memLeak.ml b/src/analyses/memLeak.ml index 05e18e2e39..456d434be7 100644 --- a/src/analyses/memLeak.ml +++ b/src/analyses/memLeak.ml @@ -205,12 +205,12 @@ struct | Malloc _ | Calloc _ | Realloc _ -> - (ctx.sideg () true; + ctx.sideg () true; begin match ctx.ask (Queries.AllocVar {on_stack = false}) with | `Lifted var -> ToppedVarInfoSet.add var state | _ -> state - end) + end | Free ptr -> begin match ctx.ask (Queries.MayPointTo ptr) with | ad when (not (Queries.AD.is_top ad)) && Queries.AD.cardinal ad = 1 -> @@ -228,24 +228,20 @@ struct warn_for_multi_threaded_due_to_abort ctx; state | Assert { exp; _ } -> - let warn_for_assert_exp = - match ctx.ask (Queries.EvalInt exp) with + begin match ctx.ask (Queries.EvalInt exp) with | a when Queries.ID.is_bot a -> M.warn ~category:Assert "assert expression %a is bottom" d_exp exp | a -> begin match Queries.ID.to_bool a with - | Some b -> ( + | Some true -> () + | Some false -> (* If we know for sure that the expression in "assert" is false => need to check for memory leaks *) - if b = false then ( - warn_for_multi_threaded_due_to_abort ctx; - check_for_mem_leak ctx - ) - else ()) + warn_for_multi_threaded_due_to_abort ctx; + check_for_mem_leak ctx | None -> - (warn_for_multi_threaded_due_to_abort ctx; - check_for_mem_leak ctx ~assert_exp_imprecise:true ~exp:(Some exp)) + warn_for_multi_threaded_due_to_abort ctx; + check_for_mem_leak ctx ~assert_exp_imprecise:true ~exp:(Some exp) end - in - warn_for_assert_exp; + end; state | ThreadExit _ -> begin match ctx.ask (Queries.CurrentThreadId) with diff --git a/src/analyses/modifiedSinceLongjmp.ml b/src/analyses/modifiedSinceSetjmp.ml similarity index 96% rename from src/analyses/modifiedSinceLongjmp.ml rename to src/analyses/modifiedSinceSetjmp.ml index a129c9f92c..93e55b2a17 100644 --- a/src/analyses/modifiedSinceLongjmp.ml +++ b/src/analyses/modifiedSinceSetjmp.ml @@ -1,6 +1,4 @@ -(** Analysis of variables modified since [setjmp] ([modifiedSinceLongjmp]). *) - -(* TODO: this name is wrong *) +(** Analysis of variables modified since [setjmp] ([modifiedSinceSetjmp]). *) open GoblintCil open Analyses @@ -9,7 +7,7 @@ module Spec = struct include Analyses.IdentitySpec - let name () = "modifiedSinceLongjmp" + let name () = "modifiedSinceSetjmp" module D = JmpBufDomain.LocallyModifiedMap module VS = D.VarSet module C = Lattice.Unit diff --git a/src/analyses/mutexAnalysis.ml b/src/analyses/mutexAnalysis.ml index ee050f55ca..a13c8d6bfd 100644 --- a/src/analyses/mutexAnalysis.ml +++ b/src/analyses/mutexAnalysis.ml @@ -132,7 +132,7 @@ struct module G = struct - include Lattice.Lift2 (GProtecting) (GProtected) (Printable.DefaultNames) + include Lattice.Lift2Conf (struct include Printable.DefaultConf let expand1 = false let expand2 = false end) (GProtecting) (GProtected) let protecting = function | `Bot -> GProtecting.bot () diff --git a/src/analyses/raceAnalysis.ml b/src/analyses/raceAnalysis.ml index 9c2272fabb..6b7217147e 100644 --- a/src/analyses/raceAnalysis.ml +++ b/src/analyses/raceAnalysis.ml @@ -194,7 +194,7 @@ struct module G = struct - include Lattice.Lift2 (OffsetTrie) (MemoSet) (Printable.DefaultNames) + include Lattice.Lift2Conf (struct include Printable.DefaultConf let expand1 = false let expand2 = false end) (OffsetTrie) (MemoSet) let access = function | `Bot -> OffsetTrie.bot () @@ -369,7 +369,7 @@ struct let special ctx (lvalOpt: lval option) (f:varinfo) (arglist:exp list) : D.t = (* perform shallow and deep invalidate according to Library descriptors *) let desc = LibraryFunctions.find f in - if List.mem LibraryDesc.ThreadUnsafe desc.attrs then ( + if List.mem LibraryDesc.ThreadUnsafe desc.attrs && ThreadFlag.is_currently_multi (Analyses.ask_of_ctx ctx) then ( let exp = Lval (Var f, NoOffset) in let conf = 110 in let kind = AccessKind.Call in diff --git a/src/analyses/spec.ml b/src/analyses/spec.ml deleted file mode 100644 index 2f754f6160..0000000000 --- a/src/analyses/spec.ml +++ /dev/null @@ -1,496 +0,0 @@ -(** Analysis using finite automaton specification file ([spec]). - - @author Ralf Vogler - - @see Vogler, R. Verifying Regular Safety Properties of C Programs Using the Static Analyzer Goblint. Section 4. *) - -open Batteries -open GoblintCil -open Analyses - -module SC = SpecCore - -module Spec = -struct - include Analyses.DefaultSpec - - let name() = "spec" - module D = SpecDomain.Dom - module C = SpecDomain.Dom - - (* special variables *) - let return_var = Cilfacade.create_var @@ Cil.makeVarinfo false "@return" Cil.voidType, `NoOffset - let global_var = Cilfacade.create_var @@ Cil.makeVarinfo false "@global" Cil.voidType, `NoOffset - - (* spec data *) - let nodes = ref [] - let edges = ref [] - - let load_specfile () = - let specfile = GobConfig.get_string "ana.spec.file" in - if String.length specfile < 1 then failwith "You need to specify a specification file using --set ana.spec.file path/to/file.spec when using the spec analysis!"; - if not (Sys.file_exists specfile) then failwith @@ "The given spec-file ("^specfile^") doesn't exist (CWD is "^Sys.getcwd ()^")."; - let _nodes, _edges = SpecUtil.parseFile specfile in - nodes := _nodes; edges := _edges (* don't change -> no need to save them in domain *) - - (* module for encapsulating general spec checking functions used in multiple transfer functions (assign, special) *) - (* - .spec-format: - - The file contains two types of definitions: nodes and edges. The labels of nodes are output. The labels of edges are the constraints. - - The given nodes are warnings, which have an implicit back edge to the previous node if used as a target. - - Alternatively warnings can be specified like this: "node1 -w1,w2,w3> node2 ...1" (w1, w2 and w3 will be output when the transition is taken). - - The start node of the first transition is the start node of the automaton. - - End nodes are specified by "node -> end _". - - "_end" is the local warning for nodes that are not in an end state, _END is the warning at return ($ is the list of keys). - - An edge with '_' matches everything. - - Edges with "->>" (or "-w1,w2>>" etc.) are forwarding edges, which will continue matching the same statement for the target node. - *) - module SpecCheck = - struct - (* custom goto (D.goto is just for modifying) that checks if the target state is a warning and acts accordingly *) - let goto ?may:(may=false) ?change_state:(change_state=true) key state m ws = - let loc = (Option.get !Node.current_node)::(D.callstack m) in - let warn key m msg = - Str.global_replace (Str.regexp_string "$") (D.string_of_key key) msg - |> D.warn ~may:(D.is_may key m || D.is_unknown key m) - in - (* do transition warnings *) - List.iter (fun state -> match SC.warning state !nodes with Some msg -> warn key m msg | _ -> ()) ws; - match SC.warning state !nodes with - | Some msg -> - warn key m msg; - m (* no goto == implicit back edge *) - | None -> - M.debug ~category:Analyzer "GOTO %s: %s -> %s" (D.string_of_key key) (D.string_of_state key m) state; - if not change_state then m - else if may then D.may_goto key loc state m else D.goto key loc state m - - let equal_exp ctx spec_exp cil_exp = match spec_exp, cil_exp with - (* TODO match constants right away to avoid queries? *) - | `String a, Const(CStr (b,_)) -> a=b - (* | `String a, Const(CWStr xs as c) -> failwith "not implemented" *) - (* CWStr is done in base.ml, query only returns `Str if it's safe *) - | `String a, e -> (match ctx.ask (Queries.EvalStr e) with - | `Lifted b -> a = b - | _ -> M.debug ~category:Analyzer "EQUAL String Query: no result!"; false - ) - | `Regex a, e -> (match ctx.ask (Queries.EvalStr e) with - | `Lifted b -> Str.string_match (Str.regexp a) b 0 - | _ -> M.debug ~category:Analyzer "EQUAL Regex String Query: no result!"; false - ) - | `Bool a, e -> (match ctx.ask (Queries.EvalInt e) with - | b -> (match Queries.ID.to_bool b with Some b -> a=b | None -> false) - ) - | `Int a, e -> (match ctx.ask (Queries.EvalInt e) with - | b -> (match Queries.ID.to_int b with Some b -> (Int64.of_int a)=(IntOps.BigIntOps.to_int64 b) | None -> false) - ) - | `Float a, Const(CReal (b, fkind, str_opt)) -> a=b - | `Float a, _ -> M.debug ~category:Analyzer "EQUAL Float: unsupported!"; false - (* arg is a key. currently there can only be one key per constraint, so we already used it for lookup. TODO multiple keys? *) - | `Var a, b -> true - (* arg is a identifier we use for matching constraints. TODO save in domain *) - | `Ident a, b -> true - | `Error s, b -> failwith @@ "Spec error: "^s - (* wildcard matches anything *) - | `Free, b -> true - | a,b -> M.info ~category:Unsound "EQUAL? Unmatched case - assume true..."; true - - let check_constraint ctx get_key matches m new_a old_key (a,ws,fwd,b,c as edge) = - (* If we have come to a wildcard, we match it instantly, but since there is no way of determining a key - this only makes sense if fwd is true (TODO wildcard for global. TODO use old_key). We pass a state replacement as 'new_a', - which will be applied in the following checks. - Multiple forwarding wildcards are not allowed, i.e. new_a must be None, otherwise we end up in a loop. *) - if SC.is_wildcard c && fwd && new_a=None then Some (m,fwd,Some (b,a),old_key) (* replace b with a in the following checks *) - else - (* save original start state of the constraint (needed to detect reflexive edges) *) - let old_a = a in - (* Assume new_a *) - let a = match new_a with - | Some (x,y) when a=x -> y - | _ -> a - in - (* if we forward, we have to replace the starting state for the following constraints *) - let new_a = if fwd then Some (b,a) else None in - (* TODO how to detect the key?? use "$foo" as key, "foo" as var in constraint and "_" for anything we're not interested in. - What to do for multiple keys (e.g. $foo, $bar)? -> Only allow one key & one map per spec-file (e.g. only $ as a key) or implement multiple maps? *) - (* look inside the constraint if there is a key and if yes, return what it corresponds to *) - (* if we can't find a matching key, we use the global key *) - let key = get_key c |? Cil.var (fst global_var) in - (* ignore(printf "KEY: %a\n" d_plainlval key); *) - (* get possible keys that &lval may point to *) - let keys = D.keys_from_lval key (Analyses.ask_of_ctx ctx) in (* does MayPointTo query *) - let check_key (m,n) var = - (* M.debug ~category:Analyzer @@ "check_key: "^f.vname^"(...): "^D.string_of_entry var m; *) - let wildcard = SC.is_wildcard c && fwd && b<>"end" in - (* skip transitions we can't take b/c we're not in the right state *) - (* i.e. if not in map, we must be at the start node or otherwise we must be in one of the possible saved states *) - if not (D.mem var m) && a<>SC.startnode !edges || D.mem var m && not (D.may_in_state var a m) then ( - (* ignore(printf "SKIP %s: state: %s, a: %s at %i\n" f.vname (D.string_of_state var m) a (!Tracing.current_loc.line)); *) - (m,n) (* not in map -> initial state. TODO save initial state? *) - ) - (* edge must match the current state or be a wildcard transition (except those for end) *) - else if not (matches edge) && not wildcard then (m,n) - (* everything matches the constraint -> go to new state and increase counter *) - else - (* TODO if #Queries.MayPointTo > 1: each result is May, but all combined are Must *) - let may = (List.compare_length_with keys 1 > 0) in - (* do not change state for reflexive edges where the key is not assigned to (e.g. *$p = _) *) - let change_state = not (old_a=b && SC.get_lval c <> Some `Var) in - M.debug ~category:Analyzer "GOTO ~may:%B ~change_state:%B. %s -> %s: %s" may change_state a b (SC.stmt_to_string c); - let new_m = goto ~may:may ~change_state:change_state var b m ws in - (new_m,n+1) - in - (* do check for each varinfo and return the resulting domain if there has been at least one matching constraint *) - let new_m,n = List.fold_left check_key (m,0) keys in (* start with original domain and #transitions=0 *) - if n==0 then None (* no constraint matched the current state *) - else Some (new_m,fwd,new_a,Some key) (* return new domain and forwarding info *) - - let check ctx get_key matches = - let m = ctx.local in - (* go through constraints and return resulting domain for the first match *) - (* if no constraint matches, the unchanged domain is returned *) - (* repeat for target node if it is a forwarding edge *) - (* TODO what should be done if multiple constraints would match? *) - (* TODO ^^ for May-Sets multiple constraints could match and should be taken! *) - try - let rec check_fwd_loop m new_a old_key = (* TODO cycle detection? *) - let new_m,fwd,new_a,key = List.find_map (check_constraint ctx get_key matches m new_a old_key) !edges in - (* List.iter (fun x -> M.debug ~category:Analyzer (x^"\n")) (D.string_of_map new_m); *) - if fwd then M.debug ~category:Analyzer "FWD: %B, new_a: %s, old_key: %s" fwd (dump new_a) (dump old_key); - if fwd then check_fwd_loop new_m new_a key else new_m,key - in - (* now we get the new domain and the latest key that was used *) - let new_m,key = check_fwd_loop m None None in - (* List.iter (fun x -> M.debug ~category:Analyzer (x^"\n")) (D.string_of_map new_m); *) - (* next we have to check if there is a branch() transition we could take *) - let branch_edges = List.filter (fun (a,ws,fwd,b,c) -> SC.is_branch c) !edges in - (* just for the compiler: key is initialized with None, but changes once some constaint matches. If none match, we wouldn't be here but at catch Not_found. *) - match key with - | Some key -> - (* we need to pass the key to the branch function. There is no scheme for getting the key from the constraint, but we should have been forwarded and can use the old key. *) - let check_branch branches var = - (* only keep those branch_edges for which our key might be in the right state *) - let branch_edges = List.filter (fun (a,ws,fwd,b,c) -> D.may_in_state var a new_m) branch_edges in - (* M.debug ~category:Analyzer @@ D.string_of_entry var new_m^" -> branch_edges: "^String.concat "\n " @@ List.map (fun x -> SC.def_to_string (SC.Edge x)) branch_edges; *) - (* count should be a multiple of 2 (true/false), otherwise the spec is malformed *) - if List.length branch_edges mod 2 <> 0 then failwith "Spec is malformed: branch-transitions always need a true and a false case!" else - (* if nothing matches, just return new_m without branching *) - (* if List.is_empty branch_edges then Set.of_list new_m else *) - if List.is_empty branch_edges then Set.of_list ([new_m, Cil.integer 1, true]) else (* XX *) - (* unique set of (dom,exp,tv) used in branch *) - let do_branch branches (a,ws,fwd,b,c) = - let c_str = match SC.branch_exp c with Some (exp,tv) -> SC.exp_to_string exp | _ -> "" in - let c_str = Str.global_replace (Str.regexp_string "$key") "%e:key" c_str in (* TODO what should be used to specify the key? *) - (* TODO this somehow also prints the expression!? why?? *) - let c_exp = Formatcil.cExp c_str [("key", Fe (D.K.to_cil_exp var))] in (* use Fl for Lval instead? *) - (* TODO encode key in exp somehow *) - (* ignore(printf "BRANCH %a\n" d_plainexp c_exp); *) - ctx.split new_m [Events.SplitBranch (c_exp, true)]; - Set.add (new_m,c_exp,true) (Set.add (new_m,c_exp,false) branches) - in - List.fold_left do_branch branches branch_edges - in - let keys = D.keys_from_lval key (Analyses.ask_of_ctx ctx) in - let new_set = List.fold_left check_branch Set.empty keys in ignore(new_set); (* TODO refactor *) - (* List.of_enum (Set.enum new_set) *) - new_m (* XX *) - | None -> new_m - with Not_found -> m (* nothing matched -> no change *) - end - - (* queries *) - let query ctx (type a) (q: a Queries.t) = - match q with - | _ -> Queries.Result.top q - - let query_addrs ask exp = - match ask (Queries.MayPointTo exp) with - | ad when not (Queries.AD.is_top ad) -> Queries.AD.elements ad - | _ -> [] - - let eval_fv ask exp: varinfo option = - match query_addrs ask exp with - | [addr] -> Queries.AD.Addr.to_var_may addr - | _ -> None - - - (* transfer functions *) - let assign ctx (lval:lval) (rval:exp) : D.t = - (* ignore(printf "%a = %a\n" d_plainlval lval d_plainexp rval); *) - let get_key c = match SC.get_key_variant c with - | `Lval s -> - M.debug ~category:Analyzer "Key variant assign `Lval %s; %s" s (SC.stmt_to_string c); - (match SC.get_lval c, lval with - | Some `Var, _ -> Some lval - | Some `Ptr, (Mem Lval x, o) -> Some x (* TODO offset? *) - | _ -> None) - | _ -> None - in - let matches (a,ws,fwd,b,c) = - SC.equal_form (Some lval) c && - (* check for constraints *p = _ where p is the key *) - match lval, SC.get_lval c with - | (Mem Lval x, o), Some `Ptr when SpecCheck.equal_exp ctx (SC.get_rval c) rval -> - let keys = D.keys_from_lval x (Analyses.ask_of_ctx ctx) in - if List.compare_length_with keys 1 <> 0 then failwith "not implemented" - else true - | _ -> false (* nothing to do *) - in - let m = SpecCheck.check ctx get_key matches in - let key_from_exp = function - | Lval (Var v,o) -> Some (v, Offset.Exp.of_cil o) - | _ -> None - in - match key_from_exp (Lval lval), key_from_exp (stripCasts rval) with (* TODO for now we just care about Lval assignments -> should use Queries.MayPointTo *) - | Some k1, Some k2 when k1=k2 -> m (* do nothing on self-assignment *) - | Some k1, Some k2 when D.mem k1 m && D.mem k2 m -> (* both in D *) - M.debug ~category:Analyzer "assign (both in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); - (* saveOpened k1 *) m |> D.remove' k1 |> D.alias k1 k2 - | Some k1, Some k2 when D.mem k1 m -> (* only k1 in D *) - M.debug ~category:Analyzer "assign (only k1 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); - (* saveOpened k1 *) m |> D.remove' k1 - | Some k1, Some k2 when D.mem k2 m -> (* only k2 in D *) - M.debug ~category:Analyzer "assign (only k2 in D): %s = %s" (D.string_of_key k1) (D.string_of_key k2); - let m = D.alias k1 k2 m in (* point k1 to k2 *) - if Basetype.Variables.to_group (fst k2) = Temp (* check if k2 is a temporary Lval introduced by CIL *) - then D.remove' k2 m (* if yes we need to remove it from our map *) - else m (* otherwise no change *) - | Some k1, _ when D.mem k1 m -> (* k1 in D and assign something unknown *) - M.debug ~category:Analyzer "assign (only k1 in D): %s = %a" (D.string_of_key k1) d_exp rval; - D.warn @@ "changed pointer "^D.string_of_key k1^" (no longer safe)"; - (* saveOpened ~unknown:true k1 *) m |> D.unknown k1 - | _ -> (* no change in D for other things *) - M.debug ~category:Analyzer "assign (none in D): %a = %a [%a]" d_lval lval d_exp rval d_plainexp rval; - m - - (* - - branch-transitions in the spec-file come in pairs: e.g. true-branch goes to node a, false-branch to node b - - branch is called for both possibilities - - TODO query the exp and take/don't take the transition - - in case of `Top we take the transition - - both branches get joined after (e.g. for fopen: May [open; error]) - - if there is a branch in the code, branch is also called - -> get the key from exp and backtrack to the corresponding branch-transitions - -> reevaluate with current exp and meet domain with result - *) - (* - - get key from exp - - ask EvalInt - - if result is `Top and we are in a state that is the starting node of a branch edge, we have to: - - go to target node and modify the state in specDomain - - find out which value of key makes exp equal to tv - - save this value and answer queries for EvalInt with it - - if not, compare it with tv and take the corresponding branch - *) - let branch ctx (exp:exp) (tv:bool) : D.t = - let m = ctx.local in - (* ignore(printf "if %a = %B (line %i)\n" d_plainexp exp tv (!Tracing.current_loc).line); *) - let check a b tv = - (* ignore(printf "check: %a = %a\n" d_plainexp a d_plainexp b); *) - match a, b with - | Const (CInt(i, kind, str)), Lval lval - | Lval lval, Const (CInt(i, kind, str)) -> - (* let binop = BinOp (Eq, a, b, Cil.intType) in *) - (* standardize the format of the expression to 'lval==i'. -> spec needs to follow that format, the code is mapped to it. *) - let binop = BinOp (Eq, Lval lval, Const (CInt(i, kind, str)), Cil.intType) in - let key = D.key_from_lval lval in - let value = D.find key m in - if Z.equal i Z.zero && tv then ( - M.debug ~category:Analyzer "error-branch"; - (* D.remove key m *) - )else( - M.debug ~category:Analyzer "success-branch"; - (* m *) - ); - (* there should always be an entry in our domain for key *) - if not (D.mem key m) then m else - (* TODO for now we just assume that a Binop is used and Lval is the key *) - (* get the state(s) that key is/might be in *) - let states = D.get_states key m in - (* compare SC.exp with Cil.exp and tv *) - let branch_exp_eq c exp tv = - (* let c_str = match SC.branch_exp c with Some (exp,tv) -> SC.exp_to_string exp | _ -> "" in - let c_str = Str.global_replace (Str.regexp_string "$key") "%e:key" c_str in - let c_exp = Formatcil.cExp c_str [("key", Fe (D.K.to_exp key))] in *) - (* c_exp=exp *) (* leads to Out_of_memory *) - match SC.branch_exp c with - | Some (c_exp,c_tv) -> - (* let exp_str = CilType.Exp.show exp in *) (* contains too many casts, so that matching fails *) - let exp_str = CilType.Exp.show binop in - let c_str = SC.exp_to_string c_exp in - let c_str = Str.global_replace (Str.regexp_string "$key") (D.string_of_key key) c_str in - (* ignore(printf "branch_exp_eq: '%s' '%s' -> %B\n" c_str exp_str (c_str=exp_str)); *) - c_str=exp_str && c_tv=tv - | _ -> false - in - (* filter those edges that are branches, start with a state from states and have the same branch expression and the same tv *) - let branch_edges = List.filter (fun (a,ws,fwd,b,c) -> SC.is_branch c && List.mem a states && branch_exp_eq c exp tv) !edges in - (* there should be only one such edge or none *) - if List.compare_length_with branch_edges 1 <> 0 then ( (* call of branch for an actual branch *) - M.debug ~category:Analyzer "branch: branch_edges length is not 1! -> actual branch"; - M.debug ~category:Analyzer "%s -> branch_edges1: %a" (D.string_of_entry key m) (Pretty.d_list "\n " (fun () x -> Pretty.text (SC.def_to_string (SC.Edge x)))) branch_edges; - (* filter those edges that are branches, end with a state from states have the same branch expression and the same tv *) - (* TODO they should end with any predecessor of the current state, not only the direct predecessor *) - let branch_edges = List.filter (fun (a,ws,fwd,b,c) -> SC.is_branch c && List.mem b states && branch_exp_eq c exp tv) !edges in - M.debug ~category:Analyzer "%s -> branch_edges2: %a" (D.string_of_entry key m) (Pretty.d_list "\n " (fun () x -> Pretty.text (SC.def_to_string (SC.Edge x)))) branch_edges; - if List.compare_length_with branch_edges 1 <> 0 then m else - (* meet current value with the target state. this is tricky: we can not simply take the target state, since there might have been more than one element already before the branching. - -> find out what the alternative branch target was and remove it *) - let (a,ws,fwd,b,c) = List.hd branch_edges in - (* the alternative branch has the same start node, the same branch expression and the negated tv *) - let (a,ws,fwd,b,c) = List.find (fun (a2,ws,fwd,b,c) -> SC.is_branch c && a2=a && branch_exp_eq c exp (not tv)) !edges in - (* now b is the state the alternative branch goes to -> remove it *) - (* TODO may etc. *) - (* being explicit: check how many records there are. if the value is Must b, then we're sure that it is so and we don't remove anything. *) - if D.V.length value = (1,1) then m else (* XX *) - (* there are multiple possible states -> remove b *) - let v2 = D.V.remove_state b value in - (* M.debug ~category:Analyzer @@ "branch: changed state from "^D.V.string_of value^" to "^D.V.string_of v2; *) - D.add key v2 m - ) else (* call of branch directly after splitting *) - let (a,ws,fwd,b,c) = List.hd branch_edges in - (* TODO may etc. *) - let v2 = D.V.set_state b value in - (* M.debug ~category:Analyzer @@ "branch: changed state from "^D.V.string_of value^" to "^D.V.string_of v2; *) - D.add key v2 m - | _ -> M.debug ~category:Analyzer "nothing matched the given BinOp: %a = %a" d_plainexp a d_plainexp b; m - in - match stripCasts (constFold true exp) with - (* somehow there are a lot of casts inside the BinOp which stripCasts only removes when called on the subparts - -> matching as in flagMode didn't work *) - | BinOp (Eq, a, b, _) -> check (stripCasts a) (stripCasts b) tv - | BinOp (Ne, a, b, _) -> check (stripCasts a) (stripCasts b) (not tv) - | UnOp (LNot, a, _) -> check (stripCasts a) (integer 0) tv - (* TODO makes 2 tests fail. probably check changes something it shouldn't *) - (* | Lval _ as a -> check (stripCasts a) (integer 0) (not tv) *) - | e -> M.debug ~category:Analyzer "branch: nothing matched the given exp: %a" d_plainexp e; m - - let body ctx (f:fundec) : D.t = - ctx.local - - let return ctx (exp:exp option) (f:fundec) : D.t = - let m = ctx.local in - (* M.debug ~category:Analyzer @@ "return: ctx.local="^D.short 50 m^D.string_of_callstack m; *) - (* if f.svar.vname <> "main" && BatList.is_empty (D.callstack m) then M.debug ~category:Analyzer @@ "\n\t!!! call stack is empty for function "^f.svar.vname^" !!!"; *) - if f.svar.vname = "main" then ( - let warn_main msg_loc msg_end = (* there is an end warning for local, return or both *) - (* find edges that have 'end' as a target *) - (* we ignore the constraint, TODO maybe find a better syntax for declaring end states *) - let end_states = BatList.filter_map (fun (a,ws,fwd,b,c) -> if b="end" then Some a else None) !edges in - let must_not, may_not = D.filter_values (fun r -> not @@ List.exists (fun end_state -> D.V.in_state end_state r) end_states) m in - let may_not = Set.diff may_not must_not in - (match msg_loc with (* local warnings for entries that must/may not be in an end state *) - | Some msg -> - Set.iter (fun r -> D.warn ~loc:(D.V.loc r) msg) must_not; - Set.iter (fun r -> D.warn ~may:true ~loc:(D.V.loc r) msg) may_not - | None -> ()); - (match msg_end with - | Some msg -> (* warnings at return for entries that must/may not be in an end state *) - let f msg rs = Str.global_replace (Str.regexp_string "$") (D.string_of_keys rs) msg in - if Set.cardinal must_not > 0 then D.warn (f msg must_not); - if Set.cardinal may_not > 0 then D.warn ~may:true (f msg may_not) - | _ -> ()) - in - (* check if there is a warning for entries that are not in an end state *) - match SC.warning "_end" !nodes, SC.warning "_END" !nodes with - | None, None -> () (* nothing to do here *) - | msg_loc,msg_end -> warn_main msg_loc msg_end - ); - (* take care of return value *) - let au = match exp with - | Some(Lval lval) when D.mem (D.key_from_lval lval) m -> (* we return a var in D *) - let k = D.key_from_lval lval in - let varinfo,offset = k in - if varinfo.vglob then - D.alias return_var k m (* if var is global, we alias it *) - else - D.add return_var (D.find' k m) m (* if var is local, we make a copy *) - | _ -> m - in - (* remove formals and locals *) - (* TODO only keep globals like in fileUse *) - List.fold_left (fun m var -> D.remove' (var, `NoOffset) m) au (f.sformals @ f.slocals) - - let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - (* M.debug ~category:Analyzer @@ "entering function "^f.vname^D.string_of_callstack ctx.local; *) - if f.svar.vname = "main" then load_specfile (); - let m = if f.svar.vname <> "main" then - D.edit_callstack (BatList.cons (Option.get !Node.current_node)) ctx.local - else ctx.local in [m, m] - - let combine_env ctx lval fexp f args fc au f_ask = - (* M.debug ~category:Analyzer @@ "leaving function "^f.vname^D.string_of_callstack au; *) - let au = D.edit_callstack List.tl au in - (* remove special return var *) - D.remove' return_var au - - let combine_assign ctx (lval:lval option) fexp (f:fundec) (args:exp list) fc (au:D.t) (f_ask: Queries.ask) : D.t = - let return_val = D.find_option return_var au in - match lval, return_val with - | Some lval, Some v -> - let k = D.key_from_lval lval in - (* handle potential overwrites *) - (* |> check_overwrite_open k *) - (* if v.key is still in D, then it must be a global and we need to alias instead of rebind *) - (* TODO what if there is a local with the same name as the global? *) - if D.V.is_top v then (* returned a local that was top -> just add k as top *) - D.add' k v ctx.local - else (* v is now a local which is not top or a global which is aliased *) - let vvar = D.V.get_alias v in (* this is also ok if v is not an alias since it chooses an element from the May-Set which is never empty (global top gets aliased) *) - if D.mem vvar au then (* returned variable was a global TODO what if local had the same name? -> seems to work *) - (* let _ = M.debug ~category:Analyzer @@ vvar.vname^" was a global -> alias" in *) - D.alias k vvar ctx.local - else (* returned variable was a local *) - let v = D.V.set_key k v in (* adjust var-field to lval *) - (* M.debug ~category:Analyzer @@ vvar.vname^" was a local -> rebind"; *) - D.add' k v ctx.local - | _ -> ctx.local - - let special ctx (lval: lval option) (f:varinfo) (arglist:exp list) : D.t = - let arglist = List.map (Cil.stripCasts) arglist in (* remove casts, TODO safe? *) - let get_key c = match SC.get_key_variant c with - | `Lval s -> - M.debug ~category:Analyzer "Key variant special `Lval %s; %s" s (SC.stmt_to_string c); - lval - | `Arg(s, i) -> - M.debug ~category:Analyzer "Key variant special `Arg(%s, %d). %s" s i (SC.stmt_to_string c); - (try - let arg = List.at arglist i in - match arg with - | Lval x -> Some x (* TODO enough to just assume the arg is already there as a Lval? *) - | AddrOf x -> Some x - | _ -> None - with Invalid_argument s -> - M.debug ~category:Analyzer "Key out of bounds! Msg: %s" s; (* TODO what to do if spec says that there should be more args... *) - None - ) - | _ -> None (* `Rval or `None *) - in - let matches (a,ws,fwd,b,c) = - let equal_args spec_args cil_args = - if List.compare_length_with spec_args 1 = 0 && List.hd spec_args = `Free then - true (* wildcard as an argument matches everything *) - else if List.compare_lengths arglist spec_args <> 0 then ( - M.debug ~category:Analyzer "SKIP the number of arguments doesn't match the specification!"; - false - )else - List.for_all2 (SpecCheck.equal_exp ctx) spec_args cil_args (* TODO Cil.constFold true arg. Test: Spec and c-file: 1+1 *) - in - (* function name must fit the constraint *) - SC.fname_is f.vname c && - (* right form (assignment or not) *) - SC.equal_form lval c && - (* function arguments match those of the constraint *) - equal_args (SC.get_fun_args c) arglist - in - SpecCheck.check ctx get_key matches - - - let startstate v = D.bot () - let threadenter ctx ~multiple lval f args = [D.bot ()] - let threadspawn ctx ~multiple lval f args fctx = ctx.local - let exitstate v = D.bot () -end - -let _ = - MCP.register_analysis (module Spec : MCPSpec) diff --git a/src/analyses/stackTrace.ml b/src/analyses/stackTrace.ml index 3c3bd56640..dd2cedf871 100644 --- a/src/analyses/stackTrace.ml +++ b/src/analyses/stackTrace.ml @@ -36,7 +36,7 @@ struct (* transfer functions *) let enter ctx (lval: lval option) (f:fundec) (args:exp list) : (D.t * D.t) list = - [ctx.local, D.push !Tracing.current_loc ctx.local] + [ctx.local, D.push !Goblint_tracing.current_loc ctx.local] let combine_env ctx lval fexp f args fc au f_ask = ctx.local (* keep local as opposed to IdentitySpec *) @@ -46,7 +46,7 @@ struct let exitstate v = D.top () let threadenter ctx ~multiple lval f args = - [D.push !Tracing.current_loc ctx.local] + [D.push !Goblint_tracing.current_loc ctx.local] end diff --git a/src/analyses/symbLocks.ml b/src/analyses/symbLocks.ml index f6fdd96c2e..c237967a7a 100644 --- a/src/analyses/symbLocks.ml +++ b/src/analyses/symbLocks.ml @@ -106,13 +106,12 @@ struct module A = struct - module E = struct - include Printable.Either (CilType.Offset) (ILock) - - let pretty () = function - | `Left o -> Pretty.dprintf "p-lock:%a" (d_offset (text "*")) o - | `Right addr -> Pretty.dprintf "i-lock:%a" ILock.pretty addr + module PLock = + struct + include CilType.Offset + let name () = "p-lock" + let pretty = d_offset (text "*") include Printable.SimplePretty ( struct type nonrec t = t @@ -120,6 +119,7 @@ struct end ) end + module E = Printable.Either (PLock) (ILock) include SetDomain.Make (E) let name () = "symblock" diff --git a/src/analyses/threadAnalysis.ml b/src/analyses/threadAnalysis.ml index 01c5dd87fa..ed30e3633e 100644 --- a/src/analyses/threadAnalysis.ml +++ b/src/analyses/threadAnalysis.ml @@ -57,16 +57,18 @@ struct | ThreadJoin { thread = id; ret_var } -> (* TODO: generalize ThreadJoin like ThreadCreate *) (let has_clean_exit tid = not (BatTuple.Tuple3.third (ctx.global tid)) in + let tids = ctx.ask (Queries.EvalThread id) in let join_thread s tid = if has_clean_exit tid && not (is_not_unique ctx tid) then D.remove tid s else s in - match TS.elements (ctx.ask (Queries.EvalThread id)) with - | [t] -> join_thread ctx.local t (* single thread *) - | _ -> ctx.local (* if several possible threads are may-joined, none are must-joined *) - | exception SetDomain.Unsupported _ -> ctx.local) + if TS.is_top tids + then ctx.local + else match TS.elements tids with + | [t] -> join_thread ctx.local t (* single thread *) + | _ -> ctx.local (* if several possible threads are may-joined, none are must-joined *)) | ThreadExit { ret_val } -> handle_thread_return ctx (Some ret_val); ctx.local diff --git a/src/analyses/threadId.ml b/src/analyses/threadId.ml index da2c688ad1..86e7f770a8 100644 --- a/src/analyses/threadId.ml +++ b/src/analyses/threadId.ml @@ -31,7 +31,7 @@ struct module N = struct - include Lattice.Flat (VNI) (struct let bot_name = "unknown node" let top_name = "unknown node" end) + include Lattice.FlatConf (struct include Printable.DefaultConf let bot_name = "unknown node" let top_name = "unknown node" end) (VNI) let name () = "wrapper call" end module TD = Thread.D diff --git a/src/analyses/threadJoins.ml b/src/analyses/threadJoins.ml index 862711073c..160b123e78 100644 --- a/src/analyses/threadJoins.ml +++ b/src/analyses/threadJoins.ml @@ -52,7 +52,7 @@ struct if TIDs.is_top threads then ctx.local else ( - (* elements throws if the thread set is top *) + (* all elements are known *) let threads = TIDs.elements threads in match threads with | [tid] when TID.is_unique tid-> @@ -70,7 +70,7 @@ struct (MustTIDs.bot(), true) (* consider everything joined, MustTIDs is reversed so bot is All threads *) ) else ( - (* elements throws if the thread set is top *) + (* all elements are known *) let threads = TIDs.elements threads in if List.compare_length_with threads 1 > 0 then M.info ~category:Unsound "Ambiguous thread ID assume-joined, assuming all of those threads must-joined."; diff --git a/src/analyses/tutorials/signs.ml b/src/analyses/tutorials/signs.ml index 31168df86a..2c26ad33b6 100644 --- a/src/analyses/tutorials/signs.ml +++ b/src/analyses/tutorials/signs.ml @@ -36,7 +36,7 @@ end * We then lift the above operations to the lattice. *) module SL = struct - include Lattice.Flat (Signs) (Printable.DefaultNames) + include Lattice.Flat (Signs) let of_int i = `Lifted (Signs.of_int i) let lt x y = match x, y with diff --git a/src/analyses/useAfterFree.ml b/src/analyses/useAfterFree.ml index a901a8d2e5..69db6b4bfa 100644 --- a/src/analyses/useAfterFree.ml +++ b/src/analyses/useAfterFree.ml @@ -76,7 +76,7 @@ struct end else if HeapVars.mem heap_var (snd ctx.local) then begin if is_double_free then set_mem_safety_flag InvalidFree else set_mem_safety_flag InvalidDeref; - M.warn ~category:(Behavior behavior) ~tags:[CWE cwe_number] "%s might occur in current unique thread %a for heap variable %a" bug_name ThreadIdDomain.FlagConfiguredTID.pretty current CilType.Varinfo.pretty heap_var + M.warn ~category:(Behavior behavior) ~tags:[CWE cwe_number] "%s might occur in current unique thread %a for heap variable %a" bug_name ThreadIdDomain.Thread.pretty current CilType.Varinfo.pretty heap_var end end | `Top -> diff --git a/src/autoTune.ml b/src/autoTune.ml index 0752d756e6..3cda36a302 100644 --- a/src/autoTune.ml +++ b/src/autoTune.ml @@ -200,7 +200,7 @@ let reduceThreadAnalyses () = (* This is run independent of the autotuner being enabled or not to be sound in the presence of setjmp/longjmp *) (* It is done this way around to allow enabling some of these analyses also for programs without longjmp *) -let longjmpAnalyses = ["activeLongjmp"; "activeSetjmp"; "taintPartialContexts"; "modifiedSinceLongjmp"; "poisonVariables"; "expsplit"; "vla"] +let longjmpAnalyses = ["activeLongjmp"; "activeSetjmp"; "taintPartialContexts"; "modifiedSinceSetjmp"; "poisonVariables"; "expsplit"; "vla"] let activateLongjmpAnalysesWhenRequired () = let isLongjmp = function @@ -224,7 +224,7 @@ let focusOnMemSafetySpecification (spec: Svcomp.Specification.t) = print_endline "Setting \"cil.addNestedScopeAttr\" to true"; set_bool "cil.addNestedScopeAttr" true; print_endline @@ "Specification: ValidDeref -> enabling memOutOfBounds analysis \"" ^ (String.concat ", " memOobAna) ^ "\""; - enableAnalyses memOobAna + enableAnalyses memOobAna; | ValidMemtrack | ValidMemcleanup -> (* Enable the memLeak analysis *) let memLeakAna = ["memLeak"] in diff --git a/src/build-info/dune b/src/build-info/dune index c1de250263..ff8d68671b 100644 --- a/src/build-info/dune +++ b/src/build-info/dune @@ -27,3 +27,6 @@ (mode (promote (until-clean) (only configOcaml.ml))) ; replace existing file in source tree, even if releasing (only overrides) (action (write-file %{target} "(* Automatically regenerated, changes do not persist! *)\nlet flambda = \"%{ocaml-config:flambda}\""))) +(env + (_ + (flags (:standard -w -no-cmx-file)))) ; suppress warning from flambda compiler bug: https://github.com/ocaml/dune/issues/3277 diff --git a/src/analyses/wrapperFunctionAnalysis0.ml b/src/cdomain/value/analyses/wrapperFunctionAnalysis0.ml similarity index 93% rename from src/analyses/wrapperFunctionAnalysis0.ml rename to src/cdomain/value/analyses/wrapperFunctionAnalysis0.ml index 9ea9c0c9aa..cd5940011e 100644 --- a/src/analyses/wrapperFunctionAnalysis0.ml +++ b/src/cdomain/value/analyses/wrapperFunctionAnalysis0.ml @@ -36,7 +36,8 @@ module ThreadCreateUniqueCount = MakeUniqueCount (val unique_count_args_from_config "ana.thread.unique_thread_id_count") (* since the query also references NodeFlatLattice, it also needs to reside here *) -module NodeFlatLattice = Lattice.Flat (Node) (struct +module NodeFlatLattice = Lattice.FlatConf (struct + include Printable.DefaultConf let top_name = "Unknown node" let bot_name = "Unreachable node" - end) + end) (Node) diff --git a/src/cdomain/value/cdomain_value.mld b/src/cdomain/value/cdomain_value.mld new file mode 100644 index 0000000000..668bbfa0ca --- /dev/null +++ b/src/cdomain/value/cdomain_value.mld @@ -0,0 +1,71 @@ +{0 Library goblint.cdomain.value} +This library is unwrapped and provides the following top-level modules. +For better context, see {!Goblint_lib} which also documents these modules. + + +{1 Domains} + +{2 Analysis-specific} + +{3 Value} + +{4 Non-relational} + +{5 Numeric} +{!modules: +IntDomain +FloatDomain +} + +{5 Addresses} +{!modules: +Mval +Offset +StringDomain +AddressDomain +} + +{5 Complex} +{!modules: +StructDomain +UnionDomain +ArrayDomain +NullByteSet +JmpBufDomain +} + +{5 Combined} +{!modules: +ValueDomain +ValueDomainQueries +} + +{3 Concurrency} +{!modules: +MutexAttrDomain +ThreadIdDomain +ConcDomain +} + +{3 Other} +{!modules: +Lval +} + + +{1 I/O} + +{2 Witnesses} +{!modules: +Invariant +InvariantCil +} + + +{1 Utilities} + +{2 Analysis-specific} +{!modules: +PrecisionUtil +WideningThresholds +} diff --git a/src/cdomains/addressDomain.ml b/src/cdomain/value/cdomains/addressDomain.ml similarity index 100% rename from src/cdomains/addressDomain.ml rename to src/cdomain/value/cdomains/addressDomain.ml diff --git a/src/cdomains/addressDomain.mli b/src/cdomain/value/cdomains/addressDomain.mli similarity index 100% rename from src/cdomains/addressDomain.mli rename to src/cdomain/value/cdomains/addressDomain.mli diff --git a/src/cdomains/addressDomain_intf.ml b/src/cdomain/value/cdomains/addressDomain_intf.ml similarity index 100% rename from src/cdomains/addressDomain_intf.ml rename to src/cdomain/value/cdomains/addressDomain_intf.ml diff --git a/src/cdomains/arrayDomain.ml b/src/cdomain/value/cdomains/arrayDomain.ml similarity index 54% rename from src/cdomains/arrayDomain.ml rename to src/cdomain/value/cdomains/arrayDomain.ml index 2f91e47663..d4d5a46e98 100644 --- a/src/cdomains/arrayDomain.ml +++ b/src/cdomain/value/cdomains/arrayDomain.ml @@ -39,15 +39,12 @@ let get_domain ~varAttr ~typAttr = let can_recover_from_top x = x <> TrivialDomain -module type S = +module type S0 = sig include Lattice.S type idx type value - val domain_of_t: t -> domain - - val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value val set: VDQ.t -> t -> Basetype.CilExp.t option * idx -> value -> t val make: ?varAttr:attributes -> ?typAttr:attributes -> idx -> value -> t val length: t -> idx option @@ -60,20 +57,76 @@ sig val smart_widen: (exp -> BI.t option) -> (exp -> BI.t option) -> t -> t -> t val smart_leq: (exp -> BI.t option) -> (exp -> BI.t option) -> t -> t -> bool val update_length: idx -> t -> t + val project: ?varAttr:attributes -> ?typAttr:attributes -> VDQ.t -> t -> t val invariant: value_invariant:(offset:Cil.offset -> lval:Cil.lval -> value -> Invariant.t) -> offset:Cil.offset -> lval:Cil.lval -> t -> Invariant.t end -module type LatticeWithSmartOps = +module type S = +sig + include S0 + + val domain_of_t: t -> domain + val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value +end + +module type Str = +sig + include S0 + + type ret = Null | NotNull | Maybe + type substr = IsNotSubstr | IsSubstrAtIndex0 | IsMaybeSubstr + + val get: VDQ.t -> t -> Basetype.CilExp.t option * idx -> ret + + val to_null_byte_domain: string -> t + val to_string_length: t -> idx + val string_copy: t -> t -> int option -> t + val string_concat: t -> t -> int option -> t + val substring_extraction: t -> t -> substr + val string_comparison: t -> t -> int option -> idx +end + +module type StrWithDomain = +sig + include Str + include S with type t := t and type idx := idx +end + +module type LatticeWithInvalidate = sig include Lattice.S + val invalidate_abstract_value: t -> t +end + +module type LatticeWithSmartOps = +sig + include LatticeWithInvalidate val smart_join: (Cil.exp -> BI.t option) -> (Cil.exp -> BI.t option) -> t -> t -> t val smart_widen: (Cil.exp -> BI.t option) -> (Cil.exp -> BI.t option) -> t -> t -> t val smart_leq: (Cil.exp -> BI.t option) -> (Cil.exp -> BI.t option) -> t -> t -> bool end +module type Null = +sig + type t + type retnull = Null | NotNull | Maybe + + val null: unit -> t + val is_null: t -> retnull + + val get_ikind: t -> Cil.ikind option + val zero_of_ikind: Cil.ikind -> t + val not_zero_of_ikind: Cil.ikind -> t +end + +module type LatticeWithNull = +sig + include LatticeWithSmartOps + include Null with type t := t +end -module Trivial (Val: Lattice.S) (Idx: Lattice.S): S with type value = Val.t and type idx = Idx.t = +module Trivial (Val: LatticeWithInvalidate) (Idx: Lattice.S): S with type value = Val.t and type idx = Idx.t = struct include Val let name () = "trivial arrays" @@ -105,6 +158,7 @@ struct let smart_widen _ _ = widen let smart_leq _ _ = leq let update_length _ x = x + let project ?(varAttr=[]) ?(typAttr=[]) _ t = t let invariant ~value_invariant ~offset ~lval x = @@ -128,7 +182,7 @@ let factor () = | 0 -> failwith "ArrayDomain: ana.base.arrays.unrolling-factor needs to be set when using the unroll domain" | x -> x -module Unroll (Val: Lattice.S) (Idx:IntDomain.Z): S with type value = Val.t and type idx = Idx.t = +module Unroll (Val: LatticeWithInvalidate) (Idx:IntDomain.Z): S with type value = Val.t and type idx = Idx.t = struct module Factor = struct let x () = (get_int "ana.base.arrays.unrolling-factor") end module Base = Lattice.ProdList (Val) (Factor) @@ -804,7 +858,7 @@ let array_oob_check ( type a ) (module Idx: IntDomain.Z with type t = a) (x, l) else () -module TrivialWithLength (Val: Lattice.S) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t = +module TrivialWithLength (Val: LatticeWithInvalidate) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t = struct module Base = Trivial (Val) (Idx) include Lattice.Prod (Base) (Idx) @@ -902,7 +956,7 @@ struct let to_yojson (x, y) = `Assoc [ (Base.name (), Base.to_yojson x); ("length", Idx.to_yojson y) ] end -module UnrollWithLength (Val: Lattice.S) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t = +module UnrollWithLength (Val: LatticeWithInvalidate) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t = struct module Base = Unroll (Val) (Idx) include Lattice.Prod (Base) (Idx) @@ -946,6 +1000,674 @@ struct let to_yojson (x, y) = `Assoc [ (Base.name (), Base.to_yojson x); ("length", Idx.to_yojson y) ] end +module NullByte (Val: LatticeWithNull) (Idx: IntDomain.Z): Str with type value = Val.t and type idx = Idx.t = +struct + module MustSet = NullByteSet.MustSet + module MaySet = NullByteSet.MaySet + module Nulls = NullByteSet.MustMaySet + + let (<.) = Z.lt + let (<=.) = Z.leq + let (>.) = Z.gt + let (>=.) = Z.geq + let (=.) = Z.equal + let (+.) = Z.add + + (* (Must Null Set, May Null Set, Array Size) *) + include Lattice.Prod (Nulls) (Idx) + + let name () = "arrays containing null bytes" + type idx = Idx.t + type value = Val.t + + type ret = Null | NotNull | Maybe + + type substr = IsNotSubstr | IsSubstrAtIndex0 | IsMaybeSubstr + + module ArrayOobMessage = M.Category.Behavior.Undefined.ArrayOutOfBounds + let warn_past_end = M.error ~category:ArrayOobMessage.past_end + + let min_nat_of_idx i = Z.max Z.zero (BatOption.default Z.zero (Idx.minimal i)) + + let get (ask: VDQ.t) (nulls, size) (e, i) = + let min_i = min_nat_of_idx i in + let max_i = Idx.maximal i in + let min_size = min_nat_of_idx size in + + match max_i, Idx.maximal size with + (* if there is no maximum value in index interval *) + | None, _ when not (Nulls.exists Possibly ((<=.) min_i) nulls) -> + (* ... return NotNull if no i >= min_i in may_nulls_set *) + NotNull + | None, _ -> + (* ... else return Top *) + Maybe + (* if there is no maximum size *) + | Some max_i, None when max_i >=. Z.zero -> + (* ... and maximum value in index interval < minimal size, return Null if all numbers in index interval are in must_nulls_set *) + if max_i <. min_size && Nulls.interval_mem Definitely (min_i,max_i) nulls then + Null + (* ... return NotNull if no number in index interval is in may_nulls_set *) + else if not (Nulls.exists Possibly (fun x -> x >=. min_i && x <=. max_i) nulls) then + NotNull + else + Maybe + | Some max_i, Some max_size when max_i >=. Z.zero -> + (* if maximum value in index interval < minimal size, return Null if all numbers in index interval are in must_nulls_set *) + if max_i <. min_size && Nulls.interval_mem Definitely (min_i, max_i) nulls then + Null + (* if maximum value in index interval < maximal size, return NotNull if no number in index interval is in may_nulls_set *) + else if max_i <. max_size && not (Nulls.exists Possibly (fun x -> x >=. min_i && x <=. max_i) nulls) then + NotNull + else + Maybe + (* if maximum number in interval is invalid, i.e. negative, return Top of value *) + | _ -> Maybe + + let set (ask: VDQ.t) (nulls, size) (e, i) v = + let min_size = min_nat_of_idx size in + let min_i = min_nat_of_idx i in + let max_i = Idx.maximal i in + + let set_exact_nulls i = + match Idx.maximal size with + (* if size has no upper limit *) + | None -> + (match Val.is_null v with + | NotNull -> + Nulls.remove (if Nulls.is_full_set Possibly nulls then Possibly else Definitely) i nulls min_size + (* ... and value <> null, remove i from must_nulls_set and also from may_nulls_set if not top *) + | Null -> + Nulls.add (if i <. min_size then Definitely else Possibly) i nulls + (* i < minimal size and value = null, add i to must_nulls_set and may_nulls_set *) + (* i >= minimal size and value = null, add i only to may_nulls_set *) + | Maybe -> + let removed = Nulls.remove Possibly i nulls min_size in + Nulls.add Possibly i removed) + | Some max_size -> + (match Val.is_null v with + | NotNull -> + Nulls.remove Definitely i nulls min_size + (* if value <> null, remove i from must_nulls_set and may_nulls_set *) + | Null when i <. min_size -> + Nulls.add Definitely i nulls + | Null when i <. max_size -> + Nulls.add Possibly i nulls + | Maybe when i <. max_size -> + let removed = Nulls.remove Possibly i nulls min_size in + Nulls.add Possibly i removed + | _ -> nulls + ) + in + + let set_interval min_i max_i = + (* Update max_i so it is capped at the maximum size *) + let max_i = BatOption.map_default (fun x -> Z.min max_i @@ Z.pred x) max_i (Idx.maximal size) in + match Val.is_null v with + | NotNull -> Nulls.remove_interval Possibly (min_i, max_i) min_size nulls + | Null -> Nulls.add_interval ~maxfull:(Idx.maximal size) Possibly (min_i, max_i) nulls + | Maybe -> + let nulls = Nulls.add_interval ~maxfull:(Idx.maximal size) Possibly (min_i, max_i) nulls in + Nulls.remove_interval Possibly (min_i, max_i) min_size nulls + in + + (* warn if index is (potentially) out of bounds *) + array_oob_check (module Idx) (Nulls.get_set Possibly, size) (e, i); + let nulls = match max_i with + (* if no maximum number in index interval *) + | None -> + (* ..., value = null *) + (if Val.is_null v = Null && Idx.maximal size = None then + match Idx.maximal size with + (* ... and there is no maximal size, modify may_nulls_set to top *) + | None -> Nulls.add_all Possibly nulls + (* ... and there is a maximal size, add all i from minimal index to maximal size to may_nulls_set *) + | Some max_size -> Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls + (* ... and value <> null, only keep indexes < minimal index in must_nulls_set *) + else if Val.is_null v = NotNull then + Nulls.filter_musts (Z.gt min_i) min_size nulls + (*..., value unknown *) + else + match Idx.minimal size, Idx.maximal size with + (* ... and size unknown, modify both sets to top *) + | None, None -> Nulls.top () + (* ... and only minimal size known, remove all indexes < minimal size from must_nulls_set and modify may_nulls_set to top *) + | Some min_size, None -> + let nulls = Nulls.add_all Possibly nulls in + Nulls.filter_musts (Z.gt min_size) min_size nulls + (* ... and only maximal size known, modify must_nulls_set to top and add all i from minimal index to maximal size to may_nulls_set *) + | None, Some max_size -> + let nulls = Nulls.remove_all Possibly nulls in + Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls + (* ... and size is known, remove all indexes < minimal size from must_nulls_set and add all i from minimal index to maximal size to may_nulls_set *) + | Some min_size, Some max_size -> + let nulls = Nulls.filter_musts (Z.gt min_size) min_size nulls in + Nulls.add_interval Possibly (min_i, Z.pred max_size) nulls + ) + | Some max_i when max_i >=. Z.zero -> + if min_i =. max_i then + set_exact_nulls min_i + else + set_interval min_i max_i + (* if maximum number in interval is invalid, i.e. negative, return tuple unmodified *) + | _ -> nulls + in + (nulls, size) + + + let make ?(varAttr=[]) ?(typAttr=[]) i v = + let min_i, max_i = match Idx.minimal i, Idx.maximal i with + | Some min_i, Some max_i -> + if min_i <. Z.zero && max_i <. Z.zero then + (M.error ~category:ArrayOobMessage.before_start "Tries to create an array of negative size"; + Z.zero, Some Z.zero) + else if min_i <. Z.zero then + (M.warn ~category:ArrayOobMessage.before_start "May try to create an array of negative size"; + Z.zero, Some max_i) + else + min_i, Some max_i + | None, Some max_i -> + if max_i <. Z.zero then + (M.error ~category:ArrayOobMessage.before_start "Tries to create an array of negative size"; + Z.zero, Some Z.zero) + else + Z.zero, Some max_i + | Some min_i, None -> + if min_i <. Z.zero then + (M.warn ~category:ArrayOobMessage.before_start "May try to create an array of negative size"; + Z.zero, None) + else + min_i, None + | None, None -> Z.zero, None + in + let size = BatOption.map_default (fun max -> Idx.of_interval ILong (min_i, max)) (Idx.starting ILong min_i) max_i in + match Val.is_null v with + | Null -> (Nulls.make_all_must (), size) + | NotNull -> (Nulls.empty (), size) + | Maybe -> (Nulls.top (), size) + + + let length (_, size) = Some size + + let move_if_affected ?(replace_with_const=false) _ x _ _ = x + + let get_vars_in_e _ = [] + + let map f (nulls, size) = + (* if f(null) = null, all values in must_nulls_set still are surely null; + * assume top for may_nulls_set as checking effect of f for every possible value is unfeasbile *) + match Val.is_null (f (Val.null ())) with + | Null -> (Nulls.add_all Possibly nulls, size) + | _ -> (Nulls.top (), size) (* else also return top for must_nulls_set *) + + let fold_left f acc _ = f acc (Val.top ()) + + let smart_join _ _ = join + let smart_widen _ _ = widen + let smart_leq _ _ = leq + + (* string functions *) + + let to_null_byte_domain s = + let last_null = Z.of_int (String.length s) in + let rec build_set i set = + if (Z.of_int i) >=. last_null then + Nulls.Set.add last_null set + else + match String.index_from_opt s i '\x00' with + | Some i -> build_set (i + 1) (Nulls.Set.add (Z.of_int i) set) + | None -> Nulls.Set.add last_null set in + let set = build_set 0 (Nulls.Set.empty ()) in + (Nulls.precise_set set, Idx.of_int ILong (Z.succ last_null)) + + (** Returns an abstract value with at most one null byte marking the end of the string *) + let to_string ((nulls, size) as x:t):t = + (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => warn about certain buffer overflow and return tuple unchanged *) + if Nulls.is_empty Definitely nulls then + (warn_past_end "Array access past end: buffer overflow"; x) + (* if only must_nulls_set empty, no certainty about array containing null byte => warn about potential buffer overflow and return tuple unchanged *) + else if Nulls.is_empty Possibly nulls then + (warn_past_end "May access array past end: potential buffer overflow"; x) + else + let min_must_null = Nulls.min_elem Definitely nulls in + let new_size = Idx.of_int ILong (Z.succ min_must_null) in + let min_may_null = Nulls.min_elem Possibly nulls in + (* if smallest index in sets coincides, only this null byte is kept in both sets *) + let nulls = + if min_must_null =. min_may_null then + Nulls.precise_singleton min_must_null + (* else return empty must_nulls_set and keep every index up to smallest index of must_nulls_set included in may_nulls_set *) + else + match Idx.maximal size with + | Some max_size -> + let nulls' = Nulls.remove_all Possibly nulls in + Nulls.filter ~max_size (Z.leq min_must_null) nulls' + | None when not (Nulls.may_can_benefit_from_filter nulls) -> + Nulls.add_interval Possibly (Z.zero, min_must_null) (Nulls.empty ()) + | None -> + let nulls' = Nulls.remove_all Possibly nulls in + Nulls.filter (Z.leq min_must_null) nulls' + in + (nulls, new_size) + + (** [to_n_string index_set n] returns an abstract value with a potential null byte + * marking the end of the string and if needed followed by further null bytes to obtain + * an n bytes string. *) + let to_n_string (nulls, size) n:t = + if n < 0 then + (Nulls.top (), Idx.top_of ILong) + else + let n = Z.of_int n in + let warn_no_null min_must_null min_may_null = + if Z.geq min_may_null n then + M.warn "Resulting string might not be null-terminated because src doesn't contain a null byte in the first n bytes" + else + (match min_must_null with + | Some min_must_null when not (min_must_null >=. n || min_must_null >. min_may_null) -> () + | _ -> + M.warn "Resulting string might not be null-terminated because src might not contain a null byte in the first n bytes" + ) + in + (match Idx.minimal size, Idx.maximal size with + | Some min_size, Some max_size -> + if n >. max_size then + warn_past_end "Array size is smaller than n bytes; can cause a buffer overflow" + else if n >. min_size then + warn_past_end "Array size might be smaller than n bytes; can cause a buffer overflow" + | Some min_size, None -> + if n >. min_size then + warn_past_end "Array size might be smaller than n bytes; can cause a buffer overflow" + | None, Some max_size -> + if n >. max_size then + warn_past_end "Array size is smaller than n bytes; can cause a buffer overflow" + | None, None -> ()); + let nulls = + (* if definitely no null byte in array, i.e. must_nulls_set = may_nulls_set = empty set *) + if Nulls.is_empty Definitely nulls then + (warn_past_end + "Resulting string might not be null-terminated because src doesn't contain a null byte"; + match Idx.maximal size with + (* ... there *may* be null bytes from maximal size to n - 1 if maximal size < n (i.e. past end) *) + | Some max_size when Z.geq max_size Z.zero -> Nulls.add_interval Possibly (max_size, Z.pred n) nulls + | _ -> nulls) + (* if only must_nulls_set empty, remove indexes >= n from may_nulls_set and add all indexes from minimal may null index to n - 1; + * warn as in any case, resulting array not guaranteed to contain null byte *) + else if Nulls.is_empty Possibly nulls then + let min_may_null = Nulls.min_elem Possibly nulls in + warn_no_null None min_may_null; + if min_may_null =. Z.zero then + Nulls.add_all Possibly nulls + else + let nulls = Nulls.add_interval Possibly (min_may_null, Z.pred n) nulls in + Nulls.filter (fun x -> x <. n) nulls + else + let min_must_null = Nulls.min_elem Definitely nulls in + let min_may_null = Nulls.min_elem Possibly nulls in + (* warn if resulting array may not contain null byte *) + warn_no_null (Some min_must_null) min_may_null; + (* if min_must_null = min_may_null, remove indexes >= n and add all indexes from minimal must/may null to n - 1 in the sets *) + if min_must_null =. min_may_null then + if min_must_null =. Z.zero then + Nulls.full_set () + else + let nulls = Nulls.add_interval Definitely (min_must_null, Z.pred n) nulls in + let nulls = Nulls.add_interval Possibly (min_may_null, Z.pred n) nulls in + Nulls.filter (fun x -> x <. n) nulls + else if min_may_null =. Z.zero then + Nulls.top () + else + let nulls = Nulls.remove_all Possibly nulls in + let nulls = Nulls.add_interval Possibly (min_may_null, Z.pred n) nulls in + Nulls.filter (fun x -> x <. n) nulls + in + (nulls, Idx.of_int ILong n) + + let to_string_length (nulls, size) = + (* if must_nulls_set and min_nulls_set empty, definitely no null byte in array => return interval [size, inf) and warn *) + if Nulls.is_empty Definitely nulls then + (warn_past_end "Array doesn't contain a null byte: buffer overflow"; + Idx.starting !Cil.kindOfSizeOf (BatOption.default Z.zero (Idx.minimal size)) + ) + (* if only must_nulls_set empty, no guarantee that null ever encountered in array => return interval [minimal may null, inf) and *) + else if Nulls.is_empty Possibly nulls then + (warn_past_end "Array might not contain a null byte: potential buffer overflow"; + Idx.starting !Cil.kindOfSizeOf (Nulls.min_elem Possibly nulls)) + (* else return interval [minimal may null, minimal must null] *) + else + Idx.of_interval !Cil.kindOfSizeOf (Nulls.min_elem Possibly nulls, Nulls.min_elem Definitely nulls) + + let string_copy (dstnulls, dstsize) ((srcnulls, srcsize) as src) n = + let must_nulls_set1, may_nulls_set1 = dstnulls in + (* filter out indexes before strlen(src) from dest sets and after strlen(src) from src sets and build union, keep size of dest *) + let update_sets (truncatednulls, truncatedsize) len2 = + let must_nulls_set2',may_nulls_set2' = truncatednulls in + match Idx.minimal dstsize, Idx.maximal dstsize, Idx.minimal len2, Idx.maximal len2 with + | Some min_dstsize, Some max_dstsize, Some min_srclen, Some max_srclen -> + (if max_dstsize <. min_srclen then + warn_past_end "The length of string src is greater than the allocated size for dest" + else if min_dstsize <. max_srclen then + warn_past_end "The length of string src may be greater than the allocated size for dest"); + let must_nulls_set_result = + let min_size2 = BatOption.default Z.zero (Idx.minimal truncatedsize) in + (* get must nulls from src string < minimal size of dest *) + MustSet.filter ~min_size:min_size2 (Z.gt min_dstsize) must_nulls_set2' + (* and keep indexes of dest >= maximal strlen of src *) + |> MustSet.union (MustSet.filter ~min_size:min_dstsize (Z.leq max_srclen) must_nulls_set1) in + let may_nulls_set_result = + let max_size2 = BatOption.default max_dstsize (Idx.maximal truncatedsize) in + (* get may nulls from src string < maximal size of dest *) + MaySet.filter ~max_size:max_size2 (Z.gt max_dstsize) may_nulls_set2' + (* and keep indexes of dest >= minimal strlen of src *) + |> MaySet.union (MaySet.filter ~max_size:max_dstsize (Z.leq min_srclen) may_nulls_set1) in + ((must_nulls_set_result, may_nulls_set_result), dstsize) + + + | Some min_size1, None, Some min_len2, Some max_len2 -> + (if min_size1 <. max_len2 then + warn_past_end "The length of string src may be greater than the allocated size for dest"); + let must_nulls_set_result = + let min_size2 = BatOption.default Z.zero (Idx.minimal truncatedsize) in + MustSet.filter ~min_size: min_size2 (Z.gt min_size1) must_nulls_set2' + |> MustSet.union (MustSet.filter ~min_size:min_size1 (Z.leq max_len2) must_nulls_set1) in + let may_nulls_set_result = + (* get all may nulls from src string as no maximal size of dest *) + may_nulls_set2' + |> MaySet.union (MaySet.filter ~max_size:(Z.succ min_len2) (Z.leq min_len2) may_nulls_set1) in + ((must_nulls_set_result, may_nulls_set_result), dstsize) + | Some min_size1, Some max_size1, Some min_len2, None -> + (if max_size1 <. min_len2 then + warn_past_end "The length of string src is greater than the allocated size for dest" + else if min_size1 <. min_len2 then + warn_past_end"The length of string src may be greater than the allocated size for dest"); + (* do not keep any index of dest as no maximal strlen of src *) + let must_nulls_set_result = + let min_size2 = BatOption.default Z.zero (Idx.minimal truncatedsize) in + MustSet.filter ~min_size:min_size2 (Z.gt min_size1) must_nulls_set2' in + let may_nulls_set_result = + let max_size2 = BatOption.default max_size1 (Idx.maximal truncatedsize) in + MaySet.filter ~max_size:max_size2 (Z.gt max_size1) may_nulls_set2' + |> MaySet.union (MaySet.filter ~max_size:max_size1 (Z.leq min_len2) may_nulls_set1) in + ((must_nulls_set_result, may_nulls_set_result), dstsize) + | Some min_size1, None, Some min_len2, None -> + (if min_size1 <. min_len2 then + warn_past_end "The length of string src may be greater than the allocated size for dest"); + (* do not keep any index of dest as no maximal strlen of src *) + let min_size2 = BatOption.default Z.zero (Idx.minimal truncatedsize) in + let truncatednulls = Nulls.remove_interval Possibly (Z.zero, min_size1) min_size2 truncatednulls in + let filtered_dst = Nulls.filter ~max_size:(Z.succ min_len2) (Z.leq min_len2) dstnulls in + (* get all may nulls from src string as no maximal size of dest *) + (Nulls.union_mays truncatednulls filtered_dst, dstsize) + (* any other case shouldn't happen as minimal index is always >= 0 *) + | _ -> (Nulls.top (), dstsize) in + + (* warn if size of dest is (potentially) smaller than size of src and the latter (potentially) has no null byte at index < size of dest *) + let sizes_warning srcsize = + (match Idx.minimal dstsize, Idx.maximal dstsize, Idx.minimal srcsize, Idx.maximal srcsize with + | Some min_dstsize, _, Some min_srcsize, _ when min_dstsize <. min_srcsize -> + if not (Nulls.exists Possibly (Z.gt min_dstsize) srcnulls) then + warn_past_end "src doesn't contain a null byte at an index smaller than the size of dest" + else if not (Nulls.exists Definitely (Z.gt min_dstsize) srcnulls) then + warn_past_end "src may not contain a null byte at an index smaller than the size of dest" + | Some min_dstsize, _, _, Some max_srcsize when min_dstsize <. max_srcsize -> + if not (Nulls.exists Possibly (Z.gt min_dstsize) srcnulls) then + warn_past_end "src doesn't contain a null byte at an index smaller than the size of dest" + else if not (Nulls.exists Definitely (Z.gt min_dstsize) srcnulls) then + warn_past_end "src may not contain a null byte at an index smaller than the size of dest" + | Some min_dstsize, _, _, None -> + if not (Nulls.exists Definitely (Z.gt min_dstsize) srcnulls) then + warn_past_end "src may not contain a null byte at an index smaller than the size of dest" + | _, Some mac_dstsize, _, Some max_srcsize when mac_dstsize <. max_srcsize -> + if not (Nulls.exists Definitely (Z.gt mac_dstsize) srcnulls) then + warn_past_end "src may not contain a null byte at an index smaller than the size of dest" + |_, Some max_dstsize, _, None -> + if not (Nulls.exists Definitely (Z.gt max_dstsize) srcnulls) then + warn_past_end "src may not contain a null byte at an index smaller than the size of dest" + | _ -> ()) in + + match n with + (* strcpy *) + | None -> + sizes_warning srcsize; + let truncated = to_string src in + update_sets truncated (to_string_length src) + (* strncpy = exactly n bytes from src are copied to dest *) + | Some n when n >= 0 -> + sizes_warning (Idx.of_int ILong (Z.of_int n)); + let truncated = to_n_string src n in + update_sets truncated (Idx.of_int !Cil.kindOfSizeOf (Z.of_int n)) + | _ -> (Nulls.top (), dstsize) + + let string_concat (nulls1, size1) (nulls2, size2) n = + let update_sets min_size1 max_size1 minlen1 maxlen1 minlen2 (maxlen2: Z.t option) nulls2' = + (* track any potential buffer overflow and issue warning if needed *) + (if GobOption.exists (fun x -> x <=. (minlen1 +. minlen2)) max_size1 then + warn_past_end + "The length of the concatenation of the strings in src and dest is greater than the allocated size for dest" + else + (match maxlen1, maxlen2 with + | Some maxlen1, Some maxlen2 when min_size1 >. (maxlen1 +. maxlen2) -> () + | _ -> warn_past_end + "The length of the concatenation of the strings in src and dest may be greater than the allocated size for dest") + ); + (* if any must_nulls_set empty, result must_nulls_set also empty; + * for all i1, i2 in may_nulls_set1, may_nulls_set2: add i1 + i2 if it is <= strlen(dest) + strlen(src) to new may_nulls_set + * and keep indexes > minimal strlen(dest) + strlen(src) of may_nulls_set *) + if Nulls.is_empty Possibly nulls1 || Nulls.is_empty Possibly nulls2 then + match max_size1 with + | Some max_size1 -> + let nulls1_no_must = Nulls.remove_all Possibly nulls1 in + let pred = match maxlen1, maxlen2 with + | Some maxlen1, Some maxlen2 -> (fun x -> x <=. (maxlen1 +. maxlen2)) + | _ -> (fun _ -> true) + in + let r = + nulls1_no_must + (* filter ensures we have the concete representation *) + |> Nulls.filter ~max_size:max_size1 pred + |> Nulls.elements ~max_size:max_size1 Possibly + |> BatList.cartesian_product (Nulls.elements ~max_size:max_size1 Possibly nulls2') + |> List.map (fun (i1, i2) -> i1 +. i2) + |> (fun x -> Nulls.add_list Possibly x (Nulls.filter ~max_size:max_size1 (Z.lt (minlen1 +. minlen2)) nulls1_no_must)) + |> Nulls.filter (Z.gt max_size1) + in + (r, size1) + | None when Nulls.may_can_benefit_from_filter nulls1 && Nulls.may_can_benefit_from_filter nulls2 -> + (match maxlen1, maxlen2 with + | Some maxlen1, Some maxlen2-> + let nulls1_no_must = Nulls.remove_all Possibly nulls1 in + let r = + nulls1_no_must + (* filter ensures we have the concete representation *) + |> Nulls.filter (fun x -> x <=. (maxlen1 +. maxlen2)) + |> Nulls.elements Possibly + |> BatList.cartesian_product (Nulls.elements Possibly nulls2') + |> List.map (fun (i1, i2) -> i1 +. i2) + |> (fun x -> Nulls.add_list Possibly x (Nulls.filter (Z.lt (minlen1 +. minlen2)) nulls1_no_must)) + in + (r, size1) + | _ -> (Nulls.top (), size1)) + | _ -> (Nulls.top (), size1) + (* if minimal must null = minimal may null in ar1 and ar2, add them together and keep indexes > strlen(dest) + strlen(src) of ar1 *) + else if Nulls.min_elem_precise nulls1 && Nulls.min_elem_precise nulls2' then + let min_i1 = Nulls.min_elem Definitely nulls1 in + let min_i2 = Nulls.min_elem Definitely nulls2' in + let min_i = min_i1 +. min_i2 in + let (must_nulls_set1, may_nulls_set1) = nulls1 in + let must_nulls_set_result = + MustSet.filter ~min_size:min_size1 (Z.lt min_i) must_nulls_set1 + |> MustSet.add min_i + |> MustSet.M.filter (Z.gt min_size1) in + let may_nulls_set_result = + match max_size1 with + | Some max_size1 -> + MaySet.filter ~max_size:max_size1 (Z.lt min_i) may_nulls_set1 + |> MaySet.add min_i + |> MaySet.M.filter (fun x -> max_size1 >. x) + | _ -> MaySet.top () + in + ((must_nulls_set_result, may_nulls_set_result), size1) + (* else only add all may nulls together <= strlen(dest) + strlen(src) *) + else + let min_i2 = Nulls.min_elem Definitely nulls2' in + let (must_nulls_set1, may_nulls_set1) = nulls1 in + let (must_nulls_set2', may_nulls_set2') = nulls2' in + let may_nulls_set2'_until_min_i2 = + match Idx.maximal size2 with + | Some max_size2 -> MaySet.filter ~max_size:max_size2 (Z.geq min_i2) may_nulls_set2' + | None -> MaySet.filter ~max_size:(Z.succ min_i2) (Z.geq min_i2) may_nulls_set2' in + let must_nulls_set_result = + let pred = match maxlen1, maxlen2 with + | Some maxlen1, Some maxlen2 -> (fun x -> (maxlen1 +. maxlen2) <. x) + | _ -> (fun _ -> false) + in + MustSet.filter ~min_size:min_size1 pred must_nulls_set1 + in + let may_nulls_set_result = + let pred = match maxlen1, maxlen2 with + | Some maxlen1, Some maxlen2 -> (fun x -> x <=. (maxlen1 +. maxlen2)) + | _ -> (fun _ -> true) + in + match max_size1 with + | Some max_size1 -> + MaySet.filter ~max_size:max_size1 pred may_nulls_set1 + |> MaySet.elements + |> BatList.cartesian_product (MaySet.elements may_nulls_set2'_until_min_i2) + |> List.map (fun (i1, i2) -> i1 +. i2) + |> MaySet.of_list + |> MaySet.union (MaySet.filter ~max_size:max_size1 (Z.lt (minlen1 +. minlen2)) may_nulls_set1) + |> MaySet.M.filter (fun x -> max_size1 >. x) + | None when not (MaySet.is_top may_nulls_set1) -> + MaySet.M.filter pred may_nulls_set1 + |> MaySet.elements + |> BatList.cartesian_product (MaySet.elements may_nulls_set2'_until_min_i2) + |> List.map (fun (i1, i2) -> i1 +. i2) + |> MaySet.of_list + |> MaySet.union (MaySet.M.filter (Z.lt (minlen1 +. minlen2)) may_nulls_set1) + | _ -> + MaySet.top () in + ((must_nulls_set_result, may_nulls_set_result), size1) in + + let compute_concat nulls2' = + let strlen1 = to_string_length (nulls1, size1) in + let strlen2 = to_string_length (nulls2', size2) in + match Idx.minimal size1, Idx.minimal strlen1, Idx.minimal strlen2 with + | Some min_size1, Some minlen1, Some minlen2 -> + begin + let f = update_sets min_size1 (Idx.maximal size1) minlen1 in + match Idx.maximal strlen1, Idx.maximal strlen2 with + | (Some _ as maxlen1), (Some _ as maxlen2) -> f maxlen1 minlen2 maxlen2 nulls2' + | _ -> f None minlen2 None nulls2' + end + (* any other case shouldn't happen as minimal index is always >= 0 *) + | _ -> (Nulls.top (), size1) in + + match n with + (* strcat *) + | None -> + let nulls2', _ = to_string (nulls2, size2) in + compute_concat nulls2' + (* strncat *) + | Some n when n >= 0 -> + let n = Z.of_int n in + (* take at most n bytes from src; if no null byte among them, add null byte at index n *) + let nulls2' = + let (nulls2, size2) = to_string (nulls2, size2) in + if not (Nulls.exists Possibly (Z.gt n) nulls2) then + Nulls.precise_singleton n + else if not (Nulls.exists Definitely (Z.gt n) nulls2) then + let max_size = BatOption.default (Z.succ n) (Idx.maximal size2) in + let nulls2 = Nulls.remove_all Possibly nulls2 in + let nulls2 = Nulls.filter ~max_size (Z.geq n) nulls2 in + Nulls.add Possibly n nulls2 + else + let min_size = BatOption.default Z.zero (Idx.minimal size2) in + let max_size = BatOption.default n (Idx.maximal size2) in + Nulls.filter ~max_size ~min_size (Z.gt n) nulls2 + in + compute_concat nulls2' + | _ -> (Nulls.top (), size1) + + let substring_extraction haystack ((nulls_needle, size_needle) as needle) = + (* if needle is empty string, i.e. certain null byte at index 0, return value of strstr is pointer to haystack *) + if Nulls.mem Definitely Z.zero nulls_needle then + IsSubstrAtIndex0 + else + let haystack_len = to_string_length haystack in + let needle_len = to_string_length needle in + match Idx.maximal haystack_len, Idx.minimal needle_len with + | Some haystack_max, Some needle_min when haystack_max <. needle_min -> + (* if strlen(haystack) < strlen(needle), needle can never be substring of haystack => return None *) + IsNotSubstr + | _ -> IsMaybeSubstr + + let string_comparison (nulls1, size1) (nulls2, size2) n = + let cmp n = + (* if s1 = s2 = empty string, i.e. certain null byte at index 0, or n = 0, return 0 *) + if (Nulls.mem Definitely Z.zero nulls1 && Nulls.mem Definitely Z.zero nulls2) || (BatOption.map_default (Z.equal Z.zero) false n) then + Idx.of_int IInt Z.zero + (* if only s1 = empty string, return negative integer *) + else if Nulls.mem Definitely Z.zero nulls1 && not (Nulls.mem Possibly Z.zero nulls2) then + Idx.ending IInt Z.minus_one + (* if only s2 = empty string, return positive integer *) + else if Nulls.mem Definitely Z.zero nulls2 then + Idx.starting IInt Z.one + else + try + let min_must1 = Nulls.min_elem Definitely nulls1 in + let min_must2 = Nulls.min_elem Definitely nulls2 in + if not (min_must1 =. min_must2) + && min_must1 =.(Nulls.min_elem Possibly nulls1) + && min_must2 =. (Nulls.min_elem Possibly nulls2) + && (BatOption.map_default (fun x -> min_must1 <. x || min_must2 <. x) true n) + then + (* if first null bytes are certain, have different indexes and are before index n if n present, return integer <> 0 *) + Idx.of_excl_list IInt [Z.zero] + else + Idx.top_of IInt + with Not_found -> Idx.top_of IInt + in + + match n with + (* strcmp *) + | None -> + (* track any potential buffer overflow and issue warning if needed *) + let warn_missing_nulls nulls name = + if Nulls.is_empty Definitely nulls then + warn_past_end "Array of string %s doesn't contain a null byte: buffer overflow" name + else if Nulls.is_empty Possibly nulls then + warn_past_end "Array of string %s might not contain a null byte: potential buffer overflow" name + in + warn_missing_nulls nulls1 "1"; + warn_missing_nulls nulls2 "2"; + (* compute abstract value for result of strcmp *) + cmp None + (* strncmp *) + | Some n when n >= 0 -> + let n = Z.of_int n in + let warn_size size name = + let min = min_nat_of_idx size in + match Idx.maximal size with + | Some max when n >. max -> + warn_past_end "The size of the array of string %s is smaller than n bytes" name + | Some max when n >. min -> + warn_past_end "The size of the array of string %s might be smaller than n bytes" name + | None when n >. min -> + warn_past_end "The size of the array of string %s might be smaller than n bytes" name + | _ -> () + in + warn_size size1 "1"; + warn_size size2 "2"; + (* compute abstract value for result of strncmp *) + cmp (Some n) + | _ -> Idx.top_of IInt + + let update_length new_size (nulls, size) = (nulls, new_size) + + let project ?(varAttr=[]) ?(typAttr=[]) _ t = t + + let invariant ~value_invariant ~offset ~lval x = Invariant.none +end + module AttributeConfiguredArrayDomain(Val: LatticeWithSmartOps) (Idx:IntDomain.Z):S with type value = Val.t and type idx = Idx.t = struct module P = PartitionedWithLength(Val)(Idx) @@ -999,7 +1721,7 @@ struct let smart_widen f g = binop_to_t' (P.smart_widen f g) (T.smart_widen f g) (U.smart_widen f g) let smart_leq f g = binop' (P.smart_leq f g) (T.smart_leq f g) (U.smart_leq f g) let update_length newl x = unop_to_t' (P.update_length newl) (T.update_length newl) (U.update_length newl) x - let name () = "AttributeConfiguredArrayDomain" + let name () = "FlagHelperAttributeConfiguredArrayDomain" let bot () = to_t @@ match get_domain ~varAttr:[] ~typAttr:[] with | PartitionedDomain -> (Some (P.bot ()), None, None) @@ -1067,3 +1789,91 @@ struct (T.invariant ~value_invariant ~offset ~lval) (U.invariant ~value_invariant ~offset ~lval) end + +module AttributeConfiguredAndNullByteArrayDomain (Val: LatticeWithNull) (Idx: IntDomain.Z): StrWithDomain with type value = Val.t and type idx = Idx.t = +struct + module A = AttributeConfiguredArrayDomain (Val) (Idx) + module N = NullByte (Val) (Idx) + + include Lattice.Prod (A) (N) + + let name () = "AttributeConfiguredAndNullByteArrayDomain" + type idx = Idx.t + type value = Val.t + + type ret = Null | NotNull | Maybe + type substr = N.substr = IsNotSubstr | IsSubstrAtIndex0 | IsMaybeSubstr + + let domain_of_t (t_f, _) = A.domain_of_t t_f + + let get ?(checkBounds=true) (ask: VDQ.t) (t_f, t_n) i = + let f_get = A.get ~checkBounds ask t_f i in + if get_bool "ana.base.arrays.nullbytes" then + let n_get = N.get ask t_n i in + match Val.get_ikind f_get, n_get with + | Some ik, Null -> Val.meet f_get (Val.zero_of_ikind ik) + | Some ik, NotNull -> Val.meet f_get (Val.not_zero_of_ikind ik) + | _ -> f_get + else + f_get + + let construct a n = + if get_bool "ana.base.arrays.nullbytes" then + (a, n ()) + else + (a, N.top ()) + + let set (ask:VDQ.t) (t_f, t_n) i v = construct (A.set ask t_f i v) (fun () -> N.set ask t_n i v) + let make ?(varAttr=[]) ?(typAttr=[]) i v = construct (A.make ~varAttr ~typAttr i v) (fun () -> N.make ~varAttr ~typAttr i v) + let map f (t_f, t_n) = construct (A.map f t_f) (fun () -> N.map f t_n) + let update_length newl (t_f, t_n) = construct (A.update_length newl t_f) (fun () -> N.update_length newl t_n) + + let smart_binop op_a op_n x y (t_f1, t_n1) (t_f2, t_n2) = construct (op_a x y t_f1 t_f2) (fun () -> op_n x y t_n1 t_n2) + + let smart_join = smart_binop A.smart_join N.smart_join + let smart_widen = smart_binop A.smart_widen N.smart_widen + + let string_op op (t_f1, t_n1) (_, t_n2) n = construct (A.map Val.invalidate_abstract_value t_f1) (fun () -> op t_n1 t_n2 n) + let string_copy = string_op N.string_copy + let string_concat = string_op N.string_concat + + let extract op default (_, t_n1) (_, t_n2) n = + if get_bool "ana.base.arrays.nullbytes" then + op t_n1 t_n2 n + else + (* Hidden behind unit, as constructing defaults may happen to early otherwise *) + (* e.g. for Idx.top_of IInt *) + default () + + let substring_extraction x y = extract (fun x y _ -> N.substring_extraction x y) (fun () -> IsMaybeSubstr) x y None + let string_comparison = extract N.string_comparison (fun () -> Idx.top_of IInt) + + let length (t_f, t_n) = + if get_bool "ana.base.arrays.nullbytes" then + N.length t_n + else + A.length t_f + let move_if_affected ?(replace_with_const=false) (ask:VDQ.t) (t_f, t_n) v f = (A.move_if_affected ~replace_with_const ask t_f v f, N.move_if_affected ~replace_with_const ask t_n v f) + let get_vars_in_e (t_f, _) = A.get_vars_in_e t_f + let fold_left f acc (t_f, _) = A.fold_left f acc t_f + + let smart_leq x y (t_f1, t_n1) (t_f2, t_n2) = + if get_bool "ana.base.arrays.nullbytes" then + A.smart_leq x y t_f1 t_f2 && N.smart_leq x y t_n1 t_n2 + else + A.smart_leq x y t_f1 t_f2 + + let to_null_byte_domain s = + if get_bool "ana.base.arrays.nullbytes" then + (A.make (Idx.top_of ILong) (Val.meet (Val.not_zero_of_ikind IChar) (Val.zero_of_ikind IChar)), N.to_null_byte_domain s) + else + (A.top (), N.top ()) + let to_string_length (_, t_n) = + if get_bool "ana.base.arrays.nullbytes" then + N.to_string_length t_n + else + Idx.top_of !Cil.kindOfSizeOf + + let project ?(varAttr=[]) ?(typAttr=[]) ask (t_f, t_n) = (A.project ~varAttr ~typAttr ask t_f, N.project ~varAttr ~typAttr ask t_n) + let invariant ~value_invariant ~offset ~lval (t_f, _) = A.invariant ~value_invariant ~offset ~lval t_f +end diff --git a/src/cdomains/arrayDomain.mli b/src/cdomain/value/cdomains/arrayDomain.mli similarity index 55% rename from src/cdomains/arrayDomain.mli rename to src/cdomain/value/cdomains/arrayDomain.mli index ebf265ac0b..9b5a713859 100644 --- a/src/cdomains/arrayDomain.mli +++ b/src/cdomain/value/cdomains/arrayDomain.mli @@ -12,8 +12,7 @@ val get_domain: varAttr:Cil.attributes -> typAttr:Cil.attributes -> domain val can_recover_from_top: domain -> bool (** Some domains such as Trivial cannot recover from their value ever being top. {!ValueDomain} handles intialization differently for these *) -(** Abstract domains representing arrays. *) -module type S = +module type S0 = sig include Lattice.S type idx @@ -22,12 +21,6 @@ sig type value (** The abstract domain of values stored in the array. *) - val domain_of_t: t -> domain - (* Returns the domain used for the array*) - - val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value - (** Returns the element residing at the given index. *) - val set: VDQ.t -> t -> Basetype.CilExp.t option * idx -> value -> t (** Returns a new abstract value, where the given index is replaced with the * given element. *) @@ -57,25 +50,104 @@ sig val smart_widen: (Cil.exp -> BigIntOps.t option) -> (Cil.exp -> BigIntOps.t option) -> t -> t -> t val smart_leq: (Cil.exp -> BigIntOps.t option) -> (Cil.exp -> BigIntOps.t option) -> t -> t -> bool val update_length: idx -> t -> t - val project: ?varAttr:Cil.attributes -> ?typAttr:Cil.attributes -> VDQ.t -> t -> t val invariant: value_invariant:(offset:Cil.offset -> lval:Cil.lval -> value -> Invariant.t) -> offset:Cil.offset -> lval:Cil.lval -> t -> Invariant.t end -module type LatticeWithSmartOps = +(** Abstract domains representing arrays. *) +module type S = +sig + include S0 + + val domain_of_t: t -> domain + (* Returns the domain used for the array*) + + val get: ?checkBounds:bool -> VDQ.t -> t -> Basetype.CilExp.t option * idx -> value + (** Returns the element residing at the given index. *) +end + +(** Abstract domains representing strings a.k.a. null-terminated char arrays. *) +module type Str = +sig + include S0 + + type ret = Null | NotNull | Maybe + type substr = IsNotSubstr | IsSubstrAtIndex0 | IsMaybeSubstr + + val get: VDQ.t -> t -> Basetype.CilExp.t option * idx -> ret + (* overwrites get of module S *) + + val to_null_byte_domain: string -> t + (* Converts a string to its abstract value in the NullByte domain *) + + val to_string_length: t -> idx + (** Returns length of string represented by input abstract value *) + + val string_copy: t -> t -> int option -> t + (** [string_copy dest src n] returns an abstract value representing the copy of string [src] + * into array [dest], taking at most [n] bytes of [src] if present *) + + val string_concat: t -> t -> int option -> t + (** [string_concat s1 s2 n] returns a new abstract value representing the string + * concatenation of the input abstract values [s1] and [s2], taking at most [n] bytes of + * [s2] if present *) + + val substring_extraction: t -> t -> substr + (** [substring_extraction haystack needle] returns {!IsNotSubstr} if the string represented by + * the abstract value [needle] surely isn't a substring of [haystack], {!IsSubstrAtIndex0} if + * [needle] is the empty string, else {!IsMaybeSubstr} *) + + val string_comparison: t -> t -> int option -> idx + (** [string_comparison s1 s2 n] returns a negative / positive idx element if the string + * represented by [s1] is less / greater than the one by [s2] or zero if they are equal; + * only compares the first [n] bytes if present *) +end + +module type StrWithDomain = +sig + include Str + include S with type t := t and type idx := idx +end + +module type LatticeWithInvalidate = sig include Lattice.S + val invalidate_abstract_value: t -> t +end + +module type LatticeWithSmartOps = +sig + include LatticeWithInvalidate val smart_join: (Cil.exp -> BigIntOps.t option) -> (Cil.exp -> BigIntOps.t option) -> t -> t -> t val smart_widen: (Cil.exp -> BigIntOps.t option) -> (Cil.exp -> BigIntOps.t option) -> t -> t -> t val smart_leq: (Cil.exp -> BigIntOps.t option) -> (Cil.exp -> BigIntOps.t option) -> t -> t -> bool end -module Trivial (Val: Lattice.S) (Idx: Lattice.S): S with type value = Val.t and type idx = Idx.t +module type Null = +sig + type t + type retnull = Null | NotNull | Maybe + + val null: unit -> t + val is_null: t -> retnull + + val get_ikind: t -> Cil.ikind option + val zero_of_ikind: Cil.ikind -> t + val not_zero_of_ikind: Cil.ikind -> t +end + +module type LatticeWithNull = +sig + include LatticeWithSmartOps + include Null with type t := t +end + +module Trivial (Val: LatticeWithInvalidate) (Idx: Lattice.S): S with type value = Val.t and type idx = Idx.t (** This functor creates a trivial single cell representation of an array. The * indexing type is taken as a parameter to satisfy the type system, it is not * used in the implementation. *) -module TrivialWithLength (Val: Lattice.S) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t +module TrivialWithLength (Val: LatticeWithInvalidate) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t (** This functor creates a trivial single cell representation of an array. The * indexing type is also used to manage the length. *) @@ -90,5 +162,18 @@ module Partitioned (Val: LatticeWithSmartOps) (Idx: IntDomain.Z): S with type va module PartitionedWithLength (Val: LatticeWithSmartOps) (Idx:IntDomain.Z): S with type value = Val.t and type idx = Idx.t (** Like partitioned but additionally manages the length of the array. *) -module AttributeConfiguredArrayDomain(Val: LatticeWithSmartOps) (Idx:IntDomain.Z):S with type value = Val.t and type idx = Idx.t +module NullByte (Val: LatticeWithNull) (Idx: IntDomain.Z): Str with type value = Val.t and type idx = Idx.t +(** This functor creates an array representation by the indexes of all null bytes + * the array must and may contain. This is useful to analyze strings, i.e. null- + * terminated char arrays, and particularly to determine if operations on strings + * could lead to a buffer overflow. Concrete values from Val are not interesting + * for this domain. It additionally tracks the array size. +*) + +module AttributeConfiguredArrayDomain (Val: LatticeWithSmartOps) (Idx: IntDomain.Z): S with type value = Val.t and type idx = Idx.t (** Switches between PartitionedWithLength, TrivialWithLength and Unroll based on variable, type, and flag. *) + +module AttributeConfiguredAndNullByteArrayDomain (Val: LatticeWithNull) (Idx: IntDomain.Z): StrWithDomain with type value = Val.t and type idx = Idx.t +(** Like FlagHelperAttributeConfiguredArrayDomain but additionally runs NullByte + * in parallel if flag "ana.base.arrays.nullbytes" is set. +*) diff --git a/src/cdomains/concDomain.ml b/src/cdomain/value/cdomains/concDomain.ml similarity index 66% rename from src/cdomains/concDomain.ml rename to src/cdomain/value/cdomains/concDomain.ml index b16cdf1d9f..5f609a31d8 100644 --- a/src/cdomains/concDomain.ml +++ b/src/cdomain/value/cdomains/concDomain.ml @@ -1,6 +1,25 @@ (** Domains for thread sets and their uniqueness. *) -module ThreadSet = SetDomain.ToppedSet (ThreadIdDomain.Thread) (struct let topname = "All Threads" end) +module ThreadSet = +struct + include SetDomain.Make (ThreadIdDomain.Thread) + + let is_top = mem UnknownThread + + let top () = singleton UnknownThread + + let merge uop cop x y = + match is_top x, is_top y with + | true, true -> uop x y + | false, true -> x + | true, false -> y + | false, false -> cop x y + + let meet x y = merge join meet x y + + let narrow x y = merge (fun x y -> widen x (join x y)) narrow x y + +end module MustThreadSet = SetDomain.Reverse(ThreadSet) module CreatedThreadSet = ThreadSet diff --git a/src/cdomains/floatDomain.ml b/src/cdomain/value/cdomains/floatDomain.ml similarity index 100% rename from src/cdomains/floatDomain.ml rename to src/cdomain/value/cdomains/floatDomain.ml diff --git a/src/cdomains/floatDomain.mli b/src/cdomain/value/cdomains/floatDomain.mli similarity index 100% rename from src/cdomains/floatDomain.mli rename to src/cdomain/value/cdomains/floatDomain.mli diff --git a/src/cdomains/intDomain.ml b/src/cdomain/value/cdomains/intDomain.ml similarity index 97% rename from src/cdomains/intDomain.ml rename to src/cdomain/value/cdomains/intDomain.ml index 054030017f..986634066c 100644 --- a/src/cdomains/intDomain.ml +++ b/src/cdomain/value/cdomains/intDomain.ml @@ -282,99 +282,6 @@ end module type Z = Y with type int_t = BI.t -module OldDomainFacade (Old : IkindUnawareS with type int_t = int64) : S with type int_t = BI.t and type t = Old.t = -struct - include Old - type int_t = BI.t - let neg ?no_ov _ik = Old.neg - let add ?no_ov _ik = Old.add - let sub ?no_ov _ik = Old.sub - let mul ?no_ov _ik = Old.mul - let div ?no_ov _ik = Old.div - let rem _ik = Old.rem - - let lt _ik = Old.lt - let gt _ik = Old.gt - let le _ik = Old.le - let ge _ik = Old.ge - let eq _ik = Old.eq - let ne _ik = Old.ne - - let bitnot _ik = bitnot - let bitand _ik = bitand - let bitor _ik = bitor - let bitxor _ik = bitxor - - let shift_left _ik = shift_left - let shift_right _ik = shift_right - - let lognot _ik = lognot - let logand _ik = logand - let logor _ik = logor - - - let to_int a = Option.map BI.of_int64 (Old.to_int a) - - let equal_to (x: int_t) (a: t)= - try - Old.equal_to (BI.to_int64 x) a - with Z.Overflow | Failure _ -> `Top - - let to_excl_list a = Option.map (BatTuple.Tuple2.map1 (List.map BI.of_int64)) (Old.to_excl_list a) - let of_excl_list ik xs = - let xs' = List.map BI.to_int64 xs in - Old.of_excl_list ik xs' - - let to_incl_list a = Option.map (List.map BI.of_int64) (Old.to_incl_list a) - - let maximal a = Option.map BI.of_int64 (Old.maximal a) - let minimal a = Option.map BI.of_int64 (Old.minimal a) - - let of_int ik x = - (* If we cannot convert x to int64, we have to represent it with top in the underlying domain*) - try - Old.of_int (BI.to_int64 x) - with - Failure _ -> top_of ik - - let of_bool ik b = Old.of_bool b - let of_interval ?(suppress_ovwarn=false) ik (l, u) = - try - Old.of_interval ~suppress_ovwarn ik (BI.to_int64 l, BI.to_int64 u) - with - Failure _ -> top_of ik - let of_congruence ik (c, m) = - try - Old.of_congruence ik (BI.to_int64 c, BI.to_int64 m) - with - Failure _ -> top_of ik - - let starting ?(suppress_ovwarn=false) ik x = - try Old.starting ~suppress_ovwarn ik (BI.to_int64 x) with Failure _ -> top_of ik - let ending ?(suppress_ovwarn=false) ik x = - try Old.ending ~suppress_ovwarn ik (BI.to_int64 x) with Failure _ -> top_of ik - - let join _ik = Old.join - let meet _ik = Old.meet - let narrow _ik = Old.narrow - let widen _ik = Old.widen - - let is_top_of _ik = Old.is_top - - let invariant_ikind e ik t = Old.invariant e t - - let cast_to ?torg ?no_ov = Old.cast_to ?torg - - let refine_with_congruence ik a b = a - let refine_with_interval ik a b = a - let refine_with_excl_list ik a b = a - let refine_with_incl_list ik a b = a - - let project ik p t = t - - let arbitrary _ik = Old.arbitrary () -end - module IntDomLifter (I : S) = struct @@ -996,12 +903,12 @@ struct let arbitrary ik = let open QCheck.Iter in - (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint MyCheck.Arbitrary.big_int 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 MyCheck.Arbitrary.int64 in + 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) <+> (MyCheck.shrink pair_arb (l, u) >|= of_interval ik >|= fst) + | 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) @@ -1601,13 +1508,13 @@ struct let arbitrary ik = let open QCheck.Iter in - (* let int_arb = QCheck.map ~rev:Ints_t.to_bigint Ints_t.of_bigint MyCheck.Arbitrary.big_int 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 MyCheck.Arbitrary.int64 in + 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 = MyCheck.shrink list_pair_arb xs >|= canonize_randomly_generated_list + 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 @@ -1695,7 +1602,7 @@ struct let logand n1 n2 = of_bool ((to_bool' n1) && (to_bool' n2)) let logor n1 n2 = of_bool ((to_bool' n1) || (to_bool' n2)) let cast_to ?torg t x = failwith @@ "Cast_to not implemented for " ^ (name ()) ^ "." - let arbitrary ik = QCheck.map ~rev:Ints_t.to_int64 Ints_t.of_int64 MyCheck.Arbitrary.int64 (* TODO: use ikind *) + 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 @@ -1713,10 +1620,11 @@ 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.Flat (Base) (struct + include Lattice.FlatConf (struct + include Printable.DefaultConf let top_name = "Unknown int" let bot_name = "Error int" - end) + end) (Base) let top_of ik = top () let bot_of ik = bot () @@ -1792,10 +1700,11 @@ end module Lift (Base: IkindUnawareS) = (* identical to Flat, but does not go to `Top/Bot` if Base raises Unknown/Error *) struct - include Lattice.LiftPO (Base) (struct + include Lattice.LiftPO (struct + include Printable.DefaultConf let top_name = "MaxInt" let bot_name = "MinInt" - end) + end) (Base) type int_t = Base.int_t let top_of ik = top () let bot_of ik = bot () @@ -2402,8 +2311,8 @@ struct let excluded s = from_excl ik s in let definite x = of_int ik x in let shrink = function - | `Excluded (s, _) -> MyCheck.shrink (S.arbitrary ()) s >|= excluded (* S TODO: possibly shrink excluded to definite *) - | `Definite x -> (return `Bot) <+> (MyCheck.shrink (BigInt.arbitrary ()) x >|= definite) + | `Excluded (s, _) -> GobQCheck.shrink (S.arbitrary ()) s >|= excluded (* S TODO: possibly shrink excluded to definite *) + | `Definite x -> (return `Bot) <+> (GobQCheck.shrink (BigInt.arbitrary ()) x >|= definite) | `Bot -> empty in QCheck.frequency ~shrink ~print:show [ @@ -2816,8 +2725,8 @@ module Enums : S with type int_t = BigInt.t = struct let neg s = of_excl_list ik (BISet.elements s) in let pos s = norm ik (Inc s) in let shrink = function - | Exc (s, _) -> MyCheck.shrink (BISet.arbitrary ()) s >|= neg (* S TODO: possibly shrink neg to pos *) - | Inc s -> MyCheck.shrink (BISet.arbitrary ()) s >|= pos + | 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 ()); @@ -3307,7 +3216,7 @@ struct let arbitrary ik = let open QCheck in - let int_arb = map ~rev:Ints_t.to_int64 Ints_t.of_int64 MyCheck.Arbitrary.int64 in + let int_arb = map ~rev:Ints_t.to_int64 Ints_t.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 diff --git a/src/cdomains/intDomain.mli b/src/cdomain/value/cdomains/intDomain.mli similarity index 98% rename from src/cdomains/intDomain.mli rename to src/cdomain/value/cdomains/intDomain.mli index a853c8acca..4b14aeec72 100644 --- a/src/cdomains/intDomain.mli +++ b/src/cdomain/value/cdomains/intDomain.mli @@ -308,8 +308,6 @@ end module SOverflowUnlifter (D : SOverflow) : S with type int_t = D.int_t and type t = D.t -module OldDomainFacade (Old : IkindUnawareS with type int_t = int64) : S with type int_t = IntOps.BigIntOps.t and type t = Old.t -(** Facade for IntDomain implementations that do not implement the interface where arithmetic functions take an ikind parameter. *) module type Y = sig diff --git a/src/cdomains/jmpBufDomain.ml b/src/cdomain/value/cdomains/jmpBufDomain.ml similarity index 100% rename from src/cdomains/jmpBufDomain.ml rename to src/cdomain/value/cdomains/jmpBufDomain.ml diff --git a/src/cdomains/lval.ml b/src/cdomain/value/cdomains/lval.ml similarity index 100% rename from src/cdomains/lval.ml rename to src/cdomain/value/cdomains/lval.ml diff --git a/src/cdomains/mutexAttrDomain.ml b/src/cdomain/value/cdomains/mutexAttrDomain.ml similarity index 91% rename from src/cdomains/mutexAttrDomain.ml rename to src/cdomain/value/cdomains/mutexAttrDomain.ml index 748ede0ff5..ea9696d26f 100644 --- a/src/cdomains/mutexAttrDomain.ml +++ b/src/cdomain/value/cdomains/mutexAttrDomain.ml @@ -18,7 +18,7 @@ struct end) end -include Lattice.Flat(MutexKind) (struct let bot_name = "Uninitialized" let top_name = "Top" end) +include Lattice.FlatConf (struct include Printable.DefaultConf let bot_name = "Uninitialized" let top_name = "Top" end) (MutexKind) (* Needed because OS X is weird and assigns different constants than normal systems... :( *) let recursive_int = lazy ( diff --git a/src/cdomains/mval.ml b/src/cdomain/value/cdomains/mval.ml similarity index 100% rename from src/cdomains/mval.ml rename to src/cdomain/value/cdomains/mval.ml diff --git a/src/cdomains/mval.mli b/src/cdomain/value/cdomains/mval.mli similarity index 100% rename from src/cdomains/mval.mli rename to src/cdomain/value/cdomains/mval.mli diff --git a/src/cdomains/mval_intf.ml b/src/cdomain/value/cdomains/mval_intf.ml similarity index 100% rename from src/cdomains/mval_intf.ml rename to src/cdomain/value/cdomains/mval_intf.ml diff --git a/src/cdomain/value/cdomains/nullByteSet.ml b/src/cdomain/value/cdomains/nullByteSet.ml new file mode 100644 index 0000000000..ff5d0270e0 --- /dev/null +++ b/src/cdomain/value/cdomains/nullByteSet.ml @@ -0,0 +1,202 @@ +(** Abstract domains for tracking [NULL] bytes in C arrays. *) + +module MustSet = struct + module M = SetDomain.Reverse (SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All Null" end)) + include M + + let compute_set len = + List.init (Z.to_int len) Z.of_int + |> of_list + + let remove i must_nulls_set min_size = + if M.is_bot must_nulls_set then + M.remove i (compute_set min_size) + else + M.remove i must_nulls_set + + let filter ?min_size cond must_nulls_set = + if M.is_bot must_nulls_set then + match min_size with + | Some min_size -> M.filter cond (compute_set min_size) + | _ -> M.empty () + else + M.filter cond must_nulls_set + + let min_elt must_nulls_set = + if M.is_bot must_nulls_set then + Z.zero + else + M.min_elt must_nulls_set + + let interval_mem (l,u) set = + if M.is_bot set then + true + else if Z.lt (Z.of_int (M.cardinal set)) (Z.sub u l) then + false + else + let rec check_all_indexes i = + if Z.gt i u then + true + else if M.mem i set then + check_all_indexes (Z.succ i) + else + false in + check_all_indexes l +end + +module MaySet = struct + module M = SetDomain.ToppedSet (IntDomain.BigInt) (struct let topname = "All Null" end) + include M + + let elements ?max_size may_nulls_set = + if M.is_top may_nulls_set then + match max_size with + | Some max_size -> M.elements @@ MustSet.compute_set max_size + | _ -> failwith "top and no max size supplied" + else + M.elements may_nulls_set + + let remove i may_nulls_set max_size = + if M.is_top may_nulls_set then + M.remove i (MustSet.compute_set max_size) + else + M.remove i may_nulls_set + + let filter ?max_size cond may_nulls_set = + if M.is_top may_nulls_set then + match max_size with + | Some max_size -> M.filter cond (MustSet.compute_set max_size) + | _ -> may_nulls_set + else + M.filter cond may_nulls_set + + let min_elt may_nulls_set = + if M.is_top may_nulls_set then + Z.zero + else + M.min_elt may_nulls_set +end + +module MustMaySet = struct + include Lattice.Prod (MustSet) (MaySet) + + module Set = SetDomain.Make (IntDomain.BigInt) + + type mode = Definitely | Possibly + + let empty () = (MustSet.top (), MaySet.bot ()) + + let full_set () = (MustSet.bot (), MaySet.top ()) + + let is_empty mode (musts, mays) = + match mode with + | Definitely -> MaySet.is_empty mays + | Possibly -> MustSet.is_empty musts + + let min_elem mode (musts, mays) = + match mode with + | Definitely -> MustSet.min_elt musts + | Possibly -> MaySet.min_elt mays + + let min_elem_precise x = + Z.equal (min_elem Definitely x) (min_elem Possibly x) + + let mem mode i (musts, mays) = + match mode with + | Definitely -> MustSet.mem i musts + | Possibly -> MaySet.mem i mays + + let interval_mem mode (l,u) (musts, mays) = + match mode with + | Definitely -> MustSet.interval_mem (l,u) musts + | Possibly -> failwith "not implemented" + + let remove mode i (musts, mays) min_size = + match mode with + | Definitely -> (MustSet.remove i musts min_size, MaySet.remove i mays min_size) + | Possibly -> (MustSet.remove i musts min_size, mays) + + let add mode i (musts, mays) = + match mode with + | Definitely -> (MustSet.add i musts, MaySet.add i mays) + | Possibly -> (musts, MaySet.add i mays) + + let add_list mode l (musts, mays) = + match mode with + | Definitely -> failwith "todo" + | Possibly -> (musts, MaySet.union (MaySet.of_list l) mays) + + let add_interval ?maxfull mode (l,u) (musts, mays) = + let rec add_indexes i max set = + if Z.gt i max then + set + else + add_indexes (Z.succ i) max (MaySet.add i set) + in + let mays = + match maxfull with + | Some Some maxfull when Z.equal l Z.zero && Z.geq u maxfull -> + MaySet.top () + | _ -> + add_indexes l u mays + in + match mode with + | Definitely -> (add_indexes l u musts, mays) + | Possibly -> (musts, mays) + + let remove_interval mode (l,u) min_size (musts, mays) = + match mode with + | Definitely -> failwith "todo" + | Possibly -> + if Z.equal l Z.zero && Z.geq u min_size then + (MustSet.top (), mays) + else + (MustSet.filter ~min_size (fun x -> (Z.lt x l || Z.gt x u) && Z.lt x min_size) musts, mays) + + let add_all mode (musts, mays) = + match mode with + | Definitely -> failwith "todo" + | Possibly -> (musts, MaySet.top ()) + + let remove_all mode (musts, mays) = + match mode with + | Possibly -> (MustSet.top (), mays) + | Definitely -> empty () + + let is_full_set mode (musts, mays) = + match mode with + | Definitely -> MustSet.is_bot musts + | Possibly -> MaySet.is_top mays + + let get_set mode (musts, mays) = + match mode with + | Definitely -> musts + | Possibly -> mays + + let elements ?max_size ?min_size mode (musts, mays) = + match mode with + | Definitely ->failwith "todo" + | Possibly -> MaySet.elements ?max_size mays + + let union_mays (must,mays) (_,mays2) = (must, MaySet.join mays mays2) + + + let precise_singleton i = + (MustSet.singleton i, MaySet.singleton i) + + let precise_set (s:Set.t):t = (`Lifted s,`Lifted s) + + let make_all_must () = (MustSet.bot (), MaySet.top ()) + + let may_can_benefit_from_filter (musts, mays) = not (MaySet.is_top mays) + + let exists mode f (musts, mays) = + match mode with + | Definitely -> MustSet.exists f musts + | Possibly -> MaySet.exists f mays + + let filter ?min_size ?max_size f (must, mays):t = + (MustSet.filter ?min_size f must, MaySet.filter ?max_size f mays) + + let filter_musts f min_size (musts, mays) = (MustSet.filter ~min_size f musts, mays) +end diff --git a/src/cdomains/offset.ml b/src/cdomain/value/cdomains/offset.ml similarity index 95% rename from src/cdomains/offset.ml rename to src/cdomain/value/cdomains/offset.ml index eca85e08a4..62bab39eb7 100644 --- a/src/cdomains/offset.ml +++ b/src/cdomain/value/cdomains/offset.ml @@ -22,7 +22,7 @@ struct include CilType.Exp let name () = "exp index" - let any = CastE (TInt (Cilfacade.ptrdiff_ikind (), []), mkString "any_index") + let any = Cilfacade.any_index_exp let all = CastE (TInt (Cilfacade.ptrdiff_ikind (), []), mkString "all_index") (* Override output *) @@ -142,15 +142,11 @@ struct | TPtr (t,_), `Index (i,o) -> type_of ~base:t o | TComp (ci,_), `Field (f,o) -> let fi = try getCompField ci f.fname - with Not_found -> - let s = GobPretty.sprintf "Addr.type_offset: field %s not found in type %a" f.fname d_plaintype t in - raise (Type_of_error (t, s)) + with Not_found -> raise (Type_of_error (t, show o)) in type_of ~base:fi.ftype o (* TODO: Why? Imprecise on zstd-thread-pool regression tests. *) (* | TComp _, `Index (_,o) -> type_of ~base:t o (* this happens (hmmer, perlbench). safe? *) *) - | t,o -> - let s = GobPretty.sprintf "Addr.type_offset: could not follow offset in type. type: %a, offset: %a" d_plaintype t pretty o in - raise (Type_of_error (t, s)) + | t, o -> raise (Type_of_error (t, show o)) let rec prefix (x: t) (y: t): t option = match x,y with | `Index (x, xs), `Index (y, ys) when Idx.equal x y -> prefix xs ys @@ -261,3 +257,9 @@ struct | `Index (i,o) -> Index (i, to_cil o) | `Field (f,o) -> Field (f, to_cil o) end + + +let () = Printexc.register_printer (function + | Type_of_error (t, o) -> Some (GobPretty.sprintf "Offset.Type_of_error(%a, %s)" d_plaintype t o) + | _ -> None (* for other exceptions *) + ) diff --git a/src/cdomains/offset.mli b/src/cdomain/value/cdomains/offset.mli similarity index 100% rename from src/cdomains/offset.mli rename to src/cdomain/value/cdomains/offset.mli diff --git a/src/cdomains/offset_intf.ml b/src/cdomain/value/cdomains/offset_intf.ml similarity index 100% rename from src/cdomains/offset_intf.ml rename to src/cdomain/value/cdomains/offset_intf.ml diff --git a/src/cdomains/preValueDomain.ml b/src/cdomain/value/cdomains/preValueDomain.ml similarity index 100% rename from src/cdomains/preValueDomain.ml rename to src/cdomain/value/cdomains/preValueDomain.ml diff --git a/src/cdomains/stringDomain.ml b/src/cdomain/value/cdomains/stringDomain.ml similarity index 100% rename from src/cdomains/stringDomain.ml rename to src/cdomain/value/cdomains/stringDomain.ml diff --git a/src/cdomains/stringDomain.mli b/src/cdomain/value/cdomains/stringDomain.mli similarity index 100% rename from src/cdomains/stringDomain.mli rename to src/cdomain/value/cdomains/stringDomain.mli diff --git a/src/cdomains/structDomain.ml b/src/cdomain/value/cdomains/structDomain.ml similarity index 100% rename from src/cdomains/structDomain.ml rename to src/cdomain/value/cdomains/structDomain.ml diff --git a/src/cdomains/structDomain.mli b/src/cdomain/value/cdomains/structDomain.mli similarity index 100% rename from src/cdomains/structDomain.mli rename to src/cdomain/value/cdomains/structDomain.mli diff --git a/src/cdomains/threadIdDomain.ml b/src/cdomain/value/cdomains/threadIdDomain.ml similarity index 79% rename from src/cdomains/threadIdDomain.ml rename to src/cdomain/value/cdomains/threadIdDomain.ml index a9646cffd2..85f9a0297b 100644 --- a/src/cdomains/threadIdDomain.ml +++ b/src/cdomain/value/cdomains/threadIdDomain.ml @@ -196,12 +196,14 @@ struct end module ThreadLiftNames = struct + include Printable.DefaultConf let bot_name = "Bot Threads" let top_name = "Top Threads" + let expand1 = false end module Lift (Thread: S) = struct - include Lattice.Flat (Thread) (ThreadLiftNames) + include Lattice.FlatConf (ThreadLiftNames) (Thread) let name () = "Thread" end @@ -217,7 +219,7 @@ struct let name = "FlagConfiguredTID" end) - module D = Lattice.Lift2(H.D)(P.D)(struct let bot_name = "bot" let top_name = "top" end) + module D = Lattice.Lift2 (H.D) (P.D) let history_enabled () = match GobConfig.get_string "ana.thread.domain" with @@ -280,6 +282,79 @@ struct let name () = "FlagConfiguredTID: " ^ if history_enabled () then H.name () else P.name () end -module Thread = FlagConfiguredTID +type thread = + | Thread of FlagConfiguredTID.t + | UnknownThread +[@@deriving eq, ord, hash] + +module Thread : Stateful with type t = thread = +struct + include Printable.Std + type t = thread [@@deriving eq, ord, hash] + + let name () = "Thread id" + let pretty () t = + match t with + | Thread tid -> FlagConfiguredTID.pretty () tid + | UnknownThread -> Pretty.text "Unknown thread id" + + let show t = + match t with + | Thread tid -> FlagConfiguredTID.show tid + | UnknownThread -> "Unknown thread id" + + let printXml f t = + match t with + | Thread tid -> FlagConfiguredTID.printXml f tid + | UnknownThread -> BatPrintf.fprintf f "\n\nUnknown thread id\n\n\n" + + let to_yojson t = + match t with + | Thread tid -> FlagConfiguredTID.to_yojson tid + | UnknownThread -> `String "Unknown thread id" + + let relift t = + match t with + | Thread tid -> Thread (FlagConfiguredTID.relift tid) + | UnknownThread -> UnknownThread + + let lift t = Thread t + + let threadinit v ~multiple = Thread (FlagConfiguredTID.threadinit v ~multiple) + + let is_main t = + match t with + | Thread tid -> FlagConfiguredTID.is_main tid + | UnknownThread -> false + + let is_unique t = + match t with + | Thread tid -> FlagConfiguredTID.is_unique tid + | UnknownThread -> false + + let may_create t1 t2 = + match t1, t2 with + | Thread tid1, Thread tid2 -> FlagConfiguredTID.may_create tid1 tid2 + | _, _ -> true + + let is_must_parent t1 t2 = + match t1, t2 with + | Thread tid1, Thread tid2 -> FlagConfiguredTID.is_must_parent tid1 tid2 + | _, _ -> false + + module D = FlagConfiguredTID.D + + let threadenter ~multiple (t, d) node i v = + match t with + | Thread tid -> List.map lift (FlagConfiguredTID.threadenter ~multiple (tid, d) node i v) + | UnknownThread -> assert false + + let threadspawn = FlagConfiguredTID.threadspawn + + let created t d = + match t with + | Thread tid -> Option.map (List.map lift) (FlagConfiguredTID.created tid d) + | UnknownThread -> None +end module ThreadLifted = Lift (Thread) diff --git a/src/cdomains/unionDomain.ml b/src/cdomain/value/cdomains/unionDomain.ml similarity index 93% rename from src/cdomains/unionDomain.ml rename to src/cdomain/value/cdomains/unionDomain.ml index ac25450c6a..ad5c531061 100644 --- a/src/cdomains/unionDomain.ml +++ b/src/cdomain/value/cdomains/unionDomain.ml @@ -16,10 +16,11 @@ sig end module Field = struct - include Lattice.Flat (CilType.Fieldinfo) (struct + include Lattice.FlatConf (struct + include Printable.DefaultConf let top_name = "Unknown field" let bot_name = "If you see this, you are special!" - end) + end) (CilType.Fieldinfo) let meet f g = if equal f g then diff --git a/src/cdomains/valueDomain.ml b/src/cdomain/value/cdomains/valueDomain.ml similarity index 95% rename from src/cdomains/valueDomain.ml rename to src/cdomain/value/cdomains/valueDomain.ml index cba4b04c18..d1b81dcb08 100644 --- a/src/cdomains/valueDomain.ml +++ b/src/cdomain/value/cdomains/valueDomain.ml @@ -19,11 +19,12 @@ sig include Lattice.S type offs val eval_offset: VDQ.t -> (AD.t -> t) -> t-> offs -> exp option -> lval option -> typ -> t - val update_offset: VDQ.t -> t -> offs -> t -> exp option -> lval -> typ -> t + val update_offset: ?blob_destructive:bool -> VDQ.t -> t -> offs -> t -> exp option -> lval -> typ -> t val update_array_lengths: (exp -> t) -> t -> Cil.typ -> t val affect_move: ?replace_with_const:bool -> VDQ.t -> t -> varinfo -> (exp -> int option) -> t val affecting_vars: t -> varinfo list val invalidate_value: VDQ.t -> typ -> t -> t + val invalidate_abstract_value: t -> t val is_safe_cast: typ -> typ -> bool val cast: ?torg:typ -> typ -> t -> t val smart_join: (exp -> BI.t option) -> (exp -> BI.t option) -> t -> t -> t @@ -38,6 +39,8 @@ sig val is_top_value: t -> typ -> bool val zero_init_value: ?varAttr:attributes -> typ -> t + include ArrayDomain.Null with type t := t + val project: VDQ.t -> int_precision option-> ( attributes * attributes ) option -> t -> t val mark_jmpbufs_as_copied: t -> t end @@ -49,6 +52,7 @@ sig type origin include Lattice.S with type t = value * size * origin + val map: (value -> value) -> t -> t val value: t -> value val invalidate_value: VDQ.t -> typ -> t -> t end @@ -68,6 +72,7 @@ struct type size = Size.t type origin = ZeroInit.t + let map f (v, s, o) = f v, s, o let value (a, b, c) = a let relift (a, b, c) = Value.relift a, b, c let invalidate_value ask t (v, s, o) = Value.invalidate_value ask t v, s, o @@ -250,7 +255,6 @@ struct let tag_name : t -> string = function | Top -> "Top" | Int _ -> "Int" | Float _ -> "Float" | Address _ -> "Address" | Struct _ -> "Struct" | Union _ -> "Union" | Array _ -> "Array" | Blob _ -> "Blob" | Thread _ -> "Thread" | Mutex -> "Mutex" | MutexAttr _ -> "MutexAttr" | JmpBuf _ -> "JmpBuf" | Bot -> "Bot" - include Printable.Std let name () = "compound" @@ -264,6 +268,22 @@ struct let is_top x = x = Top let top_name = "Unknown" + let null () = Int (ID.of_int IChar Z.zero) + + type retnull = Null | NotNull | Maybe + let is_null = function + | Int n when GobOption.exists (Z.equal Z.zero) (ID.to_int n) -> Null + | Int n -> + let zero_ik = ID.of_int (ID.ikind n) Z.zero in + if ID.to_bool (ID.ne n zero_ik) = Some true then NotNull else Maybe + | _ -> Maybe + + let get_ikind = function + | Int n -> Some (ID.ikind n) + | _ -> None + let zero_of_ikind ik = Int(ID.of_int ik Z.zero) + let not_zero_of_ikind ik = Int(ID.of_excl_list ik [Z.zero]) + let pretty () state = match state with | Int n -> ID.pretty () n @@ -502,7 +522,7 @@ struct let warn_type op x y = if GobConfig.get_bool "dbg.verbose" then - ignore @@ printf "warn_type %s: incomparable abstr. values %s and %s at %a: %a and %a\n" op (tag_name (x:t)) (tag_name (y:t)) CilType.Location.pretty !Tracing.current_loc pretty x pretty y + ignore @@ printf "warn_type %s: incomparable abstr. values %s and %s at %a: %a and %a\n" op (tag_name (x:t)) (tag_name (y:t)) CilType.Location.pretty !Goblint_tracing.current_loc pretty x pretty y let rec leq x y = match (x,y) with @@ -552,11 +572,9 @@ struct | y, Blob (x,s,o) -> Blob (join (x:t) y, s, o) | (Thread x, Thread y) -> Thread (Threads.join x y) | (Int x, Thread y) - | (Thread y, Int x) -> - Thread y (* TODO: ignores int! *) + | (Thread y, Int x) -> Thread (Threads.join y (Threads.top ())) | (Address x, Thread y) - | (Thread y, Address x) -> - Thread y (* TODO: ignores address! *) + | (Thread y, Address x) -> Thread (Threads.join y (Threads.top ())) | (JmpBuf x, JmpBuf y) -> JmpBuf (JmpBufs.join x y) | (Mutex, Mutex) -> Mutex | (MutexAttr x, MutexAttr y) -> MutexAttr (MutexAttr.join x y) @@ -585,11 +603,9 @@ struct | (Blob x, Blob y) -> Blob (Blobs.widen x y) (* TODO: why no blob special cases like in join? *) | (Thread x, Thread y) -> Thread (Threads.widen x y) | (Int x, Thread y) - | (Thread y, Int x) -> - Thread y (* TODO: ignores int! *) + | (Thread y, Int x) -> Thread (Threads.widen y (Threads.join y (Threads.top ()))) | (Address x, Thread y) - | (Thread y, Address x) -> - Thread y (* TODO: ignores address! *) + | (Thread y, Address x) -> Thread (Threads.widen y (Threads.join y (Threads.top ()))) | (Mutex, Mutex) -> Mutex | (JmpBuf x, JmpBuf y) -> JmpBuf (JmpBufs.widen x y) | (MutexAttr x, MutexAttr y) -> MutexAttr (MutexAttr.widen x y) @@ -708,11 +724,27 @@ struct let v = invalidate_value ask voidType (CArrays.get ask n (array_idx_top)) in Array (CArrays.set ask n (array_idx_top) v) | t , Blob n -> Blob (Blobs.invalidate_value ask t n) - | _ , Thread _ -> state (* TODO: no top thread ID set! *) + | _ , Thread tid -> Thread (Threads.join (Threads.top ()) tid) | _ , JmpBuf _ -> state (* TODO: no top jmpbuf *) | _, Bot -> Bot (* Leave uninitialized value (from malloc) alone in free to avoid trashing everything. TODO: sound? *) | t , _ -> top_value t + (* TODO: why is this separately needed? *) + let rec invalidate_abstract_value = function + | Top -> Top + | Int i -> Int (ID.top_of (ID.ikind i)) + | Float f -> Float (FD.top_of (FD.get_fkind f)) + | Address _ -> Address (AD.top_ptr) + | Struct s -> Struct (Structs.map invalidate_abstract_value s) + | Union u -> Union (Unions.top ()) (* More precise invalidate does not make sense, as it is not clear which component is accessed. *) + | Array a -> Array (CArrays.map invalidate_abstract_value a) + | Blob b -> Blob (Blobs.map invalidate_abstract_value b) + | Thread _ -> Thread (Threads.top ()) + | JmpBuf _ -> JmpBuf (JmpBufs.top ()) + | Mutex -> Mutex + | MutexAttr _ -> MutexAttr (MutexAttrDomain.top ()) + | Bot -> Bot + (* take the last offset in offset and move it over to left *) let shift_one_over left offset = @@ -898,7 +930,7 @@ struct in do_eval_offset ask f x offs exp l o v t - let update_offset (ask: VDQ.t) (x:t) (offs:offs) (value:t) (exp:exp option) (v:lval) (t:typ): t = + let update_offset ?(blob_destructive=false) (ask: VDQ.t) (x:t) (offs:offs) (value:t) (exp:exp option) (v:lval) (t:typ): t = let rec do_update_offset (ask:VDQ.t) (x:t) (offs:offs) (value:t) (exp:exp option) (l:lval option) (o:offset option) (v:lval) (t:typ):t = if M.tracing then M.traceli "update_offset" "do_update_offset %a %a (%a) %a\n" pretty x Offs.pretty offs (Pretty.docOpt (CilType.Exp.pretty ())) exp pretty value; let mu = function Blob (Blob (y, s', orig), s, orig2) -> Blob (y, ID.join s s',orig) | x -> x in @@ -946,9 +978,11 @@ struct | (Var var, _) -> let blob_size_opt = ID.to_int s in not @@ ask.is_multiple var - && not @@ Cil.isVoidType t (* Size of value is known *) && Option.is_some blob_size_opt (* Size of blob is known *) - && BI.equal (Option.get blob_size_opt) (BI.of_int @@ Cil.alignOf_int t) + && (( + not @@ Cil.isVoidType t (* Size of value is known *) + && BI.equal (Option.get blob_size_opt) (BI.of_int @@ Cil.alignOf_int t) + ) || blob_destructive) | _ -> false end in @@ -1234,7 +1268,7 @@ and Structs: StructDomain.S with type field = fieldinfo and type value = Compoun and Unions: UnionDomain.S with type t = UnionDomain.Field.t * Compound.t and type value = Compound.t = UnionDomain.Simple (Compound) -and CArrays: ArrayDomain.S with type value = Compound.t and type idx = ArrIdxDomain.t = ArrayDomain.AttributeConfiguredArrayDomain(Compound)(ArrIdxDomain) +and CArrays: ArrayDomain.StrWithDomain with type value = Compound.t and type idx = ArrIdxDomain.t = ArrayDomain.AttributeConfiguredAndNullByteArrayDomain(Compound)(ArrIdxDomain) and Blobs: Blob with type size = ID.t and type value = Compound.t and type origin = ZeroInit.t = Blob (Compound) (ID) diff --git a/src/domains/invariant.ml b/src/cdomain/value/domains/invariant.ml similarity index 94% rename from src/domains/invariant.ml rename to src/cdomain/value/domains/invariant.ml index 1a0c3c033c..b281e8f7b3 100644 --- a/src/domains/invariant.ml +++ b/src/cdomain/value/domains/invariant.ml @@ -28,11 +28,12 @@ end module N = struct + include Printable.DefaultConf let bot_name = "false" let top_name = "true" end -include Lattice.Lift (ExpLat) (N) +include Lattice.LiftConf (N) (ExpLat) let none = top () let of_exp = lift diff --git a/src/domains/invariantCil.ml b/src/cdomain/value/domains/invariantCil.ml similarity index 100% rename from src/domains/invariantCil.ml rename to src/cdomain/value/domains/invariantCil.ml diff --git a/src/domains/valueDomainQueries.ml b/src/cdomain/value/domains/valueDomainQueries.ml similarity index 97% rename from src/domains/valueDomainQueries.ml rename to src/cdomain/value/domains/valueDomainQueries.ml index 8266582ac2..bafec3f8bd 100644 --- a/src/domains/valueDomainQueries.ml +++ b/src/cdomain/value/domains/valueDomainQueries.ml @@ -9,7 +9,7 @@ module AD = PreValueDomain.AD module ID = struct module I = IntDomain.IntDomTuple - include Lattice.Lift (I) (Printable.DefaultNames) + include Lattice.Lift (I) let lift op x = `Lifted (op x) let unlift op x = match x with diff --git a/src/cdomain/value/dune b/src/cdomain/value/dune new file mode 100644 index 0000000000..c89d5be04d --- /dev/null +++ b/src/cdomain/value/dune @@ -0,0 +1,24 @@ +(include_subdirs unqualified) + +(library + (name goblint_cdomain_value) + (public_name goblint.cdomain.value) + (wrapped false) ; TODO: wrap + (libraries + batteries.unthreaded + goblint_std + goblint_common + goblint_config + goblint_library + goblint_domain + goblint_incremental + goblint-cil) + (flags :standard -open Goblint_std) + (preprocess + (pps + ppx_deriving.std + ppx_deriving_hash + ppx_deriving_yojson)) + (instrumentation (backend bisect_ppx))) + +(documentation) diff --git a/src/util/precisionUtil.ml b/src/cdomain/value/util/precisionUtil.ml similarity index 100% rename from src/util/precisionUtil.ml rename to src/cdomain/value/util/precisionUtil.ml diff --git a/src/util/wideningThresholds.ml b/src/cdomain/value/util/wideningThresholds.ml similarity index 100% rename from src/util/wideningThresholds.ml rename to src/cdomain/value/util/wideningThresholds.ml diff --git a/src/util/wideningThresholds.mli b/src/cdomain/value/util/wideningThresholds.mli similarity index 100% rename from src/util/wideningThresholds.mli rename to src/cdomain/value/util/wideningThresholds.mli diff --git a/src/cdomains/apron/affineEqualityDomain.apron.ml b/src/cdomains/apron/affineEqualityDomain.apron.ml index a6f00fdba0..5aa1090dd4 100644 --- a/src/cdomains/apron/affineEqualityDomain.apron.ml +++ b/src/cdomains/apron/affineEqualityDomain.apron.ml @@ -10,7 +10,7 @@ open Batteries open GoblintCil open Pretty module M = Messages -open Apron +open GobApron open VectorMatrix module Mpqf = struct @@ -26,14 +26,12 @@ module Mpqf = struct let hash x = 31 * (Z.hash (get_den x)) + Z.hash (get_num x) end -module Var = SharedFunctions.Var -module V = RelationDomain.V(Var) +module V = RelationDomain.V (** It defines the type t of the affine equality domain (a struct that contains an optional matrix and an apron environment) and provides the functions needed for handling variables (which are defined by RelationDomain.D2) such as add_vars remove_vars. Furthermore, it provides the function get_coeff_vec that parses an apron expression into a vector of coefficients if the apron expression has an affine form. *) module VarManagement (Vec: AbstractVector) (Mx: AbstractMatrix)= struct - include SharedFunctions.EnvOps module Vector = Vec (Mpqf) module Matrix = Mx(Mpqf) (Vec) @@ -78,16 +76,18 @@ struct let change_d t new_env add del = timing_wrap "dimension change" (change_d t new_env add) del + let vars x = Environment.ivars_only x.env + let add_vars t vars = let t = copy t in - let env' = add_vars t.env vars in + let env' = Environment.add_vars t.env vars in change_d t env' true false let add_vars t vars = timing_wrap "add_vars" (add_vars t) vars let drop_vars t vars del = let t = copy t in - let env' = remove_vars t.env vars in + let env' = Environment.remove_vars t.env vars in change_d t env' false del let drop_vars t vars = timing_wrap "drop_vars" (drop_vars t) vars @@ -102,7 +102,7 @@ struct t.env <- t'.env let remove_filter t f = - let env' = remove_filter t.env f in + let env' = Environment.remove_filter t.env f in change_d t env' false false let remove_filter t f = timing_wrap "remove_filter" (remove_filter t) f @@ -114,19 +114,18 @@ struct let keep_filter t f = let t = copy t in - let env' = keep_filter t.env f in + let env' = Environment.keep_filter t.env f in change_d t env' false false let keep_filter t f = timing_wrap "keep_filter" (keep_filter t) f let keep_vars t vs = let t = copy t in - let env' = keep_vars t.env vs in + let env' = Environment.keep_vars t.env vs in change_d t env' false false let keep_vars t vs = timing_wrap "keep_vars" (keep_vars t) vs - let vars t = vars t.env let mem_var t var = Environment.mem_var t.env var @@ -462,6 +461,7 @@ struct let assign_exp (t: VarManagement(Vc)(Mx).t) var exp (no_ov: bool Lazy.t) = let t = if not @@ Environment.mem_var t.env var then add_vars t [var] else t in + (* TODO: Do we need to do a constant folding here? It happens for texpr1_of_cil_exp *) match Convert.texpr1_expr_of_cil_exp t t.env exp (Lazy.force no_ov) with | exp -> assign_texpr t var exp | exception Convert.Unsupported_CilExp _ -> diff --git a/src/cdomains/apron/apronDomain.apron.ml b/src/cdomains/apron/apronDomain.apron.ml index 7dffafe967..03b9558621 100644 --- a/src/cdomains/apron/apronDomain.apron.ml +++ b/src/cdomains/apron/apronDomain.apron.ml @@ -4,7 +4,7 @@ open Batteries open GoblintCil open Pretty (* A binding to a selection of Apron-Domains *) -open Apron +open GobApron open RelationDomain open SharedFunctions @@ -29,8 +29,7 @@ let widening_thresholds_apron = ResettableLazy.from_fun (fun () -> let reset_lazy () = ResettableLazy.reset widening_thresholds_apron -module Var = SharedFunctions.Var -module V = RelationDomain.V(Var) +module V = RelationDomain.V module type Manager = @@ -209,7 +208,6 @@ module type AOpsExtra = sig type t val copy : t -> t - val vars_as_array : t -> Var.t array val vars : t -> Var.t list type marshal val unmarshal : marshal -> t @@ -248,15 +246,6 @@ struct let copy = A.copy Man.mgr - let vars_as_array d = - let ivs, fvs = Environment.vars (A.env d) in - assert (Array.length fvs = 0); (* shouldn't ever contain floats *) - ivs - - let vars d = - let ivs = vars_as_array d in - List.of_enum (Array.enum ivs) - (* marshal type: Abstract0.t and an array of var names *) type marshal = Man.mt Abstract0.t * string array @@ -266,31 +255,24 @@ struct let env = Environment.make vars [||] in {abstract0; env} + let vars x = Environment.ivars_only @@ A.env x + let marshal (x: t): marshal = - let vars = Array.map Var.to_string (vars_as_array x) in + let vars = Array.map Var.to_string (Array.of_list (vars x)) in x.abstract0, vars let mem_var d v = Environment.mem_var (A.env d) v - let add_vars_with nd vs = - let env' = EnvOps.add_vars (A.env nd) vs in + let envop f nd a = + let env' = f (A.env nd) a in A.change_environment_with Man.mgr nd env' false - let remove_vars_with nd vs = - let env' = EnvOps.remove_vars (A.env nd) vs in - A.change_environment_with Man.mgr nd env' false + let add_vars_with = envop Environment.add_vars + let remove_vars_with = envop Environment.remove_vars + let remove_filter_with = envop Environment.remove_filter + let keep_vars_with = envop Environment.keep_vars + let keep_filter_with = envop Environment.keep_filter - let remove_filter_with nd f = - let env' = EnvOps.remove_filter (A.env nd) f in - A.change_environment_with Man.mgr nd env' false - - let keep_vars_with nd vs = - let env' = EnvOps.keep_vars (A.env nd) vs in - A.change_environment_with Man.mgr nd env' false - - let keep_filter_with nd f = - let env' = EnvOps.keep_filter (A.env nd) f in - A.change_environment_with Man.mgr nd env' false let forget_vars_with nd vs = (* Unlike keep_vars_with, this doesn't check mem_var, but assumes valid vars, like assigns *) @@ -497,9 +479,9 @@ struct let to_yojson (x: t) = let constraints = A.to_lincons_array Man.mgr x - |> SharedFunctions.Lincons1Set.of_earray - |> SharedFunctions.Lincons1Set.elements - |> List.map (fun lincons1 -> `String (SharedFunctions.Lincons1.show lincons1)) + |> Lincons1Set.of_earray + |> Lincons1Set.elements + |> List.map (fun lincons1 -> `String (Lincons1.show lincons1)) in let env = `String (Format.asprintf "%a" (Environment.print: Format.formatter -> Environment.t -> unit) (A.env x)) in @@ -886,7 +868,6 @@ struct let unmarshal (b, d) = (BoxD.unmarshal b, D.unmarshal d) let mem_var (_, d) v = D.mem_var d v - let vars_as_array (_, d) = D.vars_as_array d let vars (_, d) = D.vars d let pretty_diff () ((_, d1), (_, d2)) = D.pretty_diff () (d1, d2) diff --git a/src/cdomains/apron/gobApron.apron.ml b/src/cdomains/apron/gobApron.apron.ml new file mode 100644 index 0000000000..c39a3e42db --- /dev/null +++ b/src/cdomains/apron/gobApron.apron.ml @@ -0,0 +1,98 @@ +open Batteries +include Apron + +module Var = +struct + include Var + let equal x y = Var.compare x y = 0 +end + +module Lincons1 = +struct + include Lincons1 + + let show = Format.asprintf "%a" print + let compare x y = String.compare (show x) (show y) (* HACK *) + + let num_vars x = + (* Apron.Linexpr0.get_size returns some internal nonsense, so we count ourselves. *) + let size = ref 0 in + Lincons1.iter (fun coeff var -> + if not (Apron.Coeff.is_zero coeff) then + incr size + ) x; + !size +end + +module Lincons1Set = +struct + include Set.Make (Lincons1) + + let of_earray ({lincons0_array; array_env}: Lincons1.earray): t = + Array.enum lincons0_array + |> Enum.map (fun (lincons0: Lincons0.t) -> + Lincons1.{lincons0; env = array_env} + ) + |> of_enum +end + +(** A few code elements for environment changes from functions as remove_vars etc. have been moved to sharedFunctions as they are needed in a similar way inside affineEqualityDomain. + A module that includes various methods used by variable handling operations such as add_vars, remove_vars etc. in apronDomain and affineEqualityDomain. *) +module Environment = +struct + include Environment + + let ivars_only env = + let ivs, fvs = Environment.vars env in + assert (Array.length fvs = 0); (* shouldn't ever contain floats *) + List.of_enum (Array.enum ivs) + + let add_vars env vs = + let vs' = + vs + |> List.enum + |> Enum.filter (fun v -> not (Environment.mem_var env v)) + |> Array.of_enum + in + Environment.add env vs' [||] + + let remove_vars env vs = + let vs' = + vs + |> List.enum + |> Enum.filter (fun v -> Environment.mem_var env v) + |> Array.of_enum + in + Environment.remove env vs' + + let remove_filter env f = + let vs' = + ivars_only env + |> List.enum + |> Enum.filter f + |> Array.of_enum + in + Environment.remove env vs' + + let keep_vars env vs = + (* Instead of iterating over all vars in env and doing a linear lookup in vs just to remove them, + make a new env with just the desired vs. *) + let vs' = + vs + |> List.enum + |> Enum.filter (fun v -> Environment.mem_var env v) + |> Array.of_enum + in + Environment.make vs' [||] + + let keep_filter env f = + (* Instead of removing undesired vars, + make a new env with just the desired vars. *) + let vs' = + ivars_only env + |> List.enum + |> Enum.filter f + |> Array.of_enum + in + Environment.make vs' [||] +end diff --git a/src/cdomains/apron/gobApron.no-apron.ml b/src/cdomains/apron/gobApron.no-apron.ml new file mode 100644 index 0000000000..e69de29bb2 diff --git a/src/cdomains/apron/relationDomain.apron.ml b/src/cdomains/apron/relationDomain.apron.ml index c5b6a0a89b..48720b0382 100644 --- a/src/cdomains/apron/relationDomain.apron.ml +++ b/src/cdomains/apron/relationDomain.apron.ml @@ -2,42 +2,16 @@ See {!ApronDomain} and {!AffineEqualityDomain}. *) +open GobApron open Batteries open GoblintCil -(** Abstracts the extended apron Var. *) -module type Var = -sig - type t - val compare : t -> t -> int - val of_string : string -> t - val to_string : t -> string - val hash : t -> int - val equal : t -> t -> bool -end - module type VarMetadata = sig type t val var_name: t -> string end -module VarMetadataTbl (VM: VarMetadata) (Var: Var) = -struct - module VH = Hashtbl.Make (Var) - - let vh = VH.create 113 - - let make_var ?name metadata = - let name = Option.default_delayed (fun () -> VM.var_name metadata) name in - let var = Var.of_string name in - VH.replace vh var metadata; - var - - let find_metadata (var: Var.t) = - VH.find_option vh var -end - module VM = struct type t = @@ -55,10 +29,26 @@ struct | Global g -> g.vname end +module VarMetadataTbl (VM: VarMetadata) = +struct + module VH = Hashtbl.Make (Var) + + let vh = VH.create 113 + + let make_var ?name metadata = + let name = Option.default_delayed (fun () -> VM.var_name metadata) name in + let var = Var.of_string name in + VH.replace vh var metadata; + var + + let find_metadata (var: Var.t) = + VH.find_option vh var +end + module type RV = sig - type t - type vartable + type t = Var.t + type vartable = VM.t VarMetadataTbl (VM).VH.t val vh: vartable val make_var: ?name:string -> VM.t -> t @@ -70,12 +60,13 @@ sig val to_cil_varinfo: t -> varinfo Option.t end -module V (Var: Var): (RV with type t = Var.t and type vartable = VM.t VarMetadataTbl (VM) (Var).VH.t) = +module V: RV = struct + open VM + type t = Var.t - module VMT = VarMetadataTbl (VM) (Var) + module VMT = VarMetadataTbl (VM) include VMT - open VM type vartable = VM.t VMT.VH.t @@ -90,12 +81,6 @@ struct | _ -> None end -module type LinCons = -sig - type t - val num_vars: t -> int -end - module type Tracked = sig val type_tracked: typ -> bool @@ -105,7 +90,7 @@ end module type S2 = sig type t - type var + type var = Var.t type marshal module Tracked: Tracked @@ -144,8 +129,8 @@ module type S3 = sig include S2 - val cil_exp_of_lincons1: Apron.Lincons1.t -> exp option - val invariant: t -> Apron.Lincons1.t list + val cil_exp_of_lincons1: Lincons1.t -> exp option + val invariant: t -> Lincons1.t list end type ('a, 'b) relcomponents_t = { @@ -184,10 +169,9 @@ struct let name () = RD.name () ^ " * " ^ PrivD.name () - let of_tuple(rel, priv):t = {rel; priv} - let to_tuple r = (r.rel, r.priv) - let arbitrary () = + let to_tuple r = (r.rel, r.priv) in + let of_tuple (rel, priv) = {rel; priv} in let tr = QCheck.pair (RD.arbitrary ()) (PrivD.arbitrary ()) in QCheck.map ~rev:to_tuple of_tuple tr @@ -216,7 +200,6 @@ end module type RD = sig - module Var : Var - module V : module type of struct include V(Var) end - include S3 with type var = Var.t + module V : RV + include S3 end diff --git a/src/cdomains/apron/sharedFunctions.apron.ml b/src/cdomains/apron/sharedFunctions.apron.ml index 059a7f8264..e66be00ae4 100644 --- a/src/cdomains/apron/sharedFunctions.apron.ml +++ b/src/cdomains/apron/sharedFunctions.apron.ml @@ -8,42 +8,6 @@ module M = Messages module BI = IntOps.BigIntOps -module Var = -struct - include Var - - let equal x y = Var.compare x y = 0 -end - -module Lincons1 = -struct - include Lincons1 - - let show = Format.asprintf "%a" print - let compare x y = String.compare (show x) (show y) (* HACK *) - - let num_vars x = - (* Apron.Linexpr0.get_size returns some internal nonsense, so we count ourselves. *) - let size = ref 0 in - Lincons1.iter (fun coeff var -> - if not (Apron.Coeff.is_zero coeff) then - incr size - ) x; - !size -end - -module Lincons1Set = -struct - include Set.Make (Lincons1) - - let of_earray ({lincons0_array; array_env}: Lincons1.earray): t = - Array.enum lincons0_array - |> Enum.map (fun (lincons0: Lincons0.t) -> - Lincons1.{lincons0; env = array_env} - ) - |> of_enum -end - let int_of_scalar ?round (scalar: Scalar.t) = if Scalar.is_infty scalar <> 0 then (* infinity means unbounded *) None @@ -291,66 +255,6 @@ struct include CilOfApron (V) end -(** A few code elements for environment changes from functions as remove_vars etc. have been moved to sharedFunctions as they are needed in a similar way inside affineEqualityDomain. - A module that includes various methods used by variable handling operations such as add_vars, remove_vars etc. in apronDomain and affineEqualityDomain. *) -module EnvOps = -struct - let vars env = - let ivs, fvs = Environment.vars env in - assert (Array.length fvs = 0); (* shouldn't ever contain floats *) - List.of_enum (Array.enum ivs) - - let add_vars env vs = - let vs' = - vs - |> List.enum - |> Enum.filter (fun v -> not (Environment.mem_var env v)) - |> Array.of_enum - in - Environment.add env vs' [||] - - let remove_vars env vs = - let vs' = - vs - |> List.enum - |> Enum.filter (fun v -> Environment.mem_var env v) - |> Array.of_enum - in - Environment.remove env vs' - - let remove_filter env f = - let vs' = - vars env - |> List.enum - |> Enum.filter f - |> Array.of_enum - in - Environment.remove env vs' - - let keep_vars env vs = - (* Instead of iterating over all vars in env and doing a linear lookup in vs just to remove them, - make a new env with just the desired vs. *) - let vs' = - vs - |> List.enum - |> Enum.filter (fun v -> Environment.mem_var env v) - |> Array.of_enum - in - Environment.make vs' [||] - - let keep_filter env f = - (* Instead of removing undesired vars, - make a new env with just the desired vars. *) - let vs' = - vars env - |> List.enum - |> Enum.filter f - |> Array.of_enum - in - Environment.make vs' [||] - -end - (** A more specific module type for RelationDomain.RelD2 with ConvBounds integrated and various apron elements. It is designed to be the interface for the D2 modules in affineEqualityDomain and apronDomain and serves as a functor argument for AssertionModule. *) module type AssertionRelS = diff --git a/src/cdomains/fileDomain.ml b/src/cdomains/fileDomain.ml deleted file mode 100644 index ca585b8bce..0000000000 --- a/src/cdomains/fileDomain.ml +++ /dev/null @@ -1,81 +0,0 @@ -(** Domains for file handles. *) - -open Batteries - -module D = MvalMapDomain - - -module Val = -struct - type mode = Read | Write [@@deriving eq, ord, hash] - type s = Open of string*mode | Closed | Error [@@deriving eq, ord, hash] - let name = "File handles" - let var_state = Closed - let string_of_mode = function Read -> "Read" | Write -> "Write" - let string_of_state = function - | Open(filename, m) -> "open("^filename^", "^string_of_mode m^")" - | Closed -> "closed" - | Error -> "error" - - (* properties of records (e.g. used by Dom.warn_each) *) - let opened s = s <> Closed && s <> Error - let closed s = s = Closed - let writable s = match s with Open((_,Write)) -> true | _ -> false -end - - -module Dom = -struct - include D.Domain (D.Value (Val)) - - (* returns a tuple (thunk, result) *) - let report_ ?(neg=false) k p msg m = - let f ?(may=false) msg = - let f () = warn ~may msg in - f, if may then `May true else `Must true in - let mf = (fun () -> ()), `Must false in - if mem k m then - let p = if neg then not % p else p in - let v = find' k m in - if V.must p v then f msg (* must *) - else if V.may p v then f ~may:true msg (* may *) - else mf (* none *) - else if neg then f msg else mf - - let report ?(neg=false) k p msg m = (fst (report_ ~neg k p msg m)) () (* evaluate thunk *) - - let reports k xs m = - let uncurry (neg, p, msg) = report_ ~neg:neg k p msg m in - let f result x = if snd (uncurry x) = result then Some (fst (uncurry x)) else None in - let must_true = BatList.filter_map (f (`Must true)) xs in - let may_true = BatList.filter_map (f (`May true)) xs in - (* output first must and first may *) - if must_true <> [] then (List.hd must_true) (); - if may_true <> [] then (List.hd may_true) () - - (* handling state *) - let opened r = V.state r |> Val.opened - let closed r = V.state r |> Val.closed - let writable r = V.state r |> Val.writable - - let fopen k loc filename mode m = - if is_unknown k m then m else - let mode = match String.lowercase_ascii mode with "r" -> Val.Read | _ -> Val.Write in - let v = V.make k loc (Val.Open(filename, mode)) in - add' k v m - let fclose k loc m = - if is_unknown k m then m else - let v = V.make k loc Val.Closed in - change k v m - let error k m = - if is_unknown k m then m else - let loc = if mem k m then find' k m |> V.split |> snd |> Set.choose |> V.loc else [] in - let v = V.make k loc Val.Error in - change k v m - let success k m = - if is_unknown k m then m else - match find_option k m with - | Some v when V.may (Val.opened%V.state) v && V.may (V.in_state Val.Error) v -> - change k (V.filter (Val.opened%V.state) v) m (* TODO what about must-set? *) - | _ -> m -end diff --git a/src/cdomains/mHP.ml b/src/cdomains/mHP.ml index 8037cfa21d..016a72a77e 100644 --- a/src/cdomains/mHP.ml +++ b/src/cdomains/mHP.ml @@ -4,7 +4,7 @@ include Printable.Std let name () = "mhp" -module TID = ThreadIdDomain.FlagConfiguredTID +module TID = ThreadIdDomain.Thread module Pretty = GoblintCil.Pretty type t = { diff --git a/src/cdomains/mvalMapDomain.ml b/src/cdomains/mvalMapDomain.ml deleted file mode 100644 index d0d2f8da85..0000000000 --- a/src/cdomains/mvalMapDomain.ml +++ /dev/null @@ -1,299 +0,0 @@ -(** Domains for {{!Mval} mvalue} maps. *) - -open Batteries -open GoblintCil - -module M = Messages - - -exception Unknown -exception Error - -(* signature for map entries *) -module type S = -sig - include Lattice.S - type k = Mval.Exp.t (* key *) - type s (* state is defined by Impl *) - type r (* record *) - - (* printing *) - val string_of: t -> string - val string_of_key: k -> string - val string_of_record: r -> string - - (* constructing *) - val make: k -> Node.t list -> s -> t - - (* manipulation *) - val map: (r -> r) -> t -> t - val filter: (r -> bool) -> t -> t - val union: t -> t -> t - val set_key: k -> t -> t - val set_state: s -> t -> t - val remove_state: s -> t -> t - - (* deconstructing *) - val split: t -> r Set.t * r Set.t - val map': (r -> 'a) -> t -> 'a Set.t * 'a Set.t - val filter': (r -> bool) -> t -> r Set.t * r Set.t - val length: t -> int * int - - (* predicates *) - val must: (r -> bool) -> t -> bool - val may: (r -> bool) -> t -> bool - (* properties of records *) - val key: r -> k - val loc: r -> Node.t list - val edit_loc: (Node.t list -> Node.t list) -> r -> r - val state: r -> s - val in_state: s -> r -> bool - - (* special variables *) - val get_record: t -> r option - (* val make_record: k -> location list -> s -> r *) - val make_var: k -> t - val from_tuple: r Set.t * r Set.t -> t - - (* aliasing *) - val is_alias: t -> bool - val get_alias: t -> k - val make_alias: k -> t -end - -module Value (Impl: sig - type s (* state *) [@@deriving eq, ord, hash] - val name: string - val var_state: s - val string_of_state: s -> string - end) : S with type s = Impl.s = -struct - type k = Mval.Exp.t [@@deriving eq, ord, hash] - type s = Impl.s [@@deriving eq, ord, hash] - module R = struct - include Printable.StdLeaf - type t = { key: k; loc: Node.t list; state: s } [@@deriving eq, ord, hash] - let name () = "MValMapDomainValue" - - let pretty () {key; loc; state} = - Pretty.dprintf "{key=%a; loc=%a; state=%s}" Mval.Exp.pretty key (Pretty.d_list ", " Node.pretty) loc (Impl.string_of_state state) - - include Printable.SimplePretty ( - struct - type nonrec t = t - let pretty = pretty - end - ) - end - type r = R.t - open R - (* TODO: use SetDomain.Reverse? *) - module Must' = SetDomain.ToppedSet (R) (struct let topname = "top" end) - module Must = Lattice.Reverse (Must') - module May = SetDomain.ToppedSet (R) (struct let topname = "top" end) - include Lattice.Prod (Must) (May) - let name () = Impl.name - - (* converts to polymorphic sets *) - let split (x,y) = try Must'.elements x |> Set.of_list, May.elements y |> Set.of_list with SetDomain.Unsupported _ -> Set.empty, Set.empty - - (* special variable used for indirection *) - let alias_var = Cilfacade.create_var @@ Cil.makeVarinfo false "@alias" Cil.voidType, `NoOffset - (* alias structure: x[0].key=alias_var, y[0].key=linked_var *) - let is_alias (x,y) = neg Must'.is_empty x && (Must'.choose x).key=alias_var - let get_alias (x,y) = (May.choose y).key - - (* Printing *) - let string_of_key k = Mval.Exp.show k - let string_of_loc xs = String.concat ", " (List.map (CilType.Location.show % Node.location) xs) - let string_of_record r = Impl.string_of_state r.state^" ("^string_of_loc r.loc^")" - let string_of (x,y) = - if is_alias (x,y) then - "alias for "^string_of_key @@ get_alias (x,y) - else - let x, y = split (x,y) in - let z = Set.diff y x in - "{ "^String.concat ", " (List.map string_of_record (Set.elements x))^" }, "^ - "{ "^String.concat ", " (List.map string_of_record (Set.elements z))^" }" - let show x = string_of x - include Printable.SimpleShow (struct - type nonrec t = t - let show = show - end) - (* constructing & manipulation *) - let make_record k l s = { key=k; loc=l; state=s } - let make k l s = let v = make_record k l s in Must'.singleton v, May.singleton v - let map f (x,y) = Must'.map f x, May.map f y - let filter p (x,y) = Must'.filter p x, May.filter p y (* retains top *) - let union (a,b) (c,d) = Must'.union a c, May.union b d - let set_key k v = map (fun x -> {x with key=k}) v (* changes key for all elements *) - let set_state s v = map (fun x -> {x with state=s}) v - let remove_state s v = filter (fun x -> x.state<>s) v - - (* deconstructing *) - let length = split %> Tuple2.mapn Set.cardinal - let map' f = split %> Tuple2.mapn (Set.map f) - let filter' f = split %> Tuple2.mapn (Set.filter f) - - (* predicates *) - let must p (x,y) = Must'.exists p x || May.for_all p y - let may p (x,y) = May.exists p y - - (* properties of records *) - let key r = r.key - let loc r = r.loc - let edit_loc f r = {r with loc=f r.loc} - let state r = r.state - let in_state s r = r.state = s - - (* special variables *) - let get_record (x,y) = if Must'.is_empty x then None else Some (Must'.choose x) - let make_var_record k = make_record k [] Impl.var_state - let make_var k = Must'.singleton (make_var_record k), May.singleton (make_var_record k) - let make_alias k = Must'.singleton (make_var_record alias_var), May.singleton (make_var_record k) - let from_tuple (x,y) = Set.to_list x |> Must'.of_list, Set.to_list y |> May.of_list -end - - -module Domain (V: S) = -struct - module K = Mval.Exp - module V = V - module MD = MapDomain.MapBot (Mval.Exp) (V) - include MD - - (* Map functions *) - (* find that resolves aliases *) - let find' k m = let v = find k m in if V.is_alias v then find (V.get_alias v) m else v - let find_option k m = if mem k m then Some(find' k m) else None - let get_alias k m = (* target: returns Some k' if k links to k' *) - if mem k m && V.is_alias (find k m) then Some (V.get_alias (find k m)) else None - let get_aliased k m = (* sources: get list of keys that link to k *) - (* iter (fun k' (x,y) -> if V.is_alias (x,y) then print_endline ("alias "^V.string_of_key k'^" -> "^V.string_of_key (Set.choose y).key)) m; *) - (* TODO V.get_alias v=k somehow leads to Out_of_memory... *) - filter (fun k' v -> V.is_alias v && V.string_of_key (V.get_alias v)=V.string_of_key k) m |> bindings |> List.map fst - let get_aliases k m = (* get list of all other keys that have the same pointee *) - match get_alias k m with - | Some k' -> [k] (* k links to k' *) - | None -> get_aliased k m (* k' that link to k *) - let alias a b m = (* link a to b *) - (* if b is already an alias, follow it... *) - let b' = get_alias b m |? b in - (* add an entry for key a, that points to b' *) - add a (V.make_alias b') m - let remove' k m = (* fixes keys that link to k before removing it *) - if mem k m && not (V.is_alias (find k m)) then (* k might be aliased *) - let v = find k m in - match get_aliased k m with - | [] -> remove k m (* nothing links to k *) - | k'::xs -> let m = add k' v m in (* set k' to v, link xs to k', finally remove k *) - (* List.map (fun x -> x.vname) (k'::xs) |> String.concat ", " |> print_endline; *) - List.fold_left (fun m x -> alias x k' m) m xs |> remove k - else remove k m (* k not in m or an alias *) - let add' k v m = - remove' k m (* fixes keys that might have linked to k *) - |> add k v (* set new value *) - let change k v m = (* if k is an alias, replace its pointee *) - add (get_alias k m |? k) v m - - (* special variables *) - let get_record k m = Option.bind (find_option k m) V.get_record - let edit_record k f m = - let v = find_option k m |? V.make_var k in - add k (V.map f v) m - let get_value k m = find_option k m |> Option.map_default V.split (Set.empty,Set.empty) - let extend_value k v' m = - let v = V.from_tuple v' in - if mem k m then - add k (V.union (find k m) v) m - else - add k v m - let union (a,b) (c,d) = Set.union a c, Set.union b d - let is_special_var k = String.get (V.string_of_key k) 0 = '@' - let without_special_vars m = filter (fun k v -> not @@ is_special_var k) m - - (* functions needed for enter & combine *) - (* only keep globals, aliases to them and special variables *) - let only_globals m = filter (fun k v -> (fst k).vglob || V.is_alias v && (fst (V.get_alias v)).vglob || is_special_var k) m - (* adds all the bindings from m2 to m1 (overwrites!) *) - let add_all m1 m2 = add_list (bindings m2) m1 - - (* callstack for locations *) - let callstack_var = Cilfacade.create_var @@ Cil.makeVarinfo false "@callstack" Cil.voidType, `NoOffset - let callstack m = get_record callstack_var m |> Option.map_default V.loc [] - let string_of_callstack m = " [call stack: "^String.concat ", " (List.map (CilType.Location.show % Node.location) (callstack m))^"]" - let edit_callstack f m = edit_record callstack_var (V.edit_loc f) m - - - (* predicates *) - let must k p m = mem k m && V.must p (find' k m) - let may k p m = mem k m && V.may p (find' k m) - let is_may k m = mem k m && let x,y = V.length (find' k m) in x=0 && y>0 - - let filter_values p m = (* filters all values in the map and flattens result *) - let flatten_sets = List.fold_left Set.union Set.empty in - without_special_vars m - |> filter (fun k v -> V.may p v && not (V.is_alias v)) - |> bindings |> List.map (fun (k,v) -> V.filter' p v) - |> List.split |> (fun (x,y) -> flatten_sets x, flatten_sets y) - let filter_records k p m = (* filters both sets of k *) - if mem k m then V.filter' p (find' k m) else Set.empty, Set.empty - - let unknown k m = add' k (V.top ()) m - let is_unknown k m = if mem k m then V.is_top (find' k m) else false - - (* printing *) - let string_of_state k m = if not (mem k m) then "?" else V.string_of (find' k m) - let string_of_key k = V.string_of_key k - let string_of_keys rs = Set.map (V.string_of_key % V.key) rs |> Set.elements |> String.concat ", " - let string_of_entry k m = string_of_key k ^ ": " ^ string_of_state k m - let string_of_map m = List.map (fun (k,v) -> string_of_entry k m) (bindings m) - - let warn ?may:(may=false) ?loc:(loc=[Option.get !Node.current_node]) msg = - let split_category s = - if Str.string_partial_match (Str.regexp {|\[\([^]]*\)\]|}) s 0 then - (Some (Str.matched_group 1 s), Str.string_after s (Str.match_end ())) - else - (None, s) - in - let rec split_categories s = - match split_category s with - | (Some category, s') -> - let (categories, s'') = split_categories s' in - (category :: categories, s'') - | (None, s') -> ([], s') - in - match split_categories msg with - | ([], msg) -> (if may then Messages.warn else Messages.error) ~loc:(Node (List.last loc)) "%s" msg - | (category :: categories, msg) -> - let category_of_string s = Messages.Category.from_string_list [String.lowercase_ascii s] in (* TODO: doesn't split subcategories, not used and no defined syntax even *) - let category = category_of_string category in - let tags = List.map (fun category -> Messages.Tag.Category (category_of_string category)) categories in - (if may then Messages.warn else Messages.error) ~loc:(Node (List.last loc)) ~category ~tags "%s" msg - - (* getting keys from Cil Lvals *) - - let key_from_lval lval = match lval with (* TODO try to get a Mval.Exp from Cil.Lval *) - | Var v1, o1 -> v1, Offset.Exp.of_cil o1 - | Mem Lval(Var v1, o1), o2 -> v1, Offset.Exp.of_cil (addOffset o1 o2) - (* | Mem exp, o1 -> failwith "not implemented yet" (* TODO use query_lv *) *) - | _ -> Cilfacade.create_var @@ Cil.makeVarinfo false ("?"^CilType.Lval.show lval) Cil.voidType, `NoOffset (* TODO *) - - let keys_from_lval lval (ask: Queries.ask) = (* use MayPointTo query to get all possible pointees of &lval *) - (* print_query_lv ctx.ask (AddrOf lval); *) - let query_addrs (ask: Queries.ask) exp = match ask.f (Queries.MayPointTo exp) with - | ad when not (Queries.AD.is_top ad) -> Queries.AD.elements ad - | _ -> [] - in - let exp = AddrOf lval in - let addrs = query_addrs ask exp in (* MayPointTo -> LValSet *) - let keys = List.fold (fun vs addr -> - match addr with - | Queries.AD.Addr.Addr (v,o) -> (v, ValueDomain.Offs.to_exp o) :: vs - | _ -> vs - ) [] addrs - in - let pretty_key k = Pretty.text (string_of_key k) in - Messages.debug ~category:Analyzer "MayPointTo %a = [%a]" d_exp exp (Pretty.docList ~sep:(Pretty.text ", ") pretty_key) keys; - keys -end diff --git a/src/cdomains/regionDomain.ml b/src/cdomains/regionDomain.ml index 681eb79007..cd9141876c 100644 --- a/src/cdomains/regionDomain.ml +++ b/src/cdomains/regionDomain.ml @@ -8,23 +8,9 @@ module B = Printable.UnitConf (struct let name = "•" end) module VFB = struct - include Printable.Either (VF) (B) + include Printable.EitherConf (struct include Printable.DefaultConf let expand1 = false let expand2 = false end) (VF) (B) let name () = "region" - let pretty () = function - | `Right () -> Pretty.text "•" - | `Left x -> VF.pretty () x - - let show = function - | `Right () -> "•" - | `Left x -> VF.show x - - let printXml f = function - | `Right () -> - BatPrintf.fprintf f "\n\n•\n\n\n" - | `Left x -> - BatPrintf.fprintf f "\n\n%a\n\n\n" VF.printXml x - let collapse (x:t) (y:t): bool = match x,y with | `Right (), `Right () -> true @@ -252,4 +238,4 @@ struct end (* TODO: remove Lift *) -module RegionDom = Lattice.Lift (RegMap) (struct let top_name = "Unknown" let bot_name = "Error" end) +module RegionDom = Lattice.LiftConf (struct include Printable.DefaultConf let top_name = "Unknown" let bot_name = "Error" end) (RegMap) diff --git a/src/cdomains/specDomain.ml b/src/cdomains/specDomain.ml deleted file mode 100644 index 75a9d8edc5..0000000000 --- a/src/cdomains/specDomain.ml +++ /dev/null @@ -1,34 +0,0 @@ -(** Domains for finite automaton specification file analysis. *) - -open Batteries - -module D = MvalMapDomain - - -module Val = -struct - type s = string [@@deriving eq, ord, hash] - let name = "Spec value" - let var_state = "" - let string_of_state s = s - - (* transforms May-Sets of length 1 to Must. NOTE: this should only be done if the original set had more than one element! *) - (* let maybe_must = function May xs when Set.cardinal xs = 1 -> Must (Set.choose xs) | x -> x *) - (* let may = function Must x -> May (Set.singleton x) | xs -> xs *) - (* let records = function Must x -> (Set.singleton x) | May xs -> xs *) - (* let list_of_records = function Must x -> [x] | May xs -> List.of_enum (Set.enum xs) *) - (* let vnames x = String.concat ", " (List.map (fun r -> string_of_key r.var) (list_of_records x)) *) -end - - -module Dom = -struct - include D.Domain (D.Value (Val)) - - (* handling state *) - let goto k loc state m = add' k (V.make k loc state) m - let may_goto k loc state m = let v = V.join (find' k m) (V.make k loc state) in add' k v m - let in_state k s m = must k (V.in_state s) m - let may_in_state k s m = may k (V.in_state s) m - let get_states k m = if not (mem k m) then [] else find' k m |> V.map' V.state |> snd |> Set.elements -end diff --git a/src/cdomains/stackDomain.ml b/src/cdomains/stackDomain.ml index 3a83c78503..50864d6294 100644 --- a/src/cdomains/stackDomain.ml +++ b/src/cdomains/stackDomain.ml @@ -30,7 +30,7 @@ struct module VarLat = Lattice.Fake (Basetype.Variables) - module Var = Lattice.Lift (VarLat) (struct let top_name="top" let bot_name="⊥" end) + module Var = Lattice.LiftConf (struct include Printable.DefaultConf let top_name="top" let bot_name="⊥" end) (VarLat) include Lattice.Liszt (Var) let top () : t = [] diff --git a/src/cdomains/symbLocksDomain.ml b/src/cdomains/symbLocksDomain.ml index 4a44911a53..85578d5fad 100644 --- a/src/cdomains/symbLocksDomain.ml +++ b/src/cdomains/symbLocksDomain.ml @@ -306,6 +306,7 @@ struct end include AddressDomain.AddressPrintable (Mval.MakePrintable (Offset.MakePrintable (Idx))) + let name () = "i-lock" let rec conv_const_offset x = match x with diff --git a/src/common/cdomains/basetype.ml b/src/common/cdomains/basetype.ml index 55b5dbde07..1b846309aa 100644 --- a/src/common/cdomains/basetype.ml +++ b/src/common/cdomains/basetype.ml @@ -20,8 +20,6 @@ struct | _ -> Local let name () = "variables" let printXml f x = BatPrintf.fprintf f "\n\n%s\n\n\n" (XmlUtil.escape (show x)) - - let arbitrary () = MyCheck.Arbitrary.varinfo end module RawStrings: Printable.S with type t = string = @@ -35,12 +33,6 @@ struct let printXml f x = BatPrintf.fprintf f "\n\n%s\n\n\n" (XmlUtil.escape (show x)) end -module Strings: Lattice.S with type t = [`Bot | `Lifted of string | `Top] = - Lattice.Flat (RawStrings) (struct - let top_name = "?" - let bot_name = "-" - end) - module RawBools: Printable.S with type t = bool = struct include Printable.StdLeaf @@ -52,12 +44,6 @@ struct let printXml f x = BatPrintf.fprintf f "\n\n%s\n\n\n" (show x) end -module Bools: Lattice.S with type t = [`Bot | `Lifted of bool | `Top] = - Lattice.Flat (RawBools) (struct - let top_name = "?" - let bot_name = "-" - end) - module CilExp = struct include CilType.Exp diff --git a/src/cdomains/floatOps/floatOps.ml b/src/common/cdomains/floatOps/floatOps.ml similarity index 100% rename from src/cdomains/floatOps/floatOps.ml rename to src/common/cdomains/floatOps/floatOps.ml diff --git a/src/cdomains/floatOps/floatOps.mli b/src/common/cdomains/floatOps/floatOps.mli similarity index 100% rename from src/cdomains/floatOps/floatOps.mli rename to src/common/cdomains/floatOps/floatOps.mli diff --git a/src/cdomains/floatOps/stubs.c b/src/common/cdomains/floatOps/stubs.c similarity index 100% rename from src/cdomains/floatOps/stubs.c rename to src/common/cdomains/floatOps/stubs.c diff --git a/src/common/common.mld b/src/common/common.mld index 662c789572..2176a95b8a 100644 --- a/src/common/common.mld +++ b/src/common/common.mld @@ -10,27 +10,20 @@ For better context, see {!Goblint_lib} which also documents these modules. Node Edge MyCFG +CfgTools } {2 Specification} {!modules: AnalysisState +AnalysisStateUtil ControlSpecC } -{2 Configuration} -{!modules: -GobConfig -AfterConfig -JsonSchema -Options -} - {1 Domains} {!modules: Printable -Lattice } {2 Analysis-specific} @@ -42,7 +35,6 @@ Lattice {1 I/O} {!modules: Messages -Tracing } @@ -51,6 +43,7 @@ Tracing {2 General} {!modules: +IntOps LazyEval ResettableLazy MessageUtil @@ -64,11 +57,13 @@ Cilfacade RichVarinfo } +{2 Analysis-specific} +{!modules: +ContextUtil +} + {1 Library extensions} {2 Standard library} {!modules:GobFormat} - -{2 Other libraries} -{!modules:MyCheck} diff --git a/src/common/domains/printable.ml b/src/common/domains/printable.ml index b0755fb730..0b1769e99c 100644 --- a/src/common/domains/printable.ml +++ b/src/common/domains/printable.ml @@ -103,18 +103,6 @@ struct end module Unit = UnitConf (struct let name = "()" end) -module type LiftingNames = -sig - val bot_name: string - val top_name: string -end - -module DefaultNames = -struct - let bot_name = "bot" - let top_name = "top" -end - (* HAS SIDE-EFFECTS ---- PLEASE INSTANCIATE ONLY ONCE!!! *) module HConsed (Base:S) = struct @@ -195,11 +183,67 @@ struct let tag = lift_f M.tag end -module Lift (Base: S) (N: LiftingNames) = + +module type PrefixNameConf = +sig + val expand: bool +end + +module PrefixName (Conf: PrefixNameConf) (Base: S): S with type t = Base.t = struct + include Base + + let pretty () x = + if Conf.expand then + Pretty.dprintf "%s:%a" (Base.name ()) Base.pretty x + else + Base.pretty () x + + let show x = + if Conf.expand then + Base.name () ^ ":" ^ Base.show x + else + Base.show x + + let printXml f x = + if Conf.expand then + BatPrintf.fprintf f "\n\n%s\n\n%a\n\n" (Base.name ()) Base.printXml x + else + Base.printXml f x + + let to_yojson x = + if Conf.expand then + `Assoc [(Base.name (), Base.to_yojson x)] + else + Base.to_yojson x +end + + +module type LiftConf = +sig + val bot_name: string + val top_name: string + val expand1: bool +end + +module DefaultConf = +struct + let bot_name = "bot" + let top_name = "top" + let expand1 = true + let expand2 = true + let expand3 = true +end + +module LiftConf (Conf: LiftConf) (Base: S) = +struct + open struct + module Base = PrefixName (struct let expand = Conf.expand1 end) (Base) + end + type t = [`Bot | `Lifted of Base.t | `Top] [@@deriving eq, ord, hash] include Std - include N + open Conf let lift x = `Lifted x @@ -217,13 +261,13 @@ struct let name () = "lifted " ^ Base.name () let printXml f = function - | `Bot -> BatPrintf.fprintf f "\n\n%s\n\n\n" (XmlUtil.escape N.bot_name) - | `Top -> BatPrintf.fprintf f "\n\n%s\n\n\n" (XmlUtil.escape N.top_name) + | `Bot -> BatPrintf.fprintf f "\n\n%s\n\n\n" (XmlUtil.escape bot_name) + | `Top -> BatPrintf.fprintf f "\n\n%s\n\n\n" (XmlUtil.escape top_name) | `Lifted x -> Base.printXml f x let to_yojson = function - | `Bot -> `String N.bot_name - | `Top -> `String N.top_name + | `Bot -> `String bot_name + | `Top -> `String top_name | `Lifted x -> Base.to_yojson x let relift x = match x with @@ -233,9 +277,9 @@ struct let arbitrary () = let open QCheck.Iter in let shrink = function - | `Lifted x -> (return `Bot) <+> (MyCheck.shrink (Base.arbitrary ()) x >|= lift) + | `Lifted x -> (return `Bot) <+> (GobQCheck.shrink (Base.arbitrary ()) x >|= lift) | `Bot -> empty - | `Top -> MyCheck.Iter.of_arbitrary ~n:20 (Base.arbitrary ()) >|= lift + | `Top -> GobQCheck.Iter.of_arbitrary ~n:20 (Base.arbitrary ()) >|= lift in QCheck.frequency ~shrink ~print:show [ 20, QCheck.map lift (Base.arbitrary ()); @@ -244,35 +288,96 @@ struct ] (* S TODO: decide frequencies *) end -module Either (Base1: S) (Base2: S) = +module type EitherConf = +sig + val expand1: bool + val expand2: bool +end + +module EitherConf (Conf: EitherConf) (Base1: S) (Base2: S) = struct + open struct + module Base1 = PrefixName (struct let expand = Conf.expand1 end) (Base1) + module Base2 = PrefixName (struct let expand = Conf.expand2 end) (Base2) + end + type t = [`Left of Base1.t | `Right of Base2.t] [@@deriving eq, ord, hash] include Std let pretty () (state:t) = match state with - | `Left n -> Pretty.dprintf "%s:%a" (Base1.name ()) Base1.pretty n - | `Right n -> Pretty.dprintf "%s:%a" (Base2.name ()) Base2.pretty n + | `Left n -> Base1.pretty () n + | `Right n -> Base2.pretty () n let show state = match state with - | `Left n -> (Base1.name ()) ^ ":" ^ Base1.show n - | `Right n -> (Base2.name ()) ^ ":" ^ Base2.show n + | `Left n -> Base1.show n + | `Right n -> Base2.show n let name () = "either " ^ Base1.name () ^ " or " ^ Base2.name () let printXml f = function - | `Left x -> BatPrintf.fprintf f "\n\nLeft\n\n%a\n\n" Base1.printXml x - | `Right x -> BatPrintf.fprintf f "\n\nRight\n\n%a\n\n" Base2.printXml x + | `Left x -> Base1.printXml f x + | `Right x -> Base2.printXml f x let to_yojson = function - | `Left x -> `Assoc [ Base1.name (), Base1.to_yojson x ] - | `Right x -> `Assoc [ Base2.name (), Base2.to_yojson x ] + | `Left x -> Base1.to_yojson x + | `Right x -> Base2.to_yojson x let relift = function | `Left x -> `Left (Base1.relift x) | `Right x -> `Right (Base2.relift x) end +module Either = EitherConf (DefaultConf) + +module type Either3Conf = +sig + include EitherConf + val expand3: bool +end + +module Either3Conf (Conf: Either3Conf) (Base1: S) (Base2: S) (Base3: S) = +struct + open struct + module Base1 = PrefixName (struct let expand = Conf.expand1 end) (Base1) + module Base2 = PrefixName (struct let expand = Conf.expand2 end) (Base2) + module Base3 = PrefixName (struct let expand = Conf.expand3 end) (Base3) + end + + type t = [`Left of Base1.t | `Middle of Base2.t | `Right of Base3.t] [@@deriving eq, ord, hash] + include Std + + let pretty () (state:t) = + match state with + | `Left n -> Base1.pretty () n + | `Middle n -> Base2.pretty () n + | `Right n -> Base3.pretty () n + + let show state = + match state with + | `Left n -> Base1.show n + | `Middle n -> Base2.show n + | `Right n -> Base3.show n + + let name () = "either " ^ Base1.name () ^ " or " ^ Base2.name () ^ " or " ^ Base3.name () + let printXml f = function + | `Left x -> Base1.printXml f x + | `Middle x -> Base2.printXml f x + | `Right x -> Base3.printXml f x + + let to_yojson = function + | `Left x -> Base1.to_yojson x + | `Middle x -> Base2.to_yojson x + | `Right x -> Base3.to_yojson x + + let relift = function + | `Left x -> `Left (Base1.relift x) + | `Middle x -> `Middle (Base2.relift x) + | `Right x -> `Right (Base3.relift x) +end + +module Either3 = Either3Conf (DefaultConf) + module Option (Base: S) (N: Name) = struct type t = Base.t option [@@deriving eq, ord, hash] @@ -300,11 +405,22 @@ struct let relift = Option.map Base.relift end -module Lift2 (Base1: S) (Base2: S) (N: LiftingNames) = +module type Lift2Conf = +sig + include LiftConf + val expand2: bool +end + +module Lift2Conf (Conf: Lift2Conf) (Base1: S) (Base2: S) = struct + open struct + module Base1 = PrefixName (struct let expand = Conf.expand1 end) (Base1) + module Base2 = PrefixName (struct let expand = Conf.expand2 end) (Base2) + end + type t = [`Bot | `Lifted1 of Base1.t | `Lifted2 of Base2.t | `Top] [@@deriving eq, ord, hash] include Std - include N + open Conf let pretty () (state:t) = match state with @@ -327,16 +443,16 @@ struct let name () = "lifted " ^ Base1.name () ^ " and " ^ Base2.name () let printXml f = function - | `Bot -> BatPrintf.fprintf f "\n\n%s\n\n\n" N.bot_name - | `Top -> BatPrintf.fprintf f "\n\n%s\n\n\n" N.top_name - | `Lifted1 x -> BatPrintf.fprintf f "\n\n\nLifted1\n\n%a\n\n" Base1.printXml x - | `Lifted2 x -> BatPrintf.fprintf f "\n\n\nLifted2\n\n%a\n\n" Base2.printXml x + | `Bot -> BatPrintf.fprintf f "\n\n%s\n\n\n" bot_name + | `Top -> BatPrintf.fprintf f "\n\n%s\n\n\n" top_name + | `Lifted1 x -> Base1.printXml f x + | `Lifted2 x -> Base2.printXml f x let to_yojson = function - | `Bot -> `String N.bot_name - | `Top -> `String N.top_name - | `Lifted1 x -> `Assoc [ Base1.name (), Base1.to_yojson x ] - | `Lifted2 x -> `Assoc [ Base2.name (), Base2.to_yojson x ] + | `Bot -> `String bot_name + | `Top -> `String top_name + | `Lifted1 x -> Base1.to_yojson x + | `Lifted2 x -> Base2.to_yojson x end module type ProdConfiguration = @@ -592,8 +708,8 @@ struct let arbitrary () = let open QCheck.Iter in let shrink = function - | `Lifted x -> MyCheck.shrink (Base.arbitrary ()) x >|= lift - | `Top -> MyCheck.Iter.of_arbitrary ~n:20 (Base.arbitrary ()) >|= lift + | `Lifted x -> GobQCheck.shrink (Base.arbitrary ()) x >|= lift + | `Top -> GobQCheck.Iter.of_arbitrary ~n:20 (Base.arbitrary ()) >|= lift in QCheck.frequency ~shrink ~print:show [ 20, QCheck.map lift (Base.arbitrary ()); diff --git a/src/common/dune b/src/common/dune index c8f1564782..8576970900 100644 --- a/src/common/dune +++ b/src/common/dune @@ -8,22 +8,21 @@ batteries.unthreaded zarith goblint_std + goblint_config + goblint_tracing goblint-cil fpath yojson - json-data-encoding - cpu goblint_timing - goblint_build_info - goblint.sites qcheck-core.runner) (flags :standard -open Goblint_std) + (foreign_stubs (language c) (names stubs)) + (ocamlopt_flags :standard -no-float-const-prop) (preprocess (pps ppx_deriving.std ppx_deriving_hash - ppx_deriving_yojson - ppx_blob)) - (preprocessor_deps (file util/options.schema.json))) + ppx_deriving_yojson)) + (instrumentation (backend bisect_ppx))) (documentation) diff --git a/src/framework/cfgTools.ml b/src/common/framework/cfgTools.ml similarity index 98% rename from src/framework/cfgTools.ml rename to src/common/framework/cfgTools.ml index 8f98a48e84..78aba17060 100644 --- a/src/framework/cfgTools.ml +++ b/src/common/framework/cfgTools.ml @@ -122,10 +122,6 @@ let rec pretty_edges () = function | [_,x] -> Edge.pretty_plain () x | (_,x)::xs -> Pretty.dprintf "%a; %a" Edge.pretty_plain x pretty_edges xs -let get_pseudo_return_id fd = - let start_id = 10_000_000_000 in (* TODO get max_sid? *) - let sid = Hashtbl.hash fd.svar.vid in (* Need pure sid instead of Cil.new_sid for incremental, similar to vid in Cilfacade.create_var. We only add one return stmt per loop, so the hash from the functions vid should be unique. *) - if sid < start_id then sid + start_id else sid let node_scc_global = NH.create 113 @@ -260,7 +256,7 @@ let createCFG (file: file) = if Messages.tracing then Messages.trace "cfg" "adding pseudo-return to the function %s.\n" fd.svar.vname; let fd_end_loc = {fd_loc with line = fd_loc.endLine; byte = fd_loc.endByte; column = fd_loc.endColumn} in let newst = mkStmt (Return (None, fd_end_loc)) in - newst.sid <- get_pseudo_return_id fd; + newst.sid <- Cilfacade.get_pseudo_return_id fd; Cilfacade.StmtH.add Cilfacade.pseudo_return_to_fun newst fd; Cilfacade.IntH.replace Cilfacade.pseudo_return_stmt_sids newst.sid newst; let newst_node = Statement newst in @@ -475,7 +471,7 @@ let createCFG (file: file) = ); if Messages.tracing then Messages.trace "cfg" "CFG building finished.\n\n"; if get_bool "dbg.verbose" then - ignore (Pretty.eprintf "cfgF (%a), cfgB (%a)\n" GobHashtbl.pretty_statistics (GobHashtbl.magic_stats cfgF) GobHashtbl.pretty_statistics (GobHashtbl.magic_stats cfgB)); + ignore (Pretty.eprintf "cfgF (%a), cfgB (%a)\n" GobHashtbl.pretty_statistics (NH.stats cfgF) GobHashtbl.pretty_statistics (NH.stats cfgB)); cfgF, cfgB, skippedByEdge let createCFG = Timing.wrap "createCFG" createCFG @@ -685,7 +681,7 @@ let getGlobalInits (file: file) : edges = lval in let rec any_index_offset = function - | Index (e,o) -> Index (Offset.Index.Exp.any, any_index_offset o) + | Index (e,o) -> Index (Cilfacade.any_index_exp, any_index_offset o) | Field (f,o) -> Field (f, any_index_offset o) | NoOffset -> NoOffset in diff --git a/src/util/analysisStateUtil.ml b/src/common/util/analysisStateUtil.ml similarity index 100% rename from src/util/analysisStateUtil.ml rename to src/common/util/analysisStateUtil.ml diff --git a/src/common/util/cilfacade.ml b/src/common/util/cilfacade.ml index 26a2f082a4..eff97da404 100644 --- a/src/common/util/cilfacade.ml +++ b/src/common/util/cilfacade.ml @@ -531,6 +531,12 @@ let stmt_fundecs: fundec StmtH.t ResettableLazy.t = h ) + +let get_pseudo_return_id fd = + let start_id = 10_000_000_000 in (* TODO get max_sid? *) + let sid = Hashtbl.hash fd.svar.vid in (* Need pure sid instead of Cil.new_sid for incremental, similar to vid in Cilfacade.create_var. We only add one return stmt per loop, so the hash from the functions vid should be unique. *) + if sid < start_id then sid + start_id else sid + let pseudo_return_to_fun = StmtH.create 113 (** Find [fundec] which the [stmt] is in. *) @@ -706,4 +712,10 @@ let add_function_declarations (file: Cil.file): unit = in let fun_decls = List.filter_map declaration_from_GFun functions in let globals = upto_last_type @ fun_decls @ non_types @ functions in - file.globals <- globals \ No newline at end of file + file.globals <- globals + + +(** Special index expression for some unknown index. + Weakly updates array in assignment. + Used for [exp.fast_global_inits]. *) +let any_index_exp = CastE (TInt (ptrdiff_ikind (), []), mkString "any_index") (* TODO: move back to Offset *) diff --git a/src/util/contextUtil.ml b/src/common/util/contextUtil.ml similarity index 100% rename from src/util/contextUtil.ml rename to src/common/util/contextUtil.ml diff --git a/src/util/intOps.ml b/src/common/util/intOps.ml similarity index 100% rename from src/util/intOps.ml rename to src/common/util/intOps.ml diff --git a/src/common/util/messages.ml b/src/common/util/messages.ml index 42a3118978..d7afec43c5 100644 --- a/src/common/util/messages.ml +++ b/src/common/util/messages.ml @@ -339,4 +339,23 @@ let msg_final severity ?(tags=[]) ?(category=Category.Unknown) fmt = else GobPretty.igprintf () fmt -include Tracing + +include Goblint_tracing + +open Pretty + +let tracel sys ?var fmt = + let loc = !current_loc in + let docloc sys doc = + printtrace sys (dprintf "(%a)@?" CilType.Location.pretty loc ++ indent 2 doc); + in + gtrace true docloc sys var ~loc ignore fmt + +let traceli sys ?var ?(subsys=[]) fmt = + let loc = !current_loc in + let g () = activate sys subsys in + let docloc sys doc: unit = + printtrace sys (dprintf "(%a)" CilType.Location.pretty loc ++ indent 2 doc); + traceIndent () + in + gtrace true docloc sys var ~loc g fmt diff --git a/src/common/util/xmlUtil.ml b/src/common/util/xmlUtil.ml index e33be1b215..c0eaa074e9 100644 --- a/src/common/util/xmlUtil.ml +++ b/src/common/util/xmlUtil.ml @@ -11,4 +11,5 @@ let escape (x:string):string = Str.global_replace (Str.regexp "\"") """ |> Str.global_replace (Str.regexp "'") "'" |> Str.global_replace (Str.regexp "[\x0b\001\x0c\x0f\x0e\x05]") "" |> (* g2html just cannot handle from some kernel benchmarks, even when escaped... *) - Str.global_replace (Str.regexp "[\x1b]") "" (* g2html cannot handle from chrony *) + Str.global_replace (Str.regexp "[\x1b]") "" |> (* g2html cannot handle from chrony *) + Str.global_replace (Str.regexp "\x00") "\\\\0" (* produces \\0, is needed if an example contains \0 *) diff --git a/src/common/util/afterConfig.ml b/src/config/afterConfig.ml similarity index 100% rename from src/common/util/afterConfig.ml rename to src/config/afterConfig.ml diff --git a/src/config/config.mld b/src/config/config.mld new file mode 100644 index 0000000000..160eaa9a11 --- /dev/null +++ b/src/config/config.mld @@ -0,0 +1,14 @@ +{0 Library goblint.config} +This library is unwrapped and provides the following top-level modules. +For better context, see {!Goblint_lib} which also documents these modules. + + +{1 Framework} + +{2 Configuration} +{!modules: +GobConfig +AfterConfig +JsonSchema +Options +} diff --git a/src/config/dune b/src/config/dune new file mode 100644 index 0000000000..ce5cb11559 --- /dev/null +++ b/src/config/dune @@ -0,0 +1,24 @@ +(include_subdirs no) + +(library + (name goblint_config) + (public_name goblint.config) + (wrapped false) ; TODO: wrap + (libraries + batteries.unthreaded + goblint_std + goblint_tracing + fpath + yojson + json-data-encoding + cpu + goblint.sites + qcheck-core.runner) + (flags :standard -open Goblint_std) + (preprocess + (pps + ppx_blob)) + (preprocessor_deps (file options.schema.json)) + (instrumentation (backend bisect_ppx))) + +(documentation) diff --git a/src/common/util/gobConfig.ml b/src/config/gobConfig.ml similarity index 96% rename from src/common/util/gobConfig.ml rename to src/config/gobConfig.ml index c517ba150d..24a1701ce6 100644 --- a/src/common/util/gobConfig.ml +++ b/src/config/gobConfig.ml @@ -21,7 +21,6 @@ *) open Batteries -open Tracing open Printf exception ConfigError of string @@ -300,7 +299,7 @@ struct try let st = String.trim st in let x = get_value !json_conf (parse_path st) in - if tracing then trace "conf-reads" "Reading '%s', it is %a.\n" st GobYojson.pretty x; + if Goblint_tracing.tracing then Goblint_tracing.trace "conf-reads" "Reading '%s', it is %a.\n" st GobYojson.pretty x; try f x with Yojson.Safe.Util.Type_error (s, _) -> eprintf "The value for '%s' has the wrong type: %s\n" st s; @@ -332,7 +331,7 @@ struct let wrap_get f x = (* self-observe options, which Spec construction depends on *) - if !building_spec && Tracing.tracing then Tracing.trace "config" "get during building_spec: %s\n" x; + if !building_spec && Goblint_tracing.tracing then Goblint_tracing.trace "config" "get during building_spec: %s\n" x; (* TODO: blacklist such building_spec option from server mode modification since it will have no effect (spec is already built) *) f x @@ -352,7 +351,7 @@ struct (** Helper function for writing values. Handles the tracing. *) let set_path_string st v = - if tracing then trace "conf" "Setting '%s' to %a.\n" st GobYojson.pretty v; + if Goblint_tracing.tracing then Goblint_tracing.trace "conf" "Setting '%s' to %a.\n" st GobYojson.pretty v; set_value v json_conf (parse_path st) let set_json st j = @@ -402,7 +401,7 @@ struct | Some fn -> let v = Yojson.Safe.from_channel % BatIO.to_input_channel |> File.with_file_in (Fpath.to_string fn) in merge v; - if tracing then trace "conf" "Merging with '%a', resulting\n%a.\n" GobFpath.pretty fn GobYojson.pretty !json_conf + if Goblint_tracing.tracing then Goblint_tracing.trace "conf" "Merging with '%a', resulting\n%a.\n" GobFpath.pretty fn GobYojson.pretty !json_conf | None -> raise (Sys_error (Printf.sprintf "%s: No such file or diretory" (Fpath.to_string fn))) end diff --git a/src/common/util/jsonSchema.ml b/src/config/jsonSchema.ml similarity index 100% rename from src/common/util/jsonSchema.ml rename to src/config/jsonSchema.ml diff --git a/src/common/util/options.ml b/src/config/options.ml similarity index 98% rename from src/common/util/options.ml rename to src/config/options.ml index 3046f70809..125da3330b 100644 --- a/src/common/util/options.ml +++ b/src/config/options.ml @@ -1,4 +1,4 @@ -(** [src/common/util/options.schema.json] low-level access. *) +(** [src/config/options.schema.json] low-level access. *) open Json_schema diff --git a/src/common/util/options.schema.json b/src/config/options.schema.json similarity index 99% rename from src/common/util/options.schema.json rename to src/config/options.schema.json index ab48e3a9ad..0c83e342e0 100644 --- a/src/common/util/options.schema.json +++ b/src/config/options.schema.json @@ -467,32 +467,6 @@ }, "additionalProperties": false }, - "file": { - "title": "ana.file", - "type": "object", - "properties": { - "optimistic": { - "title": "ana.file.optimistic", - "description": "Assume fopen never fails.", - "type": "boolean", - "default": false - } - }, - "additionalProperties": false - }, - "spec": { - "title": "ana.spec", - "type": "object", - "properties": { - "file": { - "title": "ana.spec.file", - "description": "Path to the specification file.", - "type": "string", - "default": "" - } - }, - "additionalProperties": false - }, "pml": { "title": "ana.pml", "type": "object", @@ -715,6 +689,12 @@ "description": "Indicates how many values will the unrolled part of the unrolled array domain contain.", "type": "integer", "default": 0 + }, + "nullbytes": { + "title": "ana.base.arrays.nullbytes", + "description": "Whether the Null Byte array domain should be activated.", + "type": "boolean", + "default": false } }, "additionalProperties": false diff --git a/src/constraint/constrSys.ml b/src/constraint/constrSys.ml new file mode 100644 index 0000000000..1698d5f214 --- /dev/null +++ b/src/constraint/constrSys.ml @@ -0,0 +1,299 @@ +(** {{!MonSystem} constraint system} signatures. *) + +open Batteries + +module type SysVar = +sig + type t + val is_write_only: t -> bool +end + +module type VarType = +sig + include Hashtbl.HashedType + include SysVar with type t := t + val pretty_trace: unit -> t -> GoblintCil.Pretty.doc + val compare : t -> t -> int + + val printXml : 'a BatInnerIO.output -> t -> unit + val var_id : t -> string + val node : t -> MyCFG.node + val relift : t -> t (* needed only for incremental+hashcons to re-hashcons contexts after loading *) +end + +(** Abstract incremental change to constraint system. + @param 'v constrain system variable type *) +type 'v sys_change_info = { + obsolete: 'v list; (** Variables to destabilize. *) + delete: 'v list; (** Variables to delete. *) + reluctant: 'v list; (** Variables to solve reluctantly. *) + restart: 'v list; (** Variables to restart. *) +} + +(** A side-effecting system. *) +module type MonSystem = +sig + type v (* variables *) + type d (* values *) + type 'a m (* basically a monad carrier *) + + (** Variables must be hashable, comparable, etc. *) + module Var : VarType with type t = v + + (** Values must form a lattice. *) + module Dom : Lattice.S with type t = d + + (** The system in functional form. *) + val system : v -> ((v -> d) -> (v -> d -> unit) -> d) m + + val sys_change: (v -> d) -> v sys_change_info + (** Compute incremental constraint system change from old solution. *) +end + +(** Any system of side-effecting equations over lattices. *) +module type EqConstrSys = MonSystem with type 'a m := 'a option + +(** A side-effecting system with globals. *) +module type GlobConstrSys = +sig + module LVar : VarType + module GVar : VarType + + module D : Lattice.S + module G : Lattice.S + val system : LVar.t -> ((LVar.t -> D.t) -> (LVar.t -> D.t -> unit) -> (GVar.t -> G.t) -> (GVar.t -> G.t -> unit) -> D.t) option + val iter_vars: (LVar.t -> D.t) -> (GVar.t -> G.t) -> VarQuery.t -> LVar.t VarQuery.f -> GVar.t VarQuery.f -> unit + val sys_change: (LVar.t -> D.t) -> (GVar.t -> G.t) -> [`L of LVar.t | `G of GVar.t] sys_change_info +end + +(** A solver is something that can translate a system into a solution (hash-table). + Incremental solver has data to be marshaled. *) +module type GenericEqIncrSolverBase = + functor (S:EqConstrSys) -> + functor (H:Hashtbl.S with type key=S.v) -> + sig + type marshal + + val copy_marshal: marshal -> marshal + val relift_marshal: marshal -> marshal + + (** The hash-map that is the first component of [solve xs vs] is a local solution for interesting variables [vs], + reached from starting values [xs]. + As a second component the solver returns data structures for incremental serialization. *) + val solve : (S.v*S.d) list -> S.v list -> marshal option -> S.d H.t * marshal + end + +(** (Incremental) solver argument, indicating which postsolving should be performed by the solver. *) +module type IncrSolverArg = +sig + val should_prune: bool + val should_verify: bool + val should_warn: bool + val should_save_run: bool +end + +(** An incremental solver takes the argument about postsolving. *) +module type GenericEqIncrSolver = + functor (Arg: IncrSolverArg) -> + GenericEqIncrSolverBase + +(** A solver is something that can translate a system into a solution (hash-table) *) +module type GenericEqSolver = + functor (S:EqConstrSys) -> + functor (H:Hashtbl.S with type key=S.v) -> + sig + (** The hash-map that is the first component of [solve xs vs] is a local solution for interesting variables [vs], + reached from starting values [xs]. *) + val solve : (S.v*S.d) list -> S.v list -> S.d H.t + end + +(** A solver is something that can translate a system into a solution (hash-table) *) +module type GenericGlobSolver = + functor (S:GlobConstrSys) -> + functor (LH:Hashtbl.S with type key=S.LVar.t) -> + functor (GH:Hashtbl.S with type key=S.GVar.t) -> + sig + type marshal + + val copy_marshal: marshal -> marshal + val relift_marshal: marshal -> marshal + + (** The hash-map that is the first component of [solve xs vs] is a local solution for interesting variables [vs], + reached from starting values [xs]. + As a second component the solver returns data structures for incremental serialization. *) + val solve : (S.LVar.t*S.D.t) list -> (S.GVar.t*S.G.t) list -> S.LVar.t list -> marshal option -> (S.D.t LH.t * S.G.t GH.t) * marshal + end + + +(** Combined variables so that we can also use the more common [EqConstrSys] + that uses only one kind of a variable. *) +module Var2 (LV:VarType) (GV:VarType) + : VarType + with type t = [ `L of LV.t | `G of GV.t ] += +struct + type t = [ `L of LV.t | `G of GV.t ] [@@deriving eq, ord, hash] + let relift = function + | `L x -> `L (LV.relift x) + | `G x -> `G (GV.relift x) + + let pretty_trace () = function + | `L a -> GoblintCil.Pretty.dprintf "L:%a" LV.pretty_trace a + | `G a -> GoblintCil.Pretty.dprintf "G:%a" GV.pretty_trace a + + let printXml f = function + | `L a -> LV.printXml f a + | `G a -> GV.printXml f a + + let var_id = function + | `L a -> LV.var_id a + | `G a -> GV.var_id a + + let node = function + | `L a -> LV.node a + | `G a -> GV.node a + + let is_write_only = function + | `L a -> LV.is_write_only a + | `G a -> GV.is_write_only a +end + + +(** Translate a [GlobConstrSys] into a [EqConstrSys] *) +module EqConstrSysFromGlobConstrSys (S:GlobConstrSys) + : EqConstrSys with type v = Var2(S.LVar)(S.GVar).t + and type d = Lattice.Lift2(S.G)(S.D).t + and module Var = Var2(S.LVar)(S.GVar) + and module Dom = Lattice.Lift2(S.G)(S.D) += +struct + module Var = Var2(S.LVar)(S.GVar) + module Dom = + struct + include Lattice.Lift2 (S.G) (S.D) + let printXml f = function + | `Lifted1 a -> S.G.printXml f a + | `Lifted2 a -> S.D.printXml f a + | (`Bot | `Top) as x -> printXml f x + end + type v = Var.t + type d = Dom.t + + let getG = function + | `Lifted1 x -> x + | `Bot -> S.G.bot () + | `Top -> failwith "EqConstrSysFromGlobConstrSys.getG: global variable has top value" + | `Lifted2 _ -> failwith "EqConstrSysFromGlobConstrSys.getG: global variable has local value" + + let getL = function + | `Lifted2 x -> x + | `Bot -> S.D.bot () + | `Top -> failwith "EqConstrSysFromGlobConstrSys.getL: local variable has top value" + | `Lifted1 _ -> failwith "EqConstrSysFromGlobConstrSys.getL: local variable has global value" + + let l, g = (fun x -> `L x), (fun x -> `G x) + let lD, gD = (fun x -> `Lifted2 x), (fun x -> `Lifted1 x) + + let conv f get set = + f (getL % get % l) (fun x v -> set (l x) (lD v)) + (getG % get % g) (fun x v -> set (g x) (gD v)) + |> lD + + let system = function + | `G _ -> None + | `L x -> Option.map conv (S.system x) + + let sys_change get = + S.sys_change (getL % get % l) (getG % get % g) +end + +(** Splits a [EqConstrSys] solution into a [GlobConstrSys] solution with given [Hashtbl.S] for the [EqConstrSys]. *) +module GlobConstrSolFromEqConstrSolBase (S: GlobConstrSys) (LH: Hashtbl.S with type key = S.LVar.t) (GH: Hashtbl.S with type key = S.GVar.t) (VH: Hashtbl.S with type key = Var2 (S.LVar) (S.GVar).t) = +struct + let split_solution hm = + let l' = LH.create 113 in + let g' = GH.create 113 in + let split_vars x d = match x with + | `L x -> + begin match d with + | `Lifted2 d -> LH.replace l' x d + (* | `Bot -> () *) + (* Since Verify2 is broken and only checks existing keys, add it with local bottom value. + This works around some cases, where Verify2 would not detect a problem due to completely missing variable. *) + | `Bot -> LH.replace l' x (S.D.bot ()) + | `Top -> failwith "GlobConstrSolFromEqConstrSolBase.split_vars: local variable has top value" + | `Lifted1 _ -> failwith "GlobConstrSolFromEqConstrSolBase.split_vars: local variable has global value" + end + | `G x -> + begin match d with + | `Lifted1 d -> GH.replace g' x d + | `Bot -> () + | `Top -> failwith "GlobConstrSolFromEqConstrSolBase.split_vars: global variable has top value" + | `Lifted2 _ -> failwith "GlobConstrSolFromEqConstrSolBase.split_vars: global variable has local value" + end + in + VH.iter split_vars hm; + (l', g') +end + +(** Splits a [EqConstrSys] solution into a [GlobConstrSys] solution. *) +module GlobConstrSolFromEqConstrSol (S: GlobConstrSys) (LH: Hashtbl.S with type key = S.LVar.t) (GH: Hashtbl.S with type key = S.GVar.t) = +struct + module S2 = EqConstrSysFromGlobConstrSys (S) + module VH = Hashtbl.Make (S2.Var) + + include GlobConstrSolFromEqConstrSolBase (S) (LH) (GH) (VH) +end + +(** Transforms a [GenericEqIncrSolver] into a [GenericGlobSolver]. *) +module GlobSolverFromEqSolver (Sol:GenericEqIncrSolverBase) + = functor (S:GlobConstrSys) -> + functor (LH:Hashtbl.S with type key=S.LVar.t) -> + functor (GH:Hashtbl.S with type key=S.GVar.t) -> + struct + module EqSys = EqConstrSysFromGlobConstrSys (S) + + module VH : Hashtbl.S with type key=EqSys.v = Hashtbl.Make(EqSys.Var) + module Sol' = Sol (EqSys) (VH) + + module Splitter = GlobConstrSolFromEqConstrSolBase (S) (LH) (GH) (VH) (* reuse EqSys and VH *) + + type marshal = Sol'.marshal + + let copy_marshal = Sol'.copy_marshal + let relift_marshal = Sol'.relift_marshal + + let solve ls gs l old_data = + let vs = List.map (fun (x,v) -> `L x, `Lifted2 v) ls + @ List.map (fun (x,v) -> `G x, `Lifted1 v) gs in + let sv = List.map (fun x -> `L x) l in + let hm, solver_data = Sol'.solve vs sv old_data in + Splitter.split_solution hm, solver_data + end + + +(** [EqConstrSys] where [current_var] indicates the variable whose right-hand side is currently being evaluated. *) +module CurrentVarEqConstrSys (S: EqConstrSys) = +struct + let current_var = ref None + + module S = + struct + include S + + let system x = + match S.system x with + | None -> None + | Some f -> + let f' get set = + let old_current_var = !current_var in + current_var := Some x; + Fun.protect ~finally:(fun () -> + current_var := old_current_var + ) (fun () -> + f get set + ) + in + Some f' + end +end diff --git a/src/constraint/constraint.mld b/src/constraint/constraint.mld new file mode 100644 index 0000000000..695e7bfa0d --- /dev/null +++ b/src/constraint/constraint.mld @@ -0,0 +1,16 @@ +{0 Library goblint.constraint} +This library is unwrapped and provides the following top-level modules. +For better context, see {!Goblint_lib} which also documents these modules. + + +{1 Framework} + +{2 Specification} +{!modules: +ConstrSys +} + +{2 Results} +{!modules: +VarQuery +} diff --git a/src/constraint/dune b/src/constraint/dune new file mode 100644 index 0000000000..2d11b9010f --- /dev/null +++ b/src/constraint/dune @@ -0,0 +1,21 @@ +(include_subdirs no) + +(library + (name goblint_constraint) + (public_name goblint.constraint) + (wrapped false) ; TODO: wrap + (libraries + batteries.unthreaded + goblint_std + goblint_common + goblint_domain + goblint-cil) + (flags :standard -open Goblint_std) + (preprocess + (pps + ppx_deriving.std + ppx_deriving_hash + ppx_deriving_yojson)) + (instrumentation (backend bisect_ppx))) + +(documentation) diff --git a/src/framework/varQuery.ml b/src/constraint/varQuery.ml similarity index 100% rename from src/framework/varQuery.ml rename to src/constraint/varQuery.ml diff --git a/src/framework/varQuery.mli b/src/constraint/varQuery.mli similarity index 100% rename from src/framework/varQuery.mli rename to src/constraint/varQuery.mli diff --git a/src/domains/boolDomain.ml b/src/domain/boolDomain.ml similarity index 69% rename from src/domains/boolDomain.ml rename to src/domain/boolDomain.ml index e088c3605c..d92d716d7a 100644 --- a/src/domains/boolDomain.ml +++ b/src/domain/boolDomain.ml @@ -4,10 +4,10 @@ module Bool = struct include Basetype.RawBools (* type t = bool - let equal = Bool.equal - let compare = Bool.compare - let relift x = x - let arbitrary () = QCheck.bool *) + let equal = Bool.equal + let compare = Bool.compare + let relift x = x + let arbitrary () = QCheck.bool *) let pretty_diff () (x,y) = GoblintCil.Pretty.dprintf "%s: %a not leq %a" (name ()) pretty x pretty y end @@ -38,4 +38,11 @@ struct let widen = (&&) let meet = (||) let narrow = (||) -end \ No newline at end of file +end + +module FlatBool: Lattice.S with type t = [`Bot | `Lifted of bool | `Top] = + Lattice.FlatConf (struct + include Printable.DefaultConf + let top_name = "?" + let bot_name = "-" + end) (Bool) diff --git a/src/domains/disjointDomain.ml b/src/domain/disjointDomain.ml similarity index 100% rename from src/domains/disjointDomain.ml rename to src/domain/disjointDomain.ml diff --git a/src/domain/domain.mld b/src/domain/domain.mld new file mode 100644 index 0000000000..ce7e1a5859 --- /dev/null +++ b/src/domain/domain.mld @@ -0,0 +1,21 @@ +{0 Library goblint.domain} +This library is unwrapped and provides the following top-level modules. +For better context, see {!Goblint_lib} which also documents these modules. + + +{1 Domains} +{!modules: +Lattice +} + +{2 General} +{!modules: +BoolDomain +SetDomain +MapDomain +TrieDomain +DisjointDomain +HoareDomain +PartitionDomain +FlagHelper +} diff --git a/src/domain/dune b/src/domain/dune new file mode 100644 index 0000000000..85e69a6246 --- /dev/null +++ b/src/domain/dune @@ -0,0 +1,20 @@ +(include_subdirs no) + +(library + (name goblint_domain) + (public_name goblint.domain) + (wrapped false) ; TODO: wrap + (libraries + batteries.unthreaded + goblint_std + goblint_common + goblint-cil) + (flags :standard -open Goblint_std) + (preprocess + (pps + ppx_deriving.std + ppx_deriving_hash + ppx_deriving_yojson)) + (instrumentation (backend bisect_ppx))) + +(documentation) diff --git a/src/domains/flagHelper.ml b/src/domain/flagHelper.ml similarity index 100% rename from src/domains/flagHelper.ml rename to src/domain/flagHelper.ml diff --git a/src/domains/hoareDomain.ml b/src/domain/hoareDomain.ml similarity index 97% rename from src/domains/hoareDomain.ml rename to src/domain/hoareDomain.ml index 23b1a92240..37b8231b92 100644 --- a/src/domains/hoareDomain.ml +++ b/src/domain/hoareDomain.ml @@ -134,13 +134,15 @@ struct let equal x y = leq x y && leq y x let hash xs = fold (fun v a -> a + E.hash v) xs 0 let compare x y = - if equal x y - then 0 + if equal x y then + 0 + else ( + let caridnality_comp = compare (cardinal x) (cardinal y) in + if caridnality_comp <> 0 then + caridnality_comp else - let caridnality_comp = compare (cardinal x) (cardinal y) in - if caridnality_comp <> 0 - then caridnality_comp - else Map.compare (List.compare E.compare) x y + Map.compare (List.compare E.compare) x y + ) let show x : string = let all_elems : string list = List.map E.show (elements x) in Printable.get_short_list "{" "}" all_elems @@ -234,8 +236,8 @@ struct ) s2 nil with Not_found -> dprintf "choose failed b/c of empty set s1: %d s2: %d" - (cardinal s1) - (cardinal s2) + (cardinal s1) + (cardinal s2) end end @@ -339,8 +341,8 @@ struct ) s2 nil with Not_found -> dprintf "choose failed b/c of empty set s1: %d s2: %d" - (cardinal s1) - (cardinal s2) + (cardinal s1) + (cardinal s2) end end [@@deprecated] diff --git a/src/common/domains/lattice.ml b/src/domain/lattice.ml similarity index 94% rename from src/common/domains/lattice.ml rename to src/domain/lattice.ml index 51306d637f..99322c09d8 100644 --- a/src/common/domains/lattice.ml +++ b/src/domain/lattice.ml @@ -148,18 +148,14 @@ struct end (* HAS SIDE-EFFECTS ---- PLEASE INSTANCIATE ONLY ONCE!!! *) -module HConsed (Base:S) = +module HConsed (Base:S) (Arg: sig val assume_idempotent: bool end) = struct include Printable.HConsed (Base) - (* We do refine int values on narrow and meet {!IntDomain.IntDomTupleImpl}, which can lead to fixpoint issues if we assume x op x = x *) - (* see https://github.com/goblint/analyzer/issues/1005 *) - let int_refine_active = GobConfig.get_string "ana.int.refinement" <> "never" - let lift_f2 f x y = f (unlift x) (unlift y) - let narrow x y = if (not int_refine_active) && x.BatHashcons.tag == y.BatHashcons.tag then x else lift (lift_f2 Base.narrow x y) + let narrow x y = if Arg.assume_idempotent && x.BatHashcons.tag == y.BatHashcons.tag then x else lift (lift_f2 Base.narrow x y) let widen x y = if x.BatHashcons.tag == y.BatHashcons.tag then x else lift (lift_f2 Base.widen x y) - let meet x y = if (not int_refine_active) && x.BatHashcons.tag == y.BatHashcons.tag then x else lift (lift_f2 Base.meet x y) + let meet x y = if Arg.assume_idempotent && x.BatHashcons.tag == y.BatHashcons.tag then x else lift (lift_f2 Base.meet x y) let join x y = if x.BatHashcons.tag == y.BatHashcons.tag then x else lift (lift_f2 Base.join x y) let leq x y = (x.BatHashcons.tag == y.BatHashcons.tag) || lift_f2 Base.leq x y let is_top = lift_f Base.is_top @@ -187,9 +183,9 @@ struct let pretty_diff () ((x:t),(y:t)): Pretty.doc = M.pretty_diff () (unlift x, unlift y) end -module Flat (Base: Printable.S) (N: Printable.LiftingNames) = +module FlatConf (Conf: Printable.LiftConf) (Base: Printable.S) = struct - include Printable.Lift (Base) (N) + include Printable.LiftConf (Conf) (Base) let bot () = `Bot let is_bot x = x = `Bot let top () = `Top @@ -231,10 +227,12 @@ struct end +module Flat = FlatConf (Printable.DefaultConf) + -module Lift (Base: S) (N: Printable.LiftingNames) = +module LiftConf (Conf: Printable.LiftConf) (Base: S) = struct - include Printable.Lift (Base) (N) + include Printable.LiftConf (Conf) (Base) let bot () = `Bot let is_bot x = x = `Bot @@ -282,9 +280,11 @@ struct | _ -> x end -module LiftPO (Base: PO) (N: Printable.LiftingNames) = +module Lift = LiftConf (Printable.DefaultConf) + +module LiftPO (Conf: Printable.LiftConf) (Base: PO) = struct - include Printable.Lift (Base) (N) + include Printable.LiftConf (Conf) (Base) let bot () = `Bot let is_bot x = x = `Bot @@ -340,9 +340,9 @@ struct | _ -> x end -module Lift2 (Base1: S) (Base2: S) (N: Printable.LiftingNames) = +module Lift2Conf (Conf: Printable.Lift2Conf) (Base1: S) (Base2: S) = struct - include Printable.Lift2 (Base1) (Base2) (N) + include Printable.Lift2Conf (Conf) (Base1) (Base2) let bot () = `Bot let is_bot x = x = `Bot @@ -412,6 +412,8 @@ struct end +module Lift2 = Lift2Conf (Printable.DefaultConf) + module ProdConf (C: Printable.ProdConfiguration) (Base1: S) (Base2: S) = struct include Printable.ProdConf (C) (Base1) (Base2) diff --git a/src/domains/mapDomain.ml b/src/domain/mapDomain.ml similarity index 99% rename from src/domains/mapDomain.ml rename to src/domain/mapDomain.ml index 76dec6f0d2..740da9969e 100644 --- a/src/domains/mapDomain.ml +++ b/src/domain/mapDomain.ml @@ -259,11 +259,12 @@ struct end (* TODO: this is very slow because every add/remove in a fold-loop relifts *) +(* TODO: currently hardcoded to assume_idempotent *) module HConsed (M: S) : S with type key = M.key and type value = M.value = struct - include Lattice.HConsed (M) + include Lattice.HConsed (M) (struct let assume_idempotent = false end) type key = M.key type value = M.value @@ -717,8 +718,8 @@ struct let singleton k v = `Lifted (M.singleton k v) let empty () = `Lifted (M.empty ()) let is_empty = function - | `Bot -> false - | `Lifted x -> M.is_empty x + | `Bot -> false + | `Lifted x -> M.is_empty x let exists f = function | `Bot -> raise (Fn_over_All "exists") | `Lifted x -> M.exists f x diff --git a/src/domains/partitionDomain.ml b/src/domain/partitionDomain.ml similarity index 100% rename from src/domains/partitionDomain.ml rename to src/domain/partitionDomain.ml diff --git a/src/domains/setDomain.ml b/src/domain/setDomain.ml similarity index 100% rename from src/domains/setDomain.ml rename to src/domain/setDomain.ml diff --git a/src/domains/trieDomain.ml b/src/domain/trieDomain.ml similarity index 100% rename from src/domains/trieDomain.ml rename to src/domain/trieDomain.ml diff --git a/src/domains/queries.ml b/src/domains/queries.ml index b9fa28f5be..24e5d45593 100644 --- a/src/domains/queries.ml +++ b/src/domains/queries.ml @@ -17,22 +17,17 @@ module TC = WrapperFunctionAnalysis0.ThreadCreateUniqueCount module ThreadNodeLattice = Lattice.Prod (NFL) (TC) module ML = LibraryDesc.MathLifted -module VI = Lattice.Flat (Basetype.Variables) (struct - let top_name = "Unknown line" - let bot_name = "Unreachable line" - end) +module VI = Lattice.Flat (Basetype.Variables) type iterprevvar = int -> (MyCFG.node * Obj.t * int) -> MyARG.inline_edge -> unit type itervar = int -> unit let compare_itervar _ _ = 0 let compare_iterprevvar _ _ = 0 -module FlatYojson = Lattice.Flat (Printable.Yojson) (struct - let top_name = "top yojson" - let bot_name = "bot yojson" - end) +module FlatYojson = Lattice.Flat (Printable.Yojson) -module SD = Basetype.Strings +module SD: Lattice.S with type t = [`Bot | `Lifted of string | `Top] = + Lattice.Flat (Basetype.RawStrings) module VD = ValueDomain.Compound module AD = ValueDomain.AD diff --git a/src/dune b/src/dune index acd5348acb..d7c6d28026 100644 --- a/src/dune +++ b/src/dune @@ -6,11 +6,15 @@ (library (name goblint_lib) (public_name goblint.lib) - (modules :standard \ goblint mainspec privPrecCompare apronPrecCompare messagesCompare) - (libraries goblint.sites goblint.build-info goblint-cil.all-features batteries.unthreaded qcheck-core.runner sha json-data-encoding jsonrpc cpu arg-complete fpath yaml yaml.unix uuidm goblint_timing catapult goblint_backtrace fileutils goblint_std goblint_common + (modules :standard \ goblint privPrecCompare apronPrecCompare messagesCompare) + (libraries goblint.sites goblint.build-info goblint-cil.all-features batteries.unthreaded qcheck-core.runner sha json-data-encoding jsonrpc cpu arg-complete fpath yaml yaml.unix uuidm goblint_timing catapult goblint_backtrace fileutils goblint_std goblint_config goblint_common goblint_domain goblint_constraint goblint_solver goblint_library goblint_cdomain_value goblint_incremental goblint_tracing ; Conditionally compile based on whether apron optional dependency is installed or not. ; Alternative dependencies seem like the only way to optionally depend on optional dependencies. ; See: https://dune.readthedocs.io/en/stable/concepts.html#alternative-dependencies. + (select gobApron.ml from + (apron -> gobApron.apron.ml) + (-> gobApron.no-apron.ml) + ) (select apronDomain.ml from (apron apron.octD apron.boxD apron.polkaMPQ zarith_mlgmpidl -> apronDomain.apron.ml) (-> apronDomain.no-apron.ml) @@ -57,7 +61,6 @@ ) ) (flags :standard -open Goblint_std) - (foreign_stubs (language c) (names stubs)) (ocamlopt_flags :standard -no-float-const-prop) (preprocess (pps ppx_deriving.std ppx_deriving_hash ppx_deriving_yojson ppx_blob)) @@ -73,10 +76,10 @@ (copy_files# witness/z3/*.ml) (executables - (names goblint mainspec) - (public_names goblint -) + (names goblint) + (public_names goblint) (modes byte native) ; https://dune.readthedocs.io/en/stable/dune-files.html#linking-modes - (modules goblint mainspec) + (modules goblint) (libraries goblint.lib goblint.sites.dune goblint.build-info.dune goblint_std) (preprocess (pps ppx_deriving.std ppx_deriving_hash ppx_deriving_yojson)) (flags :standard -linkall -open Goblint_std) diff --git a/src/framework/analyses.ml b/src/framework/analyses.ml index a37a3043c2..ca6cb9fd51 100644 --- a/src/framework/analyses.ml +++ b/src/framework/analyses.ml @@ -11,24 +11,6 @@ module M = Messages * other functions. *) type fundecs = fundec list * fundec list * fundec list -module type SysVar = -sig - type t - val is_write_only: t -> bool -end - -module type VarType = -sig - include Hashtbl.HashedType - include SysVar with type t := t - val pretty_trace: unit -> t -> doc - val compare : t -> t -> int - - val printXml : 'a BatInnerIO.output -> t -> unit - val var_id : t -> string - val node : t -> MyCFG.node - val relift : t -> t (* needed only for incremental+hashcons to re-hashcons contexts after loading *) -end module Var = struct @@ -69,12 +51,12 @@ end module type SpecSysVar = sig include Printable.S - include SysVar with type t := t + include ConstrSys.SysVar with type t := t end module GVarF (V: SpecSysVar) = struct - include Printable.Either (V) (CilType.Fundec) + include Printable.EitherConf (struct let expand1 = false let expand2 = true end) (V) (CilType.Fundec) let name () = "FromSpec" let spec x = `Left x let contexts x = `Right x @@ -90,7 +72,7 @@ end module GVarFC (V:SpecSysVar) (C:Printable.S) = struct - include Printable.Either (V) (Printable.Prod (CilType.Fundec) (C)) + include Printable.EitherConf (struct let expand1 = false let expand2 = true end) (V) (Printable.Prod (CilType.Fundec) (C)) let name () = "FromSpec" let spec x = `Left x let call (x, c) = `Right (x, c) @@ -117,7 +99,7 @@ struct let name () = "contexts" end - include Lattice.Lift2 (G) (CSet) (Printable.DefaultNames) + include Lattice.Lift2 (G) (CSet) let spec = function | `Bot -> G.bot () @@ -142,10 +124,11 @@ exception Deadcode (** [Dom (D)] produces D lifted where bottom means dead-code *) module Dom (LD: Lattice.S) = struct - include Lattice.Lift (LD) (struct + include Lattice.LiftConf (struct + include Printable.DefaultConf let bot_name = "Dead code" let top_name = "Totally unknown and messed up" - end) + end) (LD) let lift (x:LD.t) : t = `Lifted x @@ -155,189 +138,12 @@ struct | _ -> raise Deadcode let printXml f = function - | `Top -> BatPrintf.fprintf f "%s" (XmlUtil.escape top_name) + | `Top -> BatPrintf.fprintf f "%s" (XmlUtil.escape Printable.DefaultConf.top_name) | `Bot -> () | `Lifted x -> LD.printXml f x end -module ResultNode: Printable.S with type t = MyCFG.node = -struct - include Printable.Std - - include Node - - let name () = "resultnode" - - let show a = - (* Not using Node.location here to have updated locations in incremental analysis. - See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) - let x = UpdateCil.getLoc a in - let f = Node.find_fundec a in - CilType.Location.show x ^ "(" ^ f.svar.vname ^ ")" - - include Printable.SimpleShow ( - struct - type nonrec t = t - let show = show - end - ) -end - -module type ResultConf = -sig - val result_name: string -end - -module Result (Range: Printable.S) (C: ResultConf) = -struct - include Hashtbl.Make (ResultNode) - type nonrec t = Range.t t (* specialize polymorphic type for Range values *) - - let pretty () mapping = - let f key st dok = - dok ++ dprintf "%a ->@? @[%a@]\n" ResultNode.pretty key Range.pretty st - in - let content () = fold f mapping nil in - let defline () = dprintf "OTHERS -> Not available\n" in - dprintf "@[Mapping {\n @[%t%t@]}@]" content defline - - include C - - let printXml f xs = - let print_one n v = - (* Not using Node.location here to have updated locations in incremental analysis. - See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) - let loc = UpdateCil.getLoc n in - BatPrintf.fprintf f "\n" (Node.show_id n) loc.file loc.line loc.byte loc.column; - BatPrintf.fprintf f "%a\n" Range.printXml v - in - iter print_one xs - - let printJson f xs = - let print_one n v = - (* Not using Node.location here to have updated locations in incremental analysis. - See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) - let loc = UpdateCil.getLoc n in - BatPrintf.fprintf f "{\n\"id\": \"%s\", \"file\": \"%s\", \"line\": \"%d\", \"byte\": \"%d\", \"column\": \"%d\", \"states\": %s\n},\n" (Node.show_id n) loc.file loc.line loc.byte loc.column (Yojson.Safe.to_string (Range.to_yojson v)) - in - iter print_one xs - - let printXmlWarning f () = - let one_text f Messages.Piece.{loc; text = m; _} = - match loc with - | Some loc -> - let l = Messages.Location.to_cil loc in - BatPrintf.fprintf f "\n%s" l.file l.line l.column (XmlUtil.escape m) - | None -> - () (* TODO: not outputting warning without location *) - in - let one_w f (m: Messages.Message.t) = match m.multipiece with - | Single piece -> one_text f piece - | Group {group_text = n; pieces = e; group_loc} -> - let group_loc_text = match group_loc with - | None -> "" - | Some group_loc -> GobPretty.sprintf " (%a)" CilType.Location.pretty (Messages.Location.to_cil group_loc) - in - BatPrintf.fprintf f "%a\n" n group_loc_text (BatList.print ~first:"" ~last:"" ~sep:"" one_text) e - in - let one_w f x = BatPrintf.fprintf f "\n%a" one_w x in - List.iter (one_w f) !Messages.Table.messages_list - - let output table gtable gtfxml (file: file) = - let out = Messages.get_out result_name !Messages.out in - match get_string "result" with - | "pretty" -> ignore (fprintf out "%a\n" pretty (Lazy.force table)) - | "fast_xml" -> - let module SH = BatHashtbl.Make (Basetype.RawStrings) in - let file2funs = SH.create 100 in - let funs2node = SH.create 100 in - iter (fun n _ -> SH.add funs2node (Node.find_fundec n).svar.vname n) (Lazy.force table); - iterGlobals file (function - | GFun (fd,loc) -> SH.add file2funs loc.file fd.svar.vname - | _ -> () - ); - let p_node f n = BatPrintf.fprintf f "%s" (Node.show_id n) in - let p_nodes f xs = - List.iter (BatPrintf.fprintf f "\n" p_node) xs - in - let p_funs f xs = - let one_fun n = - BatPrintf.fprintf f "\n%a\n" n p_nodes (SH.find_all funs2node n) - in - List.iter one_fun xs - in - let write_file f fn = - Messages.xml_file_name := fn; - BatPrintf.printf "Writing xml to temp. file: %s\n%!" fn; - BatPrintf.fprintf f ""; - BatPrintf.fprintf f "%s" GobSys.command_line; - BatPrintf.fprintf f ""; - let timing_ppf = BatFormat.formatter_of_out_channel f in - Timing.Default.print timing_ppf; - Format.pp_print_flush timing_ppf (); - BatPrintf.fprintf f ""; - BatPrintf.fprintf f "\n"; - BatEnum.iter (fun b -> BatPrintf.fprintf f "\n%a\n" (Filename.basename b) b p_funs (SH.find_all file2funs b)) (BatEnum.uniq @@ SH.keys file2funs); - BatPrintf.fprintf f "%a" printXml (Lazy.force table); - gtfxml f gtable; - printXmlWarning f (); - BatPrintf.fprintf f "\n"; - BatPrintf.fprintf f "%!" - in - if get_bool "g2html" then - BatFile.with_temporary_out ~mode:[`create;`text;`delete_on_exit] write_file - else - let f = BatIO.output_channel out in - write_file f (get_string "outfile") - | "json" -> - let open BatPrintf in - let module SH = BatHashtbl.Make (Basetype.RawStrings) in - let file2funs = SH.create 100 in - let funs2node = SH.create 100 in - iter (fun n _ -> SH.add funs2node (Node.find_fundec n).svar.vname n) (Lazy.force table); - iterGlobals file (function - | GFun (fd,loc) -> SH.add file2funs loc.file fd.svar.vname - | _ -> () - ); - let p_enum p f xs = BatEnum.print ~first:"[\n " ~last:"\n]" ~sep:",\n " p f xs in - let p_list p f xs = BatList.print ~first:"[\n " ~last:"\n]" ~sep:",\n " p f xs in - (*let p_kv f (k,p,v) = fprintf f "\"%s\": %a" k p v in*) - (*let p_obj f xs = BatList.print ~first:"{\n " ~last:"\n}" ~sep:",\n " p_kv xs in*) - let p_node f n = BatPrintf.fprintf f "\"%s\"" (Node.show_id n) in - let p_fun f x = fprintf f "{\n \"name\": \"%s\",\n \"nodes\": %a\n}" x (p_list p_node) (SH.find_all funs2node x) in - (*let p_fun f x = p_obj f [ "name", BatString.print, x; "nodes", p_list p_node, SH.find_all funs2node x ] in*) - let p_file f x = fprintf f "{\n \"name\": \"%s\",\n \"path\": \"%s\",\n \"functions\": %a\n}" (Filename.basename x) x (p_list p_fun) (SH.find_all file2funs x) in - let write_file f fn = - printf "Writing json to temp. file: %s\n%!" fn; - fprintf f "{\n \"parameters\": \"%s\",\n " GobSys.command_line; - fprintf f "\"files\": %a,\n " (p_enum p_file) (SH.keys file2funs); - fprintf f "\"results\": [\n %a\n]\n" printJson (Lazy.force table); - (*gtfxml f gtable;*) - (*printXmlWarning f ();*) - fprintf f "}\n"; - in - if get_bool "g2html" then - BatFile.with_temporary_out ~mode:[`create;`text;`delete_on_exit] write_file - else - let f = BatIO.output_channel out in - write_file f (get_string "outfile") - | "sarif" -> - let open BatPrintf in - printf "Writing Sarif to file: %s\n%!" (get_string "outfile"); - Yojson.Safe.to_channel ~std:true out (Sarif.to_yojson (List.rev !Messages.Table.messages_list)); - | "json-messages" -> - let json = `Assoc [ - ("files", Preprocessor.dependencies_to_yojson ()); - ("messages", Messages.Table.to_yojson ()); - ] - in - Yojson.Safe.to_channel ~std:true out json - | "none" -> () - | s -> failwith @@ "Unsupported value for option `result`: "^s -end - - (* Experiment to reduce the number of arguments on transfer functions and allow sub-analyses. The list sub contains the current local states of analyses in the same order as written in the dependencies list (in MCP). @@ -494,119 +300,6 @@ type increment_data = { restarting: VarQuery.t list; } -(** Abstract incremental change to constraint system. - @param 'v constrain system variable type *) -type 'v sys_change_info = { - obsolete: 'v list; (** Variables to destabilize. *) - delete: 'v list; (** Variables to delete. *) - reluctant: 'v list; (** Variables to solve reluctantly. *) - restart: 'v list; (** Variables to restart. *) -} - -(** A side-effecting system. *) -module type MonSystem = -sig - type v (* variables *) - type d (* values *) - type 'a m (* basically a monad carrier *) - - (** Variables must be hashable, comparable, etc. *) - module Var : VarType with type t = v - - (** Values must form a lattice. *) - module Dom : Lattice.S with type t = d - - (** The system in functional form. *) - val system : v -> ((v -> d) -> (v -> d -> unit) -> d) m - - val sys_change: (v -> d) -> v sys_change_info - (** Compute incremental constraint system change from old solution. *) -end - -(** Any system of side-effecting equations over lattices. *) -module type EqConstrSys = MonSystem with type 'a m := 'a option - -(** A side-effecting system with globals. *) -module type GlobConstrSys = -sig - module LVar : VarType - module GVar : VarType - - module D : Lattice.S - module G : Lattice.S - val system : LVar.t -> ((LVar.t -> D.t) -> (LVar.t -> D.t -> unit) -> (GVar.t -> G.t) -> (GVar.t -> G.t -> unit) -> D.t) option - val iter_vars: (LVar.t -> D.t) -> (GVar.t -> G.t) -> VarQuery.t -> LVar.t VarQuery.f -> GVar.t VarQuery.f -> unit - val sys_change: (LVar.t -> D.t) -> (GVar.t -> G.t) -> [`L of LVar.t | `G of GVar.t] sys_change_info -end - -(** A solver is something that can translate a system into a solution (hash-table). - Incremental solver has data to be marshaled. *) -module type GenericEqIncrSolverBase = - functor (S:EqConstrSys) -> - functor (H:Hashtbl.S with type key=S.v) -> - sig - type marshal - - val copy_marshal: marshal -> marshal - val relift_marshal: marshal -> marshal - - (** The hash-map that is the first component of [solve xs vs] is a local solution for interesting variables [vs], - reached from starting values [xs]. - As a second component the solver returns data structures for incremental serialization. *) - val solve : (S.v*S.d) list -> S.v list -> marshal option -> S.d H.t * marshal - end - -(** (Incremental) solver argument, indicating which postsolving should be performed by the solver. *) -module type IncrSolverArg = -sig - val should_prune: bool - val should_verify: bool - val should_warn: bool - val should_save_run: bool -end - -(** An incremental solver takes the argument about postsolving. *) -module type GenericEqIncrSolver = - functor (Arg: IncrSolverArg) -> - GenericEqIncrSolverBase - -(** A solver is something that can translate a system into a solution (hash-table) *) -module type GenericEqSolver = - functor (S:EqConstrSys) -> - functor (H:Hashtbl.S with type key=S.v) -> - sig - (** The hash-map that is the first component of [solve xs vs] is a local solution for interesting variables [vs], - reached from starting values [xs]. *) - val solve : (S.v*S.d) list -> S.v list -> S.d H.t - end - -(** A solver is something that can translate a system into a solution (hash-table) *) -module type GenericGlobSolver = - functor (S:GlobConstrSys) -> - functor (LH:Hashtbl.S with type key=S.LVar.t) -> - functor (GH:Hashtbl.S with type key=S.GVar.t) -> - sig - type marshal - - val copy_marshal: marshal -> marshal - val relift_marshal: marshal -> marshal - - (** The hash-map that is the first component of [solve xs vs] is a local solution for interesting variables [vs], - reached from starting values [xs]. - As a second component the solver returns data structures for incremental serialization. *) - val solve : (S.LVar.t*S.D.t) list -> (S.GVar.t*S.G.t) list -> S.LVar.t list -> marshal option -> (S.D.t LH.t * S.G.t GH.t) * marshal - end - -module ResultType2 (S:Spec) = -struct - open S - include Printable.Prod3 (C) (D) (CilType.Fundec) - let show (es,x,f:t) = D.show x - let pretty () (_,x,_) = D.pretty () x - let printXml f (c,d,fd) = - BatPrintf.fprintf f "\n%a\n%a" C.printXml c D.printXml d -end - module StdV = struct let is_write_only _ = false @@ -727,7 +420,7 @@ end module type SpecSys = sig module Spec: Spec - module EQSys: GlobConstrSys with module LVar = VarF (Spec.C) + module EQSys: ConstrSys.GlobConstrSys with module LVar = VarF (Spec.C) and module GVar = GVarF (Spec.V) and module D = Spec.D and module G = GVarG (Spec.G) (Spec.C) diff --git a/src/framework/analysisResult.ml b/src/framework/analysisResult.ml new file mode 100644 index 0000000000..09ece868c1 --- /dev/null +++ b/src/framework/analysisResult.ml @@ -0,0 +1,191 @@ +(** Analysis result output. *) + +open GoblintCil +open Pretty +open GobConfig + +module ResultNode: Printable.S with type t = MyCFG.node = +struct + include Printable.Std + + include Node + + let name () = "resultnode" + + let show a = + (* Not using Node.location here to have updated locations in incremental analysis. + See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) + let x = UpdateCil.getLoc a in + let f = Node.find_fundec a in + CilType.Location.show x ^ "(" ^ f.svar.vname ^ ")" + + include Printable.SimpleShow ( + struct + type nonrec t = t + let show = show + end + ) +end + +module type ResultConf = +sig + val result_name: string +end + +module Result (Range: Printable.S) (C: ResultConf) = +struct + include BatHashtbl.Make (ResultNode) + type nonrec t = Range.t t (* specialize polymorphic type for Range values *) + + let pretty () mapping = + let f key st dok = + dok ++ dprintf "%a ->@? @[%a@]\n" ResultNode.pretty key Range.pretty st + in + let content () = fold f mapping nil in + let defline () = dprintf "OTHERS -> Not available\n" in + dprintf "@[Mapping {\n @[%t%t@]}@]" content defline + + include C + + let printXml f xs = + let print_one n v = + (* Not using Node.location here to have updated locations in incremental analysis. + See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) + let loc = UpdateCil.getLoc n in + BatPrintf.fprintf f "\n" (Node.show_id n) loc.file loc.line loc.byte loc.column; + BatPrintf.fprintf f "%a\n" Range.printXml v + in + iter print_one xs + + let printJson f xs = + let print_one n v = + (* Not using Node.location here to have updated locations in incremental analysis. + See: https://github.com/goblint/analyzer/issues/290#issuecomment-881258091. *) + let loc = UpdateCil.getLoc n in + BatPrintf.fprintf f "{\n\"id\": \"%s\", \"file\": \"%s\", \"line\": \"%d\", \"byte\": \"%d\", \"column\": \"%d\", \"states\": %s\n},\n" (Node.show_id n) loc.file loc.line loc.byte loc.column (Yojson.Safe.to_string (Range.to_yojson v)) + in + iter print_one xs + + let printXmlWarning f () = + let one_text f Messages.Piece.{loc; text = m; _} = + match loc with + | Some loc -> + let l = Messages.Location.to_cil loc in + BatPrintf.fprintf f "\n%s" l.file l.line l.column (XmlUtil.escape m) + | None -> + () (* TODO: not outputting warning without location *) + in + let one_w f (m: Messages.Message.t) = match m.multipiece with + | Single piece -> one_text f piece + | Group {group_text = n; pieces = e; group_loc} -> + let group_loc_text = match group_loc with + | None -> "" + | Some group_loc -> GobPretty.sprintf " (%a)" CilType.Location.pretty (Messages.Location.to_cil group_loc) + in + BatPrintf.fprintf f "%a\n" n group_loc_text (BatList.print ~first:"" ~last:"" ~sep:"" one_text) e + in + let one_w f x = BatPrintf.fprintf f "\n%a" one_w x in + List.iter (one_w f) !Messages.Table.messages_list + + let output table gtable gtfxml (file: file) = + let out = Messages.get_out result_name !Messages.out in + match get_string "result" with + | "pretty" -> ignore (fprintf out "%a\n" pretty (Lazy.force table)) + | "fast_xml" -> + let module SH = BatHashtbl.Make (Basetype.RawStrings) in + let file2funs = SH.create 100 in + let funs2node = SH.create 100 in + iter (fun n _ -> SH.add funs2node (Node.find_fundec n).svar.vname n) (Lazy.force table); + iterGlobals file (function + | GFun (fd,loc) -> SH.add file2funs loc.file fd.svar.vname + | _ -> () + ); + let p_node f n = BatPrintf.fprintf f "%s" (Node.show_id n) in + let p_nodes f xs = + List.iter (BatPrintf.fprintf f "\n" p_node) xs + in + let p_funs f xs = + let one_fun n = + BatPrintf.fprintf f "\n%a\n" n p_nodes (SH.find_all funs2node n) + in + List.iter one_fun xs + in + let write_file f fn = + Messages.xml_file_name := fn; + BatPrintf.printf "Writing xml to temp. file: %s\n%!" fn; + BatPrintf.fprintf f ""; + BatPrintf.fprintf f "%s" GobSys.command_line; + BatPrintf.fprintf f ""; + let timing_ppf = BatFormat.formatter_of_out_channel f in + Timing.Default.print timing_ppf; + Format.pp_print_flush timing_ppf (); + BatPrintf.fprintf f ""; + BatPrintf.fprintf f "\n"; + BatEnum.iter (fun b -> BatPrintf.fprintf f "\n%a\n" (Filename.basename b) b p_funs (SH.find_all file2funs b)) (BatEnum.uniq @@ SH.keys file2funs); + BatPrintf.fprintf f "%a" printXml (Lazy.force table); + gtfxml f gtable; + printXmlWarning f (); + BatPrintf.fprintf f "\n"; + BatPrintf.fprintf f "%!" + in + if get_bool "g2html" then + BatFile.with_temporary_out ~mode:[`create;`text;`delete_on_exit] write_file + else + let f = BatIO.output_channel out in + write_file f (get_string "outfile") + | "json" -> + let open BatPrintf in + let module SH = BatHashtbl.Make (Basetype.RawStrings) in + let file2funs = SH.create 100 in + let funs2node = SH.create 100 in + iter (fun n _ -> SH.add funs2node (Node.find_fundec n).svar.vname n) (Lazy.force table); + iterGlobals file (function + | GFun (fd,loc) -> SH.add file2funs loc.file fd.svar.vname + | _ -> () + ); + let p_enum p f xs = BatEnum.print ~first:"[\n " ~last:"\n]" ~sep:",\n " p f xs in + let p_list p f xs = BatList.print ~first:"[\n " ~last:"\n]" ~sep:",\n " p f xs in + (*let p_kv f (k,p,v) = fprintf f "\"%s\": %a" k p v in*) + (*let p_obj f xs = BatList.print ~first:"{\n " ~last:"\n}" ~sep:",\n " p_kv xs in*) + let p_node f n = BatPrintf.fprintf f "\"%s\"" (Node.show_id n) in + let p_fun f x = fprintf f "{\n \"name\": \"%s\",\n \"nodes\": %a\n}" x (p_list p_node) (SH.find_all funs2node x) in + (*let p_fun f x = p_obj f [ "name", BatString.print, x; "nodes", p_list p_node, SH.find_all funs2node x ] in*) + let p_file f x = fprintf f "{\n \"name\": \"%s\",\n \"path\": \"%s\",\n \"functions\": %a\n}" (Filename.basename x) x (p_list p_fun) (SH.find_all file2funs x) in + let write_file f fn = + printf "Writing json to temp. file: %s\n%!" fn; + fprintf f "{\n \"parameters\": \"%s\",\n " GobSys.command_line; + fprintf f "\"files\": %a,\n " (p_enum p_file) (SH.keys file2funs); + fprintf f "\"results\": [\n %a\n]\n" printJson (Lazy.force table); + (*gtfxml f gtable;*) + (*printXmlWarning f ();*) + fprintf f "}\n"; + in + if get_bool "g2html" then + BatFile.with_temporary_out ~mode:[`create;`text;`delete_on_exit] write_file + else + let f = BatIO.output_channel out in + write_file f (get_string "outfile") + | "sarif" -> + let open BatPrintf in + printf "Writing Sarif to file: %s\n%!" (get_string "outfile"); + Yojson.Safe.to_channel ~std:true out (Sarif.to_yojson (List.rev !Messages.Table.messages_list)); + | "json-messages" -> + let json = `Assoc [ + ("files", Preprocessor.dependencies_to_yojson ()); + ("messages", Messages.Table.to_yojson ()); + ] + in + Yojson.Safe.to_channel ~std:true out json + | "none" -> () + | s -> failwith @@ "Unsupported value for option `result`: "^s +end + +module ResultType2 (S: Analyses.Spec) = +struct + open S + include Printable.Prod3 (C) (D) (CilType.Fundec) + let show (es,x,f:t) = D.show x + let pretty () (_,x,_) = D.pretty () x + let printXml f (c,d,fd) = + BatPrintf.fprintf f "\n%a\n%a" C.printXml c D.printXml d +end diff --git a/src/framework/constraints.ml b/src/framework/constraints.ml index b1bbc73660..f5c024c24f 100644 --- a/src/framework/constraints.ml +++ b/src/framework/constraints.ml @@ -5,6 +5,7 @@ open Batteries open GoblintCil open MyCFG open Analyses +open ConstrSys open GobConfig module M = Messages @@ -12,12 +13,17 @@ module M = Messages (** Lifts a [Spec] so that the domain is [Hashcons]d *) module HashconsLifter (S:Spec) - : Spec with module D = Lattice.HConsed (S.D) - and module G = S.G + : Spec with module G = S.G and module C = S.C = struct - module D = Lattice.HConsed (S.D) + module HConsedArg = + struct + (* We do refine int values on narrow and meet {!IntDomain.IntDomTupleImpl}, which can lead to fixpoint issues if we assume x op x = x *) + (* see https://github.com/goblint/analyzer/issues/1005 *) + let assume_idempotent = GobConfig.get_string "ana.int.refinement" = "never" + end + module D = Lattice.HConsed (S.D) (HConsedArg) module G = S.G module C = S.C module V = S.V @@ -496,38 +502,6 @@ sig val increment: increment_data option end -(** Combined variables so that we can also use the more common [EqConstrSys] - that uses only one kind of a variable. *) -module Var2 (LV:VarType) (GV:VarType) - : VarType - with type t = [ `L of LV.t | `G of GV.t ] -= -struct - type t = [ `L of LV.t | `G of GV.t ] [@@deriving eq, ord, hash] - let relift = function - | `L x -> `L (LV.relift x) - | `G x -> `G (GV.relift x) - - let pretty_trace () = function - | `L a -> Pretty.dprintf "L:%a" LV.pretty_trace a - | `G a -> Pretty.dprintf "G:%a" GV.pretty_trace a - - let printXml f = function - | `L a -> LV.printXml f a - | `G a -> GV.printXml f a - - let var_id = function - | `L a -> LV.var_id a - | `G a -> GV.var_id a - - let node = function - | `L a -> LV.node a - | `G a -> GV.node a - - let is_write_only = function - | `L a -> LV.is_write_only a - | `G a -> GV.is_write_only a -end (** The main point of this file---generating a [GlobConstrSys] from a [Spec]. *) module FromSpec (S:Spec) (Cfg:CfgBackward) (I: Increment) @@ -820,13 +794,13 @@ struct ) let tf var getl sidel getg sideg prev_node (_,edge) d (f,t) = - let old_loc = !Tracing.current_loc in - let old_loc2 = !Tracing.next_loc in - Tracing.current_loc := f; - Tracing.next_loc := t; + let old_loc = !Goblint_tracing.current_loc in + let old_loc2 = !Goblint_tracing.next_loc in + Goblint_tracing.current_loc := f; + Goblint_tracing.next_loc := t; Goblint_backtrace.protect ~mark:(fun () -> TfLocation f) ~finally:(fun () -> - Tracing.current_loc := old_loc; - Tracing.next_loc := old_loc2 + Goblint_tracing.current_loc := old_loc; + Goblint_tracing.next_loc := old_loc2 ) (fun () -> let d = tf var getl sidel getg sideg prev_node edge d in d @@ -999,7 +973,7 @@ struct let dummy_pseudo_return_node f = (* not the same as in CFG, but compares equal because of sid *) - Node.Statement ({Cil.dummyStmt with sid = CfgTools.get_pseudo_return_id f}) + Node.Statement ({Cil.dummyStmt with sid = Cilfacade.get_pseudo_return_id f}) in let add_nodes_of_fun (functions: fundec list) (withEntry: fundec -> bool) = let add_stmts (f: fundec) = @@ -1048,137 +1022,6 @@ struct {obsolete; delete; reluctant; restart} end -(** Convert a non-incremental solver into an "incremental" solver. - It will solve from scratch, perform standard postsolving and have no marshal data. *) -module EqIncrSolverFromEqSolver (Sol: GenericEqSolver): GenericEqIncrSolver = - functor (Arg: IncrSolverArg) (S: EqConstrSys) (VH: Hashtbl.S with type key = S.v) -> - struct - module Sol = Sol (S) (VH) - module Post = PostSolver.MakeList (PostSolver.ListArgFromStdArg (S) (VH) (Arg)) - - type marshal = unit - let copy_marshal () = () - let relift_marshal () = () - - let solve xs vs _ = - let vh = Sol.solve xs vs in - Post.post xs vs vh; - (vh, ()) - end - - -(** Translate a [GlobConstrSys] into a [EqConstrSys] *) -module EqConstrSysFromGlobConstrSys (S:GlobConstrSys) - : EqConstrSys with type v = Var2(S.LVar)(S.GVar).t - and type d = Lattice.Lift2(S.G)(S.D)(Printable.DefaultNames).t - and module Var = Var2(S.LVar)(S.GVar) - and module Dom = Lattice.Lift2(S.G)(S.D)(Printable.DefaultNames) -= -struct - module Var = Var2(S.LVar)(S.GVar) - module Dom = - struct - include Lattice.Lift2(S.G)(S.D)(Printable.DefaultNames) - let printXml f = function - | `Lifted1 a -> S.G.printXml f a - | `Lifted2 a -> S.D.printXml f a - | (`Bot | `Top) as x -> printXml f x - end - type v = Var.t - type d = Dom.t - - let getG = function - | `Lifted1 x -> x - | `Bot -> S.G.bot () - | `Top -> failwith "EqConstrSysFromGlobConstrSys.getG: global variable has top value" - | `Lifted2 _ -> failwith "EqConstrSysFromGlobConstrSys.getG: global variable has local value" - - let getL = function - | `Lifted2 x -> x - | `Bot -> S.D.bot () - | `Top -> failwith "EqConstrSysFromGlobConstrSys.getL: local variable has top value" - | `Lifted1 _ -> failwith "EqConstrSysFromGlobConstrSys.getL: local variable has global value" - - let l, g = (fun x -> `L x), (fun x -> `G x) - let lD, gD = (fun x -> `Lifted2 x), (fun x -> `Lifted1 x) - - let conv f get set = - f (getL % get % l) (fun x v -> set (l x) (lD v)) - (getG % get % g) (fun x v -> set (g x) (gD v)) - |> lD - - let system = function - | `G _ -> None - | `L x -> Option.map conv (S.system x) - - let sys_change get = - S.sys_change (getL % get % l) (getG % get % g) -end - -(** Splits a [EqConstrSys] solution into a [GlobConstrSys] solution with given [Hashtbl.S] for the [EqConstrSys]. *) -module GlobConstrSolFromEqConstrSolBase (S: GlobConstrSys) (LH: Hashtbl.S with type key = S.LVar.t) (GH: Hashtbl.S with type key = S.GVar.t) (VH: Hashtbl.S with type key = Var2 (S.LVar) (S.GVar).t) = -struct - let split_solution hm = - let l' = LH.create 113 in - let g' = GH.create 113 in - let split_vars x d = match x with - | `L x -> - begin match d with - | `Lifted2 d -> LH.replace l' x d - (* | `Bot -> () *) - (* Since Verify2 is broken and only checks existing keys, add it with local bottom value. - This works around some cases, where Verify2 would not detect a problem due to completely missing variable. *) - | `Bot -> LH.replace l' x (S.D.bot ()) - | `Top -> failwith "GlobConstrSolFromEqConstrSolBase.split_vars: local variable has top value" - | `Lifted1 _ -> failwith "GlobConstrSolFromEqConstrSolBase.split_vars: local variable has global value" - end - | `G x -> - begin match d with - | `Lifted1 d -> GH.replace g' x d - | `Bot -> () - | `Top -> failwith "GlobConstrSolFromEqConstrSolBase.split_vars: global variable has top value" - | `Lifted2 _ -> failwith "GlobConstrSolFromEqConstrSolBase.split_vars: global variable has local value" - end - in - VH.iter split_vars hm; - (l', g') -end - -(** Splits a [EqConstrSys] solution into a [GlobConstrSys] solution. *) -module GlobConstrSolFromEqConstrSol (S: GlobConstrSys) (LH: Hashtbl.S with type key = S.LVar.t) (GH: Hashtbl.S with type key = S.GVar.t) = -struct - module S2 = EqConstrSysFromGlobConstrSys (S) - module VH = Hashtbl.Make (S2.Var) - - include GlobConstrSolFromEqConstrSolBase (S) (LH) (GH) (VH) -end - -(** Transforms a [GenericEqIncrSolver] into a [GenericGlobSolver]. *) -module GlobSolverFromEqSolver (Sol:GenericEqIncrSolverBase) - = functor (S:GlobConstrSys) -> - functor (LH:Hashtbl.S with type key=S.LVar.t) -> - functor (GH:Hashtbl.S with type key=S.GVar.t) -> - struct - module EqSys = EqConstrSysFromGlobConstrSys (S) - - module VH : Hashtbl.S with type key=EqSys.v = Hashtbl.Make(EqSys.Var) - module Sol' = Sol (EqSys) (VH) - - module Splitter = GlobConstrSolFromEqConstrSolBase (S) (LH) (GH) (VH) (* reuse EqSys and VH *) - - type marshal = Sol'.marshal - - let copy_marshal = Sol'.copy_marshal - let relift_marshal = Sol'.relift_marshal - - let solve ls gs l old_data = - let vs = List.map (fun (x,v) -> `L x, `Lifted2 v) ls - @ List.map (fun (x,v) -> `G x, `Lifted1 v) gs in - let sv = List.map (fun x -> `L x) l in - let hm, solver_data = Sol'.solve vs sv old_data in - Splitter.split_solution hm, solver_data - end - (** Add path sensitivity to a analysis *) module PathSensitive2 (Spec:Spec) @@ -1333,7 +1176,7 @@ struct module V = struct - include Printable.Either (S.V) (Node) + include Printable.EitherConf (struct let expand1 = false let expand2 = true end) (S.V) (Node) let name () = "DeadBranch" let s x = `Left x let node x = `Right x @@ -1344,13 +1187,13 @@ struct module EM = struct - include MapDomain.MapBot (Basetype.CilExp) (Basetype.Bools) + include MapDomain.MapBot (Basetype.CilExp) (BoolDomain.FlatBool) let name () = "branches" end module G = struct - include Lattice.Lift2 (S.G) (EM) (Printable.DefaultNames) + include Lattice.Lift2 (S.G) (EM) let name () = "deadbranch" let s = function @@ -1467,19 +1310,19 @@ struct module V = struct - include Printable.Either (S.V) (Printable.Either (Printable.Prod (Node) (C)) (Printable.Prod (CilType.Fundec) (C))) + include Printable.Either3Conf (struct let expand1 = false let expand2 = true let expand3 = true end) (S.V) (Printable.Prod (Node) (C)) (Printable.Prod (CilType.Fundec) (C)) let name () = "longjmp" let s x = `Left x - let longjmpto x = `Right (`Left x) - let longjmpret x = `Right (`Right x) + let longjmpto x = `Middle x + let longjmpret x = `Right x let is_write_only = function | `Left x -> S.V.is_write_only x - | `Right _ -> false + | _ -> false end module G = struct - include Lattice.Lift2 (S.G) (S.D) (Printable.DefaultNames) + include Lattice.Lift2 (S.G) (S.D) let s = function | `Bot -> S.G.bot () @@ -1511,7 +1354,7 @@ struct begin match g with | `Left g -> S.query (conv ctx) (WarnGlobal (Obj.repr g)) - | `Right g -> + | _ -> Queries.Result.top q end | InvariantGlobal g -> @@ -1519,7 +1362,7 @@ struct begin match g with | `Left g -> S.query (conv ctx) (InvariantGlobal (Obj.repr g)) - | `Right g -> + | _ -> Queries.Result.top q end | IterSysVars (vq, vf) -> @@ -1732,7 +1575,7 @@ struct module G = struct - include Lattice.Lift2 (G) (CallerSet) (Printable.DefaultNames) + include Lattice.Lift2 (G) (CallerSet) let spec = function | `Bot -> G.bot () @@ -2051,29 +1894,3 @@ struct ignore (Pretty.printf "Nodes comparison summary: %t\n" (fun () -> msg)); print_newline (); end - -(** [EqConstrSys] where [current_var] indicates the variable whose right-hand side is currently being evaluated. *) -module CurrentVarEqConstrSys (S: EqConstrSys) = -struct - let current_var = ref None - - module S = - struct - include S - - let system x = - match S.system x with - | None -> None - | Some f -> - let f' get set = - let old_current_var = !current_var in - current_var := Some x; - Fun.protect ~finally:(fun () -> - current_var := old_current_var - ) (fun () -> - f get set - ) - in - Some f' - end -end diff --git a/src/framework/control.ml b/src/framework/control.ml index 0c9b61739b..391c766feb 100644 --- a/src/framework/control.ml +++ b/src/framework/control.ml @@ -6,6 +6,7 @@ open Batteries open GoblintCil open MyCFG open Analyses +open ConstrSys open GobConfig open Constraints @@ -84,16 +85,16 @@ struct let save_run = let o = get_string "save_run" in if o = "" then (if gobview then "run" else "") else o in save_run <> "" end - module Slvr = (GlobSolverFromEqSolver (Selector.Make (PostSolverArg))) (EQSys) (LHT) (GHT) + module Slvr = (GlobSolverFromEqSolver (Goblint_solver.Selector.Make (PostSolverArg))) (EQSys) (LHT) (GHT) (* The comparator *) module CompareGlobSys = Constraints.CompareGlobSys (SpecSys) (* Triple of the function, context, and the local value. *) - module RT = Analyses.ResultType2 (Spec) + module RT = AnalysisResult.ResultType2 (Spec) (* Set of triples [RT] *) module LT = SetDomain.HeadlessSet (RT) (* Analysis result structure---a hashtable from program points to [LT] *) - module Result = Analyses.Result (LT) (struct let result_name = "analysis" end) + module Result = AnalysisResult.Result (LT) (struct let result_name = "analysis" end) module Query = ResultQuery.Query (SpecSys) @@ -142,12 +143,12 @@ struct if List.mem "termination" @@ get_string_list "ana.activated" then ( (* check if we have upjumping gotos *) let open Cilfacade in - let warn_for_upjumps fundec gotos = + let warn_for_upjumps fundec gotos = if FunSet.mem live_funs fundec then ( (* set nortermiantion flag *) AnalysisState.svcomp_may_not_terminate := true; (* iterate through locations to produce warnings *) - LocSet.iter (fun l _ -> + LocSet.iter (fun l _ -> M.warn ~loc:(M.Location.CilLocation l) ~category:Termination "The program might not terminate! (Upjumping Goto)" ) gotos ) @@ -313,7 +314,7 @@ struct if M.tracing then M.trace "con" "Initializer %a\n" CilType.Location.pretty loc; (*incr count; if (get_bool "dbg.verbose")&& (!count mod 1000 = 0) then Printf.printf "%d %!" !count; *) - Tracing.current_loc := loc; + Goblint_tracing.current_loc := loc; match edge with | MyCFG.Entry func -> if M.tracing then M.trace "global_inits" "Entry %a\n" d_lval (var func.svar); @@ -335,9 +336,9 @@ struct in let with_externs = do_extern_inits ctx file in (*if (get_bool "dbg.verbose") then Printf.printf "Number of init. edges : %d\nWorking:" (List.length edges); *) - let old_loc = !Tracing.current_loc in + let old_loc = !Goblint_tracing.current_loc in let result : Spec.D.t = List.fold_left transfer_func with_externs edges in - Tracing.current_loc := old_loc; + Goblint_tracing.current_loc := old_loc; if M.tracing then M.trace "global_inits" "startstate: %a\n" Spec.D.pretty result; result, !funs in @@ -475,7 +476,7 @@ struct let save_run_str = let o = get_string "save_run" in if o = "" then (if gobview then "run" else "") else o in let lh, gh = if load_run <> "" then ( - let module S2' = (GlobSolverFromEqSolver (Generic.LoadRunIncrSolver (PostSolverArg))) (EQSys) (LHT) (GHT) in + let module S2' = (GlobSolverFromEqSolver (Goblint_solver.Generic.LoadRunIncrSolver (PostSolverArg))) (EQSys) (LHT) (GHT) in let (r2, _) = S2'.solve entrystates entrystates_global startvars' None in (* TODO: has incremental data? *) r2 ) else if compare_runs <> [] then ( @@ -581,7 +582,7 @@ struct let (r2, _) = S2'.solve entrystates entrystates_global startvars' None in (* TODO: has incremental data? *) CompareGlobSys.compare (get_string "solver", get_string "comparesolver") (lh,gh) (r2) in - compare_with (Selector.choose_solver (get_string "comparesolver")) + compare_with (Goblint_solver.Selector.choose_solver (get_string "comparesolver")) ); (* Most warnings happen before during postsolver, but some happen later (e.g. in finalize), so enable this for the rest (if required by option). *) diff --git a/src/goblint_lib.ml b/src/goblint_lib.ml index 70f331b5ac..1bc70f3f52 100644 --- a/src/goblint_lib.ml +++ b/src/goblint_lib.ml @@ -21,6 +21,7 @@ module CfgTools = CfgTools A dynamic composition of analyses is combined with CFGs to produce a constraint system. *) module Analyses = Analyses +module ConstrSys = ConstrSys module Constraints = Constraints module AnalysisState = AnalysisState module AnalysisStateUtil = AnalysisStateUtil @@ -45,13 +46,14 @@ module Events = Events The following modules help query the constraint system solution using semantic information. *) +module AnalysisResult = AnalysisResult module ResultQuery = ResultQuery module VarQuery = VarQuery (** {2 Configuration} Runtime configuration is represented as JSON. - Options are specified and documented by the JSON schema [src/common/util/options.schema.json]. *) + Options are specified and documented by the JSON schema [src/config/options.schema.json]. *) module GobConfig = GobConfig module AfterConfig = AfterConfig @@ -130,7 +132,7 @@ module ExtractPthread = ExtractPthread Analyses related to [longjmp] and [setjmp]. *) module ActiveSetjmp = ActiveSetjmp -module ModifiedSinceLongjmp = ModifiedSinceLongjmp +module ModifiedSinceSetjmp = ModifiedSinceSetjmp module ActiveLongjmp = ActiveLongjmp module PoisonVariables = PoisonVariables module Vla = Vla @@ -147,12 +149,10 @@ module UnitAnalysis = UnitAnalysis (** {2 Other} *) module Assert = Assert -module FileUse = FileUse module LoopTermination = LoopTermination module Uninit = Uninit module Expsplit = Expsplit module StackTrace = StackTrace -module Spec = Spec (** {2 Helper} @@ -221,6 +221,7 @@ module AddressDomain = AddressDomain module StructDomain = StructDomain module UnionDomain = UnionDomain module ArrayDomain = ArrayDomain +module NullByteSet = NullByteSet module JmpBufDomain = JmpBufDomain (** {5 Combined} @@ -263,12 +264,8 @@ module AccessDomain = AccessDomain module MusteqDomain = MusteqDomain module RegionDomain = RegionDomain -module FileDomain = FileDomain module StackDomain = StackDomain -module MvalMapDomain = MvalMapDomain -module SpecDomain = SpecDomain - (** {2 Testing} Modules related to (property-based) testing of domains. *) @@ -291,47 +288,11 @@ module Serialize = Serialize module CilMaps = CilMaps -(** {1 Solvers} - - Generic solvers are used to solve {{!Analyses.MonSystem} (side-effecting) constraint systems}. *) - -(** {2 Top-down} - - The top-down solver family. *) - -module Td3 = Td3 -module TopDown = TopDown -module TopDown_term = TopDown_term -module TopDown_space_cache_term = TopDown_space_cache_term -module TopDown_deprecated = TopDown_deprecated - -(** {2 SLR} - - The SLR solver family. *) - -module SLRphased = SLRphased -module SLRterm = SLRterm -module SLR = SLR - -(** {2 Other} *) - -module EffectWConEq = EffectWConEq -module Worklist = Worklist -module Generic = Generic -module Selector = Selector - -module PostSolver = PostSolver -module LocalFixpoint = LocalFixpoint -module SolverStats = SolverStats -module SolverBox = SolverBox - - (** {1 I/O} Various input/output interfaces and formats. *) module Messages = Messages -module Tracing = Tracing (** {2 Front-end} @@ -447,6 +408,7 @@ module WideningThresholds = WideningThresholds module VectorMatrix = VectorMatrix module SharedFunctions = SharedFunctions +module GobApron = GobApron (** {2 Precision comparison} *) @@ -467,9 +429,3 @@ module ApronPrecCompareUtil = ApronPrecCompareUtil OCaml standard library extensions which are not provided by {!Batteries}. *) module GobFormat = GobFormat - -(** {2 Other libraries} - - External library extensions. *) - -module MyCheck = MyCheck diff --git a/src/util/cilMaps.ml b/src/incremental/cilMaps.ml similarity index 100% rename from src/util/cilMaps.ml rename to src/incremental/cilMaps.ml diff --git a/src/incremental/compareCFG.ml b/src/incremental/compareCFG.ml index 225cbb1c76..55b3fa8fc5 100644 --- a/src/incremental/compareCFG.ml +++ b/src/incremental/compareCFG.ml @@ -17,7 +17,7 @@ let (&&<>) (prev_result: bool * rename_mapping) f : bool * rename_mapping = let eq_node (x, fun1) (y, fun2) ~rename_mapping = let isPseudoReturn f sid = - let pid = CfgTools.get_pseudo_return_id f in + let pid = Cilfacade.get_pseudo_return_id f in sid == pid in match x,y with | Statement s1, Statement s2 -> diff --git a/src/incremental/dune b/src/incremental/dune new file mode 100644 index 0000000000..15c1d2a7af --- /dev/null +++ b/src/incremental/dune @@ -0,0 +1,23 @@ +(include_subdirs no) + +(library + (name goblint_incremental) + (public_name goblint.incremental) + (wrapped false) ; TODO: wrap + (libraries + batteries.unthreaded + zarith + goblint_std + goblint_config + goblint_common + goblint-cil + fpath) + (flags :standard -open Goblint_std) + (preprocess + (pps + ppx_deriving.std + ppx_deriving_hash + ppx_deriving_yojson)) + (instrumentation (backend bisect_ppx))) + +(documentation) diff --git a/src/incremental/incremental.mld b/src/incremental/incremental.mld new file mode 100644 index 0000000000..bf9b6e6a58 --- /dev/null +++ b/src/incremental/incremental.mld @@ -0,0 +1,16 @@ +{0 Library goblint.incremental} +This library is unwrapped and provides the following top-level modules. +For better context, see {!Goblint_lib} which also documents these modules. + + +{1 Incremental} + +{!modules: +CompareCIL +CompareAST +CompareCFG +UpdateCil +MaxIdUtil +Serialize +CilMaps +} diff --git a/src/index.mld b/src/index.mld index 2afbbc97ae..0f6b1c3e69 100644 --- a/src/index.mld +++ b/src/index.mld @@ -7,9 +7,30 @@ The following libraries make up Goblint's main codebase. {!modules:Goblint_lib} This library currently contains the majority of Goblint and is in the process of being split into smaller libraries. +{2 Library goblint.config} +This {{!page-config}unwrapped library} contains various configuration modules extracted from {!Goblint_lib}. + {2 Library goblint.common} This {{!page-common}unwrapped library} contains various common modules extracted from {!Goblint_lib}. +{2 Library goblint.domain} +This {{!page-domain}unwrapped library} contains various domain modules extracted from {!Goblint_lib}. + +{2 Library goblint.cdomain.value} +This {{!page-cdomain_value}unwrapped library} contains various value domain modules extracted from {!Goblint_lib}. + +{2 Library goblint.constraint} +This {{!page-constraint}unwrapped library} contains various constraint system modules extracted from {!Goblint_lib}. + +{2 Library goblint.solver} +{!modules:Goblint_solver} + +{2 Library goblint.library} +This {{!page-library}unwrapped library} contains various library specification modules extracted from {!Goblint_lib}. + +{2 Library goblint.incremental} +This {{!page-incremental}unwrapped library} contains various incremental modules extracted from {!Goblint_lib}. + {1 Library extensions} The following libraries provide extensions to other OCaml libraries. @@ -43,6 +64,9 @@ The following libraries provide utilities which are completely independent of Go {2 Library goblint.timing} {!modules:Goblint_timing} +{2 Library goblint.tracing} +{!modules:Goblint_tracing} + {1 Vendored} The following libraries are vendored in Goblint. diff --git a/src/main.camldoc b/src/main.camldoc deleted file mode 100644 index ec08a14a7b..0000000000 --- a/src/main.camldoc +++ /dev/null @@ -1,142 +0,0 @@ - -This is the API of the Goblint static analyzer framework, developed at the Technische Universität München ({b TUM}) -and the University of Tartu ({b UT}). - -The API is divided into four logical sections: -the framework, constraint solvers, domains, and analysis instances. - -{2 Framework} -{!modules: -Maingoblint -Analyses -Constraints -Control -MyCFG -Version -Config -} - -{3 Util} -{!modules: -Cache -Cilfacade -Defaults -GobConfig -Goblintutil -Hash -Htmldump -Htmlutil -Json -Messages -MyLiveness -OilUtil -Printer -Questions -Report -Tracing -Xmldump -} - -{3 CIL components} -{!modules: -Cil -Pretty -} - -{2 Solvers} -{!modules: -EffectWCon -EffectWConEq -Generic -Interactive -SLR -Selector -SharirPnueli -TopDown -} - -{2 Domains} - -{!modules: - -ValueDomain -Basetype - -Exp -IntDomain -CircularInterval -ArrayDomain -StructDomain -UnionDomain - -Lval -AddressDomain -MemoryDomain -MusteqDomain -RegionDomain -ShapeDomain -ListDomain - -BaseDomain -ConcDomain -ContainDomain -EscapeDomain -FlagModeDomain -LockDomain -StackDomain -FileDomain -SpecDomain -LvalMapDomain - -} - -{3 General Lattice Functors} - -{!modules: -Lattice -Printable -MapDomain -PartitionDomain -SetDomain -Queries -Glob -} - -{2 Analyses} -{!modules: -MCP -Base -Spec - -CondVars -Contain -Deadlock -DeadlocksByRaces -Depbase -Depmutex -FileUse -Flag -FlagModes -ImpVar -Malloc_null -MayLocks -MTFlag -Mutex -Region -Shapes -StackTrace -SymbLocks -Termination -ThreadEscape -Thread -Uninit -Unit -VarDep -VarEq - -LibraryFunctions -} - -{9 Indexes} - -{!indexlist} diff --git a/src/maingoblint.ml b/src/maingoblint.ml index d81d3cfb71..f1d2793d2e 100644 --- a/src/maingoblint.ml +++ b/src/maingoblint.ml @@ -53,7 +53,7 @@ let rec option_spec_list: Arg_complete.speclist Lazy.t = lazy ( let add_string l = let f str = l := str :: !l in Arg_complete.String (f, Arg_complete.empty) in let add_int l = let f str = l := str :: !l in Arg_complete.Int (f, Arg_complete.empty) in let set_trace sys = - if Messages.tracing then Tracing.addsystem sys + if Messages.tracing then Goblint_tracing.addsystem sys else (prerr_endline "Goblint has been compiled without tracing, recompile in trace profile (./scripts/trace_on.sh)"; raise Stdlib.Exit) in let configure_html () = @@ -112,8 +112,8 @@ let rec option_spec_list: Arg_complete.speclist Lazy.t = lazy ( ; "--print_options" , Arg_complete.Unit (fun () -> Options.print_options (); exit 0), "" ; "--print_all_options" , Arg_complete.Unit (fun () -> Options.print_all_options (); exit 0), "" ; "--trace" , Arg_complete.String (set_trace, Arg_complete.empty), "" - ; "--tracevars" , add_string Tracing.tracevars, "" - ; "--tracelocs" , add_int Tracing.tracelocs, "" + ; "--tracevars" , add_string Goblint_tracing.tracevars, "" + ; "--tracelocs" , add_int Goblint_tracing.tracelocs, "" ; "--help" , Arg_complete.Unit (fun _ -> print_help stdout),"" ; "--html" , Arg_complete.Unit (fun _ -> configure_html ()),"" ; "--sarif" , Arg_complete.Unit (fun _ -> configure_sarif ()),"" @@ -191,10 +191,10 @@ let handle_flags () = let handle_options () = check_arguments (); - AfterConfig.run (); Sys.set_signal (GobSys.signal_of_string (get_string "dbg.solver-signal")) Signal_ignore; (* Ignore solver-signal before solving (e.g. MyCFG), otherwise exceptions self-signal the default, which crashes instead of printing backtrace. *) if AutoTune.isActivated "memsafetySpecification" && get_string "ana.specification" <> "" then AutoTune.focusOnMemSafetySpecification (); + AfterConfig.run (); Cilfacade.init_options (); handle_flags () @@ -513,7 +513,7 @@ let preprocess_parse_merge () = let do_stats () = if get_bool "dbg.timing.enabled" then ( print_newline (); - SolverStats.print (); + Goblint_solver.SolverStats.print (); print_newline (); print_string "Timings:\n"; Timing.Default.print (Stdlib.Format.formatter_of_out_channel @@ Messages.get_out "timing" Legacy.stderr); @@ -521,7 +521,7 @@ let do_stats () = ) let reset_stats () = - SolverStats.reset (); + Goblint_solver.SolverStats.reset (); Timing.Default.reset (); Timing.Program.reset () diff --git a/src/mainspec.ml b/src/mainspec.ml deleted file mode 100644 index 4509645f98..0000000000 --- a/src/mainspec.ml +++ /dev/null @@ -1,13 +0,0 @@ -open Goblint_lib -open Batteries (* otherwise open_in would return wrong type for SpecUtil *) -open SpecUtil - -let _ = - (* no arguments -> run interactively (= reading from stdin) *) - let args = Array.length Sys.argv > 1 in - if args && Sys.argv.(1) = "-" then - ignore(parse ~dot:true stdin) - else - let cin = if args then open_in Sys.argv.(1) else stdin in - ignore(parse ~repl:(not args) ~print:true cin) -(* exit 0 *) diff --git a/src/solver/dune b/src/solver/dune new file mode 100644 index 0000000000..bd6d7a4d0a --- /dev/null +++ b/src/solver/dune @@ -0,0 +1,23 @@ +(include_subdirs no) + +(library + (name goblint_solver) + (public_name goblint.solver) + (libraries + batteries.unthreaded + goblint_std + goblint_common + goblint_config + goblint_domain + goblint_constraint + goblint_incremental + goblint-cil) + (flags :standard -open Goblint_std) + (preprocess + (pps + ppx_deriving.std + ppx_deriving_hash + ppx_deriving_yojson)) + (instrumentation (backend bisect_ppx))) + +(documentation) diff --git a/src/solvers/effectWConEq.ml b/src/solver/effectWConEq.ml similarity index 95% rename from src/solvers/effectWConEq.ml rename to src/solver/effectWConEq.ml index c6dcf8f0e9..3cca6361b4 100644 --- a/src/solvers/effectWConEq.ml +++ b/src/solver/effectWConEq.ml @@ -1,8 +1,7 @@ (** ([effectWConEq]). *) open Batteries -open Analyses -open Constraints +open ConstrSys module Make = functor (S:EqConstrSys) -> @@ -88,4 +87,4 @@ module Make = end let _ = - Selector.add_solver ("effectWConEq", (module EqIncrSolverFromEqSolver (Make))); + Selector.add_solver ("effectWConEq", (module PostSolver.EqIncrSolverFromEqSolver (Make))); diff --git a/src/solvers/generic.ml b/src/solver/generic.ml similarity index 99% rename from src/solvers/generic.ml rename to src/solver/generic.ml index 2569341dd1..636aed8831 100644 --- a/src/solvers/generic.ml +++ b/src/solver/generic.ml @@ -2,7 +2,7 @@ open Batteries open GobConfig -open Analyses +open ConstrSys module LoadRunSolver: GenericEqSolver = functor (S: EqConstrSys) (VH: Hashtbl.S with type key = S.v) -> @@ -30,7 +30,7 @@ module LoadRunSolver: GenericEqSolver = end module LoadRunIncrSolver: GenericEqIncrSolver = - Constraints.EqIncrSolverFromEqSolver (LoadRunSolver) + PostSolver.EqIncrSolverFromEqSolver (LoadRunSolver) module SolverStats (S:EqConstrSys) (HM:Hashtbl.S with type key = S.v) = struct diff --git a/src/solver/goblint_solver.ml b/src/solver/goblint_solver.ml new file mode 100644 index 0000000000..0a264d7dea --- /dev/null +++ b/src/solver/goblint_solver.ml @@ -0,0 +1,31 @@ +(** Generic solvers for {{!ConstrSys.MonSystem} (side-effecting) constraint systems}. *) + +(** {1 Top-down} + + The top-down solver family. *) + +module Td3 = Td3 +module TopDown = TopDown +module TopDown_term = TopDown_term +module TopDown_space_cache_term = TopDown_space_cache_term +module TopDown_deprecated = TopDown_deprecated + +(** {1 SLR} + + The SLR solver family. *) + +module SLRphased = SLRphased +module SLRterm = SLRterm +module SLR = SLR + +(** {1 Other} *) + +module EffectWConEq = EffectWConEq +module Worklist = Worklist +module Generic = Generic +module Selector = Selector + +module PostSolver = PostSolver +module LocalFixpoint = LocalFixpoint +module SolverStats = SolverStats +module SolverBox = SolverBox diff --git a/src/solvers/localFixpoint.ml b/src/solver/localFixpoint.ml similarity index 100% rename from src/solvers/localFixpoint.ml rename to src/solver/localFixpoint.ml diff --git a/src/solvers/postSolver.ml b/src/solver/postSolver.ml similarity index 92% rename from src/solvers/postSolver.ml rename to src/solver/postSolver.ml index f96ca832a1..7f4f9c2b1f 100644 --- a/src/solvers/postSolver.ml +++ b/src/solver/postSolver.ml @@ -1,9 +1,10 @@ (** Extra constraint system evaluation pass for warning generation, verification, pruning, etc. *) open Batteries -open Analyses +open ConstrSys open GobConfig module Pretty = GoblintCil.Pretty +module M = Messages (** Postsolver with hooks. *) module type S = @@ -154,13 +155,7 @@ struct module VH = Hashtbl.Make (S.Var) (* starts as Hashtbl for quick lookup *) - let starth = - (* VH.of_list S.starts *) (* TODO: BatHashtbl.Make.of_list is broken, use after new Batteries release *) - let starth = VH.create (List.length S.starts) in - List.iter (fun (x, d) -> - VH.replace starth x d - ) S.starts; - starth + let starth = VH.of_list S.starts let system x = match S.system x, VH.find_option starth x with @@ -321,3 +316,22 @@ struct |> List.map snd |> List.map (fun (module F: F) -> (module F (S) (VH): M)) end + +(* Here to avoid module cycle between ConstrSys and PostSolver. *) +(** Convert a non-incremental solver into an "incremental" solver. + It will solve from scratch, perform standard postsolving and have no marshal data. *) +module EqIncrSolverFromEqSolver (Sol: GenericEqSolver): GenericEqIncrSolver = + functor (Arg: IncrSolverArg) (S: EqConstrSys) (VH: Hashtbl.S with type key = S.v) -> + struct + module Sol = Sol (S) (VH) + module Post = MakeList (ListArgFromStdArg (S) (VH) (Arg)) + + type marshal = unit + let copy_marshal () = () + let relift_marshal () = () + + let solve xs vs _ = + let vh = Sol.solve xs vs in + Post.post xs vs vh; + (vh, ()) + end diff --git a/src/solvers/sLR.ml b/src/solver/sLR.ml similarity index 91% rename from src/solvers/sLR.ml rename to src/solver/sLR.ml index 4904731b61..d05d87c4f3 100644 --- a/src/solvers/sLR.ml +++ b/src/solver/sLR.ml @@ -3,8 +3,7 @@ @see Apinis, K. Frameworks for analyzing multi-threaded C. *) open Batteries -open Analyses -open Constraints +open ConstrSys open Messages let narrow f = if GobConfig.get_bool "exp.no-narrow" then (fun a b -> a) else f @@ -522,29 +521,29 @@ let _ = let module W1 = JustWiden (struct let ver = 1 end) in let module W2 = JustWiden (struct let ver = 2 end) in let module W3 = JustWiden (struct let ver = 3 end) in - Selector.add_solver ("widen1", (module EqIncrSolverFromEqSolver (W1))); - Selector.add_solver ("widen2", (module EqIncrSolverFromEqSolver (W2))); - Selector.add_solver ("widen3", (module EqIncrSolverFromEqSolver (W3))); + Selector.add_solver ("widen1", (module PostSolver.EqIncrSolverFromEqSolver (W1))); + 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 EqIncrSolverFromEqSolver (S2))); + Selector.add_solver ("two", (module PostSolver.EqIncrSolverFromEqSolver (S2))); let module S1 = Make (struct let ver = 1 end) in - Selector.add_solver ("new", (module EqIncrSolverFromEqSolver (S1))); - Selector.add_solver ("slr+", (module EqIncrSolverFromEqSolver (S1))) + Selector.add_solver ("new", (module PostSolver.EqIncrSolverFromEqSolver (S1))); + Selector.add_solver ("slr+", (module PostSolver.EqIncrSolverFromEqSolver (S1))) let _ = let module S1 = Make (struct let ver = 1 end) in let module S2 = Make (struct let ver = 2 end) in let module S3 = SLR3 in let module S4 = Make (struct let ver = 4 end) in - Selector.add_solver ("slr1", (module EqIncrSolverFromEqSolver (S1))); (* W&N at every program point *) - Selector.add_solver ("slr2", (module EqIncrSolverFromEqSolver (S2))); (* W&N dynamic at certain points, growing number of W-points *) - Selector.add_solver ("slr3", (module EqIncrSolverFromEqSolver (S3))); (* same as S2 but number of W-points may also shrink *) - Selector.add_solver ("slr4", (module EqIncrSolverFromEqSolver (S4))); (* restarting: set influenced variables to bot and start up-iteration instead of narrowing *) + Selector.add_solver ("slr1", (module PostSolver.EqIncrSolverFromEqSolver (S1))); (* W&N at every program point *) + Selector.add_solver ("slr2", (module PostSolver.EqIncrSolverFromEqSolver (S2))); (* W&N dynamic at certain points, growing number of W-points *) + Selector.add_solver ("slr3", (module PostSolver.EqIncrSolverFromEqSolver (S3))); (* same as S2 but number of W-points may also shrink *) + Selector.add_solver ("slr4", (module PostSolver.EqIncrSolverFromEqSolver (S4))); (* restarting: set influenced variables to bot and start up-iteration instead of narrowing *) let module S1p = PrintInfluence (Make (struct let ver = 1 end)) in let module S2p = PrintInfluence (Make (struct let ver = 2 end)) in let module S3p = PrintInfluence (Make (struct let ver = 3 end)) in let module S4p = PrintInfluence (Make (struct let ver = 4 end)) in - Selector.add_solver ("slr1p", (module EqIncrSolverFromEqSolver (S1p))); (* same as S1-4 above but with side-effects *) - Selector.add_solver ("slr2p", (module EqIncrSolverFromEqSolver (S2p))); - Selector.add_solver ("slr3p", (module EqIncrSolverFromEqSolver (S3p))); - Selector.add_solver ("slr4p", (module EqIncrSolverFromEqSolver (S4p))); + Selector.add_solver ("slr1p", (module PostSolver.EqIncrSolverFromEqSolver (S1p))); (* same as S1-4 above but with side-effects *) + Selector.add_solver ("slr2p", (module PostSolver.EqIncrSolverFromEqSolver (S2p))); + Selector.add_solver ("slr3p", (module PostSolver.EqIncrSolverFromEqSolver (S3p))); + Selector.add_solver ("slr4p", (module PostSolver.EqIncrSolverFromEqSolver (S4p))); diff --git a/src/solvers/sLRphased.ml b/src/solver/sLRphased.ml similarity index 98% rename from src/solvers/sLRphased.ml rename to src/solver/sLRphased.ml index c120a7bc6c..17571f0138 100644 --- a/src/solvers/sLRphased.ml +++ b/src/solver/sLRphased.ml @@ -1,8 +1,7 @@ (** Two-phased terminating SLR3 solver ([slr3tp]). *) open Batteries -open Analyses -open Constraints +open ConstrSys open Messages open SLR @@ -205,4 +204,4 @@ module Make = end let _ = - Selector.add_solver ("slr3tp", (module EqIncrSolverFromEqSolver (Make))); (* two-phased slr3t *) + Selector.add_solver ("slr3tp", (module PostSolver.EqIncrSolverFromEqSolver (Make))); (* two-phased slr3t *) diff --git a/src/solvers/sLRterm.ml b/src/solver/sLRterm.ml similarity index 97% rename from src/solvers/sLRterm.ml rename to src/solver/sLRterm.ml index eb11447d11..8ec34c7dc2 100644 --- a/src/solvers/sLRterm.ml +++ b/src/solver/sLRterm.ml @@ -2,8 +2,7 @@ Simpler version of {!SLRphased} without phases. *) open Batteries -open Analyses -open Constraints +open ConstrSys open Messages open SLR @@ -224,4 +223,4 @@ module SLR3term = end let _ = - Selector.add_solver ("slr3t", (module EqIncrSolverFromEqSolver (SLR3term))); (* same as S2 but number of W-points may also shrink + terminating? *) + Selector.add_solver ("slr3t", (module PostSolver.EqIncrSolverFromEqSolver (SLR3term))); (* same as S2 but number of W-points may also shrink + terminating? *) diff --git a/src/solvers/selector.ml b/src/solver/selector.ml similarity index 99% rename from src/solvers/selector.ml rename to src/solver/selector.ml index 664cbe0513..854b8e1036 100644 --- a/src/solvers/selector.ml +++ b/src/solver/selector.ml @@ -1,7 +1,7 @@ (** Solver, which delegates at runtime to the configured solver. *) open Batteries -open Analyses +open ConstrSys open GobConfig (* Registered solvers. *) diff --git a/src/solvers/solverBox.ml b/src/solver/solverBox.ml similarity index 100% rename from src/solvers/solverBox.ml rename to src/solver/solverBox.ml diff --git a/src/solvers/solverStats.ml b/src/solver/solverStats.ml similarity index 100% rename from src/solvers/solverStats.ml rename to src/solver/solverStats.ml diff --git a/src/solvers/td3.ml b/src/solver/td3.ml similarity index 99% rename from src/solvers/td3.ml rename to src/solver/td3.ml index 07edc632c7..54b7520cd6 100644 --- a/src/solvers/td3.ml +++ b/src/solver/td3.ml @@ -15,9 +15,11 @@ *) open Batteries -open Analyses +open ConstrSys open Messages +module M = Messages + module type Hooks = sig module S: EqConstrSys @@ -192,7 +194,7 @@ module Base = type phase = Widen | Narrow [@@deriving show] (* used in inner solve *) - module CurrentVarS = Constraints.CurrentVarEqConstrSys (S) + module CurrentVarS = ConstrSys.CurrentVarEqConstrSys (S) module S = CurrentVarS.S let solve st vs marshal = diff --git a/src/solvers/topDown.ml b/src/solver/topDown.ml similarity index 98% rename from src/solvers/topDown.ml rename to src/solver/topDown.ml index c6b20d28db..f7da560057 100644 --- a/src/solvers/topDown.ml +++ b/src/solver/topDown.ml @@ -2,8 +2,7 @@ Simpler version of {!Td3} without terminating, space-efficiency and incremental. *) open Batteries -open Analyses -open Constraints +open ConstrSys open Messages module WP = @@ -155,4 +154,4 @@ module WP = end let _ = - Selector.add_solver ("topdown", (module EqIncrSolverFromEqSolver (WP))); + Selector.add_solver ("topdown", (module PostSolver.EqIncrSolverFromEqSolver (WP))); diff --git a/src/solvers/topDown_deprecated.ml b/src/solver/topDown_deprecated.ml similarity index 97% rename from src/solvers/topDown_deprecated.ml rename to src/solver/topDown_deprecated.ml index 1f51244458..4e9799cf78 100644 --- a/src/solvers/topDown_deprecated.ml +++ b/src/solver/topDown_deprecated.ml @@ -1,8 +1,7 @@ (** Deprecated top-down solver ([topdown_deprecated]). *) open Batteries -open Analyses -open Constraints +open ConstrSys open Messages exception SolverCannotDoGlobals @@ -164,4 +163,4 @@ module TD3 = end let _ = - Selector.add_solver ("topdown_deprecated", (module EqIncrSolverFromEqSolver (TD3))); + Selector.add_solver ("topdown_deprecated", (module PostSolver.EqIncrSolverFromEqSolver (TD3))); diff --git a/src/solvers/topDown_space_cache_term.ml b/src/solver/topDown_space_cache_term.ml similarity index 98% rename from src/solvers/topDown_space_cache_term.ml rename to src/solver/topDown_space_cache_term.ml index a78d90559d..f6c256517c 100644 --- a/src/solvers/topDown_space_cache_term.ml +++ b/src/solver/topDown_space_cache_term.ml @@ -2,8 +2,7 @@ Simpler version of {!Td3} without incremental. *) open Batteries -open Analyses -open Constraints +open ConstrSys open Messages module WP = @@ -197,4 +196,4 @@ module WP = end let _ = - Selector.add_solver ("topdown_space_cache_term", (module EqIncrSolverFromEqSolver (WP))); + Selector.add_solver ("topdown_space_cache_term", (module PostSolver.EqIncrSolverFromEqSolver (WP))); diff --git a/src/solvers/topDown_term.ml b/src/solver/topDown_term.ml similarity index 97% rename from src/solvers/topDown_term.ml rename to src/solver/topDown_term.ml index ec07995586..d15493b5a1 100644 --- a/src/solvers/topDown_term.ml +++ b/src/solver/topDown_term.ml @@ -2,8 +2,7 @@ Simpler version of {!Td3} without space-efficiency and incremental. *) open Batteries -open Analyses -open Constraints +open ConstrSys open Messages module WP = @@ -134,4 +133,4 @@ module WP = end let _ = - Selector.add_solver ("topdown_term", (module EqIncrSolverFromEqSolver (WP))); + Selector.add_solver ("topdown_term", (module PostSolver.EqIncrSolverFromEqSolver (WP))); diff --git a/src/solvers/worklist.ml b/src/solver/worklist.ml similarity index 93% rename from src/solvers/worklist.ml rename to src/solver/worklist.ml index b525764c74..b1a5d7e834 100644 --- a/src/solvers/worklist.ml +++ b/src/solver/worklist.ml @@ -1,8 +1,7 @@ (** Worklist solver ([WL]). *) open Batteries -open Analyses -open Constraints +open ConstrSys module Make = functor (S:EqConstrSys) -> @@ -63,4 +62,4 @@ module Make = let _ = - Selector.add_solver ("WL", (module EqIncrSolverFromEqSolver (Make))); + Selector.add_solver ("WL", (module PostSolver.EqIncrSolverFromEqSolver (Make))); diff --git a/src/spec/dune b/src/spec/dune deleted file mode 100644 index 47c22a0d46..0000000000 --- a/src/spec/dune +++ /dev/null @@ -1,2 +0,0 @@ -(ocamllex specLexer) -(ocamlyacc specParser) diff --git a/src/spec/file.dot b/src/spec/file.dot deleted file mode 100644 index a78c64d3fc..0000000000 --- a/src/spec/file.dot +++ /dev/null @@ -1,37 +0,0 @@ -digraph file { - // changed file pointer {fp} (no longer safe) - - // file handle is not saved! - // overwriting still opened file handle - // file is never closed - // file may be never closed - // closeing unopened file handle - // closeing already closed file handle - // writing to closed file handle - // writing to unopened file handle - // writing to read-only file handle - - // unclosed files: ... - // maybe unclosed files: ... - - w1 [label="file handle is not saved!"]; - w2 [label="closeing unopened file handle"]; - w3 [label="writing to unopened file handle"]; - w4 [label="writing to read-only file handle"]; - w5 [label="closeing already closed file handle"]; - w6 [label="writing to closed file handle"]; - - 1 -> w1 [label="fopen(_)"]; - 1 -> w2 [label="fclose($fp)"]; - 1 -> w3 [label="fprintf($fp, _)"]; - 1 -> open_read [label="$fp = fopen($path, \"r\")"]; - 1 -> open_write [label="$fp = fopen($path, \"w\")"]; - 1 -> open_write [label="$fp = fopen($path, \"a\")"]; - open_read -> w4 [label="fprintf($fp, _)"]; - open_write -> open_write [label="fprintf($fp, _)"]; - open_read -> closed [label="fclose($fp)"]; - open_write -> closed [label="fclose($fp)"]; - closed -> w5 [label="fclose($fp)"]; - closed -> w6 [label="fprintf($fp, _)"]; - closed -> 1 [label="->"]; -} \ No newline at end of file diff --git a/src/spec/render.sh b/src/spec/render.sh deleted file mode 100755 index 91e486c247..0000000000 --- a/src/spec/render.sh +++ /dev/null @@ -1,31 +0,0 @@ -# command -v ls >&- || {echo >&2 bla; exit 1;} -function check(){ - set -e # needed to exit script from function - hash $1 2>&- || (echo >&2 "$1 is needed but not installed! $2"; exit 1;) - set +e # do not exit shell if some command fails (default) -} -check dot -mode=${1-"png"} -file=${2-"file"} -dst=graph -viewcmd=gpicview - -mkdir -p ${dst} -cp ${file}.dot ${dst} -file=${file##*/} # use basename in case the file was somewhere else -cd ${dst} -trap 'cd ..' EXIT # leave dst again on exit -case "$mode" in - png) dot -Tpng -o${file}.png ${file}.dot; - check ${viewcmd} "Please edit viewcmd accordingly." - pkill ${viewcmd}; - ${viewcmd} ${file}.png & - ;; - pdf) rm -f ${file}.tex; - check dot2tex - dot -Txdot ${file}.dot | dot2tex > ${file}.tex; - check pdflatex - pdflatex ${file}.tex - echo "generated $dst/$file.pdf" - ;; -esac diff --git a/src/spec/specCore.ml b/src/spec/specCore.ml deleted file mode 100644 index 9d0ce35624..0000000000 --- a/src/spec/specCore.ml +++ /dev/null @@ -1,152 +0,0 @@ -(* types used by specParser and functions for handling the constructed types *) - -open Batteries - -exception Endl -exception Eof - -(* type value = String of string | Bool of bool | Int of int | Float of float *) -type lval = Ptr of lval | Var of string | Ident of string -type fcall = {fname: string; args: exp list} -and exp = - Fun of fcall | - Exp_ | - Lval of lval | - Regex of string | - String of string | Bool of bool | Int of int | Float of float | - Binop of string * exp * exp | - Unop of string * exp -type stmt = {lval: lval option; exp: exp} -type def = Node of (string * string) (* node warning *) - | Edge of (string * string list * bool * string * stmt) (* start-node, warning-nodes, forwarding, target-node, constraint *) - -(* let stmts edges = List.map (fun (a,b,c) -> c) edges - let get_fun stmt = match stmt.exp with Fun x -> Some x | _ -> None - let fun_records edges = List.filter_map get_fun (stmts edges) - let fun_names edges = fun_records edges |> List.map (fun x -> x.fname) - let fun_by_fname fname edges = List.filter (fun x -> x.fname=fname) (fun_records edges) *) -let fname_is fname stmt = - match stmt.exp with - | Fun x -> x.fname=fname - | _ -> false - -let is_wildcard stmt = stmt.exp = Exp_ - -let branch_exp stmt = - match stmt.exp with - | Fun { fname="branch"; args=[exp; Bool tv] } -> Some (exp,tv) - | _ -> None - -let is_branch stmt = branch_exp stmt <> None - -let startnode edges = - (* The start node of the first transition is the start node of the automaton. *) - let a,ws,fwd,b,c = List.hd edges in a - -let warning state nodes = - try - Some (snd (List.find (fun x -> fst x = state) nodes)) (* find node for state and return its warning *) - with - | Not_found -> None (* no node for state *) - -let get_lval stmt = - let f = function - | Ptr x -> `Ptr (* TODO recursive *) - | Var s -> `Var - | Ident s -> `Ident - in - Option.map f stmt.lval - -let get_exp = function - | Regex x -> `Regex x - | String x -> `String x - | Bool x -> `Bool x - | Int x -> `Int x - | Float x -> `Float x - | Lval (Var x) -> `Var x - | Lval (Ident x) -> `Ident x - | Fun x -> `Error "Functions aren't allowed to have functions as an argument (put the function as a previous state instead)" - | Exp_ -> `Free - | Unop ("!", Bool x) -> `Bool (not x) - | _ -> `Error "Unsupported operation inside function argument, use a simpler expression instead." - -let get_rval stmt = get_exp stmt.exp - -let get_key_variant stmt = - let rec get_from_exp = function - | Fun f -> get_from_args f.args (* TODO for special we only consider constraints where the root of the exp is Fun (see fname_is) *) - | Lval (Var s) -> `Rval s - | _ -> `None - (* walks over arguments until it finds something or returns `None *) - and get_from_argsi i = function - | [] -> `None - | x::xs -> - match get_from_exp x with - | `Rval s -> `Arg(s, i) - | _ -> get_from_argsi (i+1) xs (* matches `None and `Arg -> `Arg of `Arg not supported *) - and get_from_args args = get_from_argsi 0 args (* maybe better use List.findi *) - in - let rec get_from_lval = function - | Ptr x -> get_from_lval x - | Var s -> Some s - | Ident s -> None - in - match stmt.lval with - | Some lval when Option.is_some (get_from_lval lval) -> `Lval (Option.get (get_from_lval lval)) - | _ -> get_from_exp stmt.exp - -let equal_form lval stmt = - match lval, stmt.lval with - | Some _, Some _ - | None, None -> true - | _ -> false - -(* get function arguments with tags corresponding to the type -> should only be called for functions, returns [] for everything else *) -let get_fun_args stmt = match stmt.exp with - | Fun f -> List.map get_exp f.args - | _ -> [] - -(* functions for output *) -let rec lval_to_string = function - | Ptr x -> "*"^(lval_to_string x) - | Var x -> "$"^x - | Ident x -> x -let rec exp_to_string = function - | Fun x -> x.fname^"("^String.concat ", " (List.map exp_to_string x.args)^")" - | Exp_ -> "_" - | Lval x -> lval_to_string x - | Regex x -> "r\""^x^"\"" - | String x -> "\""^x^"\"" - | Bool x -> string_of_bool x - | Int x -> string_of_int x - | Float x -> string_of_float x - | Binop (op, a, b) -> exp_to_string a ^ " " ^ op ^ " " ^ exp_to_string b - | Unop (op, a) -> op ^ " " ^ exp_to_string a -let stmt_to_string stmt = match stmt.lval, stmt.exp with - | Some lval, exp -> lval_to_string lval^" = "^exp_to_string exp - | None, exp -> exp_to_string exp -let arrow_to_string ws fwd = (String.concat "," ws)^if fwd then ">" else "" -let def_to_string = function - | Node(n, m) -> n^"\t\""^m^"\"" - | Edge(a, ws, fwd, b, s) -> a^" -"^arrow_to_string ws fwd^"> "^b^"\t"^stmt_to_string s - -let to_dot_graph defs = - let no_warnings = true in - let def_to_string = function - | Node(n, m) -> - if no_warnings then "" - else n^"\t[style=filled, fillcolor=orange, label=\""^n^": "^m^"\"];" - | Edge(a, ws, fwd, b, s) -> - let style = if fwd then "style=dotted, " else "" in - let ws = if List.is_empty ws then "" else (String.concat "," ws)^" | " in - a^" -> "^b^"\t["^style^"label=\""^ws^String.escaped (stmt_to_string s)^"\"];" - in - let ends,defs = List.partition (function Edge (a,ws,fwd,b,s) -> b="end" && s.exp=Exp_ | _ -> false) defs in - let endstates = List.filter_map (function Edge (a,ws,fwd,b,s) -> Some a | _ -> None) ends in - (* set the default style for nodes *) - let defaultstyle = "node [shape=box, style=rounded];" in - (* style end nodes and then reset *) - let endstyle = if List.is_empty endstates then "" else "node [peripheries=2]; "^(String.concat " " endstates)^"; node [peripheries=1];" in - let lines = "digraph file {"::defaultstyle::endstyle::(List.map def_to_string defs |> List.filter (fun s -> s<>"")) in - (* List.iter print_endline lines *) - String.concat "\n " lines ^ "\n}" diff --git a/src/spec/specLexer.mll b/src/spec/specLexer.mll deleted file mode 100644 index 64ac69359e..0000000000 --- a/src/spec/specLexer.mll +++ /dev/null @@ -1,67 +0,0 @@ -{ - open SpecParser (* The type token is defined in specParser.mli *) - exception Token of string - let line = ref 1 -} - -let digit = ['0'-'9'] -let alpha = ['a'-'z' 'A'-'Z'] -let nl = '\r'?'\n' (* new line *) -let s = [' ' '\t'] (* whitespace *) -let w = '_' | alpha | digit (* word *) -let endlinecomment = "//" [^'\n']* -let multlinecomment = "/*"([^'*']|('*'+[^'*''/'])|nl)*'*'+'/' -let comments = endlinecomment | multlinecomment -let str = ('\"'(([^'\"']|"\\\"")* as s)'\"') | ('\''(([^'\'']|"\\'")* as s)'\'') - -rule token = parse - | s { token lexbuf } (* skip blanks *) - | comments { token lexbuf } (* skip comments *) - | nl { incr line; EOL } - - (* operators *) - | '(' { LPAREN } - | ')' { RPAREN } - | '[' { LBRACK } - | ']' { RBRACK } - | '{' { LCURL } - | '}' { RCURL } - (*| '.' { DOT } *) - (*| "->" { ARROW } *) - | '+' { PLUS } - | '-' { MINUS } - | '*' { MUL } - | '/' { DIV } - | '%' { MOD } - | '<' { LT } - | '>' { GT } - | "==" { EQEQ } - | "!=" { NE } - | "<=" { LE } - | ">=" { GE } - | "&&" { AND } - | "||" { OR } - | '!' { NOT } - | '=' { EQ } - | ',' { COMMA } - | ';' { SEMICOLON } - - (* literals, identifiers *) - | "true" { BOOL(true) } - | "false" { BOOL(false) } - | "null" { NULL } - | digit+ as x { INT(int_of_string x) } - | str { STRING(s) } - | '_' { UNDERS } (* used for spec, but has to be before Ident! *) - | ('_'|alpha) w* as x { IDENT(x) } - - (* spec *) - | ':' { COLON } - | "$"(w+ as x) { VAR(x) } - | "r" str { REGEX(s) } - | (w+ as n) s+ str - { NODE(n, s) } - | (w+ as a) s* "-" ((w+ ("," w+)*)? as ws) (">"? as fwd) ">" s* (w+ as b) s+ - { EDGE(a, BatString.split_on_string ~by:"," ws, fwd=">", b) } - | eof { EOF } - | _ as x { raise(Token (Char.escaped x^": unknown token in line "^string_of_int !line)) } diff --git a/src/spec/specParser.mly b/src/spec/specParser.mly deleted file mode 100644 index fe8fe90ec8..0000000000 --- a/src/spec/specParser.mly +++ /dev/null @@ -1,116 +0,0 @@ -%{ - (* necessary to open a different compilation unit - because exceptions directly defined here aren't visible outside - (e.g. SpecParser.Eof is raised, but Error: Unbound constructor - if used to catch in a different module) *) - open SpecCore -%} - -%token EOL EOF -/* operators */ -%token LPAREN RPAREN LCURL RCURL LBRACK RBRACK -%token PLUS MINUS MUL DIV MOD -%token LT GT EQEQ NE LE GE AND OR NOT -%token EQ COMMA SEMICOLON -/* literals, identifiers */ -%token BOOL -%token NULL -%token INT -%token STRING -%token IDENT -/* spec */ -%token UNDERS COLON -%token VAR -%token REGEX -%token NODE -%token EDGE - -/* precedence groups from low to high */ -%right EQ -%left OR -%left AND -%left EQEQ NE -%left LT GT LE GE -%left PLUS MINUS -%left MUL DIV MOD -%right NOT UPLUS UMINUS DEREF - -%start file -%type file - -%% - -file: - | def EOL { $1 } - | def EOF { $1 } /* no need for an empty line at the end */ - | EOL { raise Endl } /* empty line */ - | EOF { raise Eof } /* end of file */ -; - -def: - | NODE { Node($1) } - | EDGE stmt { let a, ws, fwd, b = $1 in Edge(a, ws, fwd, b, $2) } -; - -stmt: - | lval EQ expr { {lval = Some $1; exp = $3} } /* TODO expression would be better */ - | expr { {lval = None; exp = $1} } -; - -lval: - | MUL lval %prec DEREF { Ptr $2 } - | IDENT { Ident $1 } /* C identifier, e.g. foo, _foo, _1, but not 1b */ - | VAR { Var $1 } /* spec variable, e.g. $foo, $123, $__ */ -; - -expr: - | LPAREN expr RPAREN { $2 } - | REGEX { Regex $1 } - | STRING { String $1 } - | BOOL { Bool $1 } - | lval { Lval $1 } - | IDENT args { Fun {fname=$1; args=$2} } /* function */ - | UNDERS { Exp_ } - | nexpr { Int $1 } - /* | nexpr LT nexpr { Bool ($1<$3) } - | nexpr GT nexpr { Bool ($1>$3) } - | nexpr EQEQ nexpr { Bool ($1=$3) } - | nexpr NE nexpr { Bool ($1<>$3) } - | nexpr LE nexpr { Bool ($1<=$3) } - | nexpr GE nexpr { Bool ($1>=$3) } */ - | expr OR expr { Binop ("||", $1, $3) } - | expr AND expr { Binop ("&&", $1, $3) } - | expr EQEQ expr { Binop ("==", $1, $3) } - | expr NE expr { Binop ("!=", $1, $3) } - | expr LT expr { Binop ("<", $1, $3) } - | expr GT expr { Binop (">", $1, $3) } - | expr LE expr { Binop ("<=", $1, $3) } - | expr GE expr { Binop (">=", $1, $3) } - | expr PLUS expr { Binop ("+", $1, $3) } - | expr MINUS expr { Binop ("-", $1, $3) } - | expr MUL expr { Binop ("*", $1, $3) } - | expr DIV expr { Binop ("/", $1, $3) } - | expr MOD expr { Binop ("%", $1, $3) } - | NOT expr { Unop ("!", $2) } -; - -nexpr: - | INT { $1 } - | MINUS nexpr %prec UMINUS { - $2 } - | PLUS nexpr %prec UPLUS { $2 } - /* | LPAREN nexpr RPAREN { $2 } - | nexpr PLUS nexpr { $1 + $3 } - | nexpr MINUS nexpr { $1 - $3 } - | nexpr MUL nexpr { $1 * $3 } - | nexpr DIV nexpr { $1 / $3 } */ -; - -args: - | LPAREN RPAREN { [] } - | LPAREN expr_list RPAREN { $2 } -; - -expr_list: - | expr { [$1] } - | expr COMMA expr_list { $1 :: $3 } -; diff --git a/src/spec/specUtil.ml b/src/spec/specUtil.ml deleted file mode 100644 index 55e0b51135..0000000000 --- a/src/spec/specUtil.ml +++ /dev/null @@ -1,52 +0,0 @@ -(* functions for driving specParser *) - -open Batteries - -(* config *) -let save_dot = true - -let line = ref 1 -exception Parse_error of string - -let parse ?repl:(repl=false) ?print:(print=false) ?dot:(dot=false) cin = - let lexbuf = Lexing.from_channel cin in - let defs = ref [] in - (* Printf.printf "\nrepl: %B, print: %B, dot: %B, save_dot: %B\n" repl print dot save_dot; *) - try - while true do (* loop over all lines *) - try - let result = SpecParser.file SpecLexer.token lexbuf in - defs := !defs@[result]; - incr line; - if print then (print_endline (SpecCore.def_to_string result); flush stdout) - with - (* just an empty line -> don't print *) - | SpecCore.Endl -> incr line - (* somehow gets raised in some cases instead of SpecCore.Eof *) - | BatInnerIO.Input_closed -> raise SpecCore.Eof - (* catch and print in repl-mode *) - | e when repl -> print_endline (Printexc.to_string e) - done; - ([], []) (* never happens, but ocaml needs it for type *) - with - (* done *) - | SpecCore.Eof -> - let nodes = List.filter_map (function SpecCore.Node x -> Some x | _ -> None) !defs in - let edges = List.filter_map (function SpecCore.Edge x -> Some x | _ -> None) !defs in - if print then Printf.printf "\n#Definitions: %i, #Nodes: %i, #Edges: %i\n" - (List.length !defs) (List.length nodes) (List.length edges); - if save_dot && not dot then ( - let dotgraph = SpecCore.to_dot_graph !defs in - output_file ~filename:"result/graph.dot" ~text:dotgraph; - print_endline ("saved graph as "^Sys.getcwd ()^"/result/graph.dot"); - ); - if dot then ( - print_endline (SpecCore.to_dot_graph !defs) - ); - (nodes, edges) - (* stop on parsing error if not in REPL and include line number *) - | e -> raise (Parse_error ("Line "^string_of_int !line^": "^Printexc.to_string e)) - -let parseFile filename = parse (open_in filename) - -(* print ~first:"[" ~sep:", " ~last:"]" print_any stdout @@ 5--10 *) diff --git a/src/domains/accessKind.ml b/src/util/library/accessKind.ml similarity index 100% rename from src/domains/accessKind.ml rename to src/util/library/accessKind.ml diff --git a/src/util/library/dune b/src/util/library/dune new file mode 100644 index 0000000000..c7797db33f --- /dev/null +++ b/src/util/library/dune @@ -0,0 +1,19 @@ +(include_subdirs no) + +(library + (name goblint_library) + (public_name goblint.library) + (wrapped false) ; TODO: wrap + (libraries + batteries.unthreaded + goblint_common + goblint_domain + goblint_config + goblint-cil) + (preprocess + (pps + ppx_deriving.std + ppx_deriving_hash)) + (instrumentation (backend bisect_ppx))) + +(documentation) diff --git a/src/util/library/library.mld b/src/util/library/library.mld new file mode 100644 index 0000000000..f55db3f2ff --- /dev/null +++ b/src/util/library/library.mld @@ -0,0 +1,14 @@ +{0 Library goblint.library} +This library is unwrapped and provides the following top-level modules. +For better context, see {!Goblint_lib} which also documents these modules. + + +{1 Utilities} + +{2 Library specification} +{!modules: +AccessKind +LibraryDesc +LibraryDsl +LibraryFunctions +} diff --git a/src/analyses/libraryDesc.ml b/src/util/library/libraryDesc.ml similarity index 98% rename from src/analyses/libraryDesc.ml rename to src/util/library/libraryDesc.ml index e426c32235..e2dbedb516 100644 --- a/src/analyses/libraryDesc.ml +++ b/src/util/library/libraryDesc.ml @@ -184,7 +184,8 @@ module MathPrintable = struct ) end -module MathLifted = Lattice.Flat (MathPrintable) (struct +module MathLifted = Lattice.FlatConf (struct + include Printable.DefaultConf let top_name = "Unknown or no math desc" let bot_name = "Nonexistent math desc" - end) + end) (MathPrintable) diff --git a/src/analyses/libraryDsl.ml b/src/util/library/libraryDsl.ml similarity index 100% rename from src/analyses/libraryDsl.ml rename to src/util/library/libraryDsl.ml diff --git a/src/analyses/libraryDsl.mli b/src/util/library/libraryDsl.mli similarity index 100% rename from src/analyses/libraryDsl.mli rename to src/util/library/libraryDsl.mli diff --git a/src/analyses/libraryFunctions.ml b/src/util/library/libraryFunctions.ml similarity index 95% rename from src/analyses/libraryFunctions.ml rename to src/util/library/libraryFunctions.ml index ab0d04d3ec..54b244f9e0 100644 --- a/src/analyses/libraryFunctions.ml +++ b/src/util/library/libraryFunctions.ml @@ -159,6 +159,10 @@ let c_descs_list: (string * LibraryDesc.t) list = LibraryDsl.[ ("wscanf", unknown (drop "fmt" [r] :: VarArgs (drop' [w]))); ("fwscanf", unknown (drop "stream" [r_deep; w_deep] :: drop "fmt" [r] :: VarArgs (drop' [w]))); ("swscanf", unknown (drop "buffer" [r] :: drop "fmt" [r] :: VarArgs (drop' [w]))); + ("remove", unknown [drop "pathname" [r]]); + ("raise", unknown [drop "sig" []]); (* safe-ish, we don't handle signal handlers for now *) + ("timespec_get", unknown [drop "ts" [w]; drop "base" []]); + ("signal", unknown [drop "signum" []; drop "handler" [s]]); ] (** C POSIX library functions. @@ -418,6 +422,16 @@ let posix_descs_list: (string * LibraryDesc.t) list = LibraryDsl.[ ("random", special [] Rand); ("posix_memalign", unknown [drop "memptr" [w]; drop "alignment" []; drop "size" []]); (* TODO: Malloc *) ("stpcpy", unknown [drop "dest" [w]; drop "src" [r]]); + ("dup", unknown [drop "oldfd" []]); + ("readdir_r", unknown [drop "dirp" [r_deep]; drop "entry" [r_deep]; drop "result" [w]]); + ("pipe", unknown [drop "pipefd" [w_deep]]); + ("waitpid", unknown [drop "pid" []; drop "wstatus" [w]; drop "options" []]); + ("strerror_r", unknown [drop "errnum" []; drop "buff" [w]; drop "buflen" []]); + ("umask", unknown [drop "mask" []]); + ("openlog", unknown [drop "ident" [r]; drop "option" []; drop "facility" []]); + ("times", unknown [drop "buf" [w]]); + ("mmap", unknown [drop "addr" []; drop "length" []; drop "prot" []; drop "flags" []; drop "fd" []; drop "offset" []]); + ("munmap", unknown [drop "addr" []; drop "length" []]); ] (** Pthread functions. *) @@ -638,6 +652,7 @@ let glibc_desc_list: (string * LibraryDesc.t) list = LibraryDsl.[ ("strchrnul", unknown [drop "s" [r]; drop "c" []]); ("getdtablesize", unknown []); ("daemon", unknown [drop "nochdir" []; drop "noclose" []]); + ("putw", unknown [drop "w" []; drop "stream" [r_deep; w_deep]]); ] let linux_userspace_descs_list: (string * LibraryDesc.t) list = LibraryDsl.[ @@ -735,6 +750,7 @@ let linux_kernel_descs_list: (string * LibraryDesc.t) list = LibraryDsl.[ ("__kmalloc", special [__ "size" []; drop "flags" []] @@ fun size -> Malloc size); ("kzalloc", special [__ "size" []; drop "flags" []] @@ fun size -> Calloc {count = Cil.one; size}); ("usb_alloc_urb", special [__ "iso_packets" []; drop "mem_flags" []] @@ fun iso_packets -> Malloc MyCFG.unknown_exp); + ("ioctl", unknown (drop "fd" [] :: drop "request" [] :: VarArgs (drop' [r_deep; w_deep]))); ] (** Goblint functions. *) @@ -1249,88 +1265,74 @@ open Invalidate * We assume that no known functions that are reachable are executed/spawned. For that we use ThreadCreate above. *) (* WTF: why are argument numbers 1-indexed (in partition)? *) let invalidate_actions = [ - "__printf_chk", readsAll;(*safe*) - "printk", readsAll;(*safe*) - "__mutex_init", readsAll;(*safe*) - "__builtin___snprintf_chk", writes [1];(*keep [1]*) - "__vfprintf_chk", writes [1];(*keep [1]*) - "__builtin_va_arg", readsAll;(*safe*) - "__builtin_va_end", readsAll;(*safe*) - "__builtin_va_start", readsAll;(*safe*) - "__ctype_b_loc", readsAll;(*safe*) - "__errno", readsAll;(*safe*) - "__errno_location", readsAll;(*safe*) - "__strdup", readsAll;(*safe*) - "strtoul__extinline", readsAll;(*safe*) - "readdir_r", writesAll;(*unsafe*) - "atoi__extinline", readsAll;(*safe*) - "_IO_getc", writesAll;(*unsafe*) - "pipe", writesAll;(*unsafe*) - "strerror_r", writesAll;(*unsafe*) - "raise", writesAll;(*unsafe*) - "_strlen", readsAll;(*safe*) - "stat__extinline", writesAllButFirst 1 readsAll;(*drop 1*) - "lstat__extinline", writesAllButFirst 1 readsAll;(*drop 1*) - "waitpid", readsAll;(*safe*) - "__open_alias", readsAll;(*safe*) - "__open_2", readsAll;(*safe*) - "ioctl", writesAll;(*unsafe*) - "fstat__extinline", writesAll;(*unsafe*) - "scandir", writes [1;3;4];(*keep [1;3;4]*) - "bindtextdomain", readsAll;(*safe*) - "textdomain", readsAll;(*safe*) - "dcgettext", readsAll;(*safe*) - "putw", readsAll;(*safe*) - "__getdelim", writes [3];(*keep [3]*) - "__h_errno_location", readsAll;(*safe*) - "__fxstat", readsAll;(*safe*) - "openlog", readsAll;(*safe*) - "umask", readsAll;(*safe*) - "clntudp_create", writesAllButFirst 3 readsAll;(*drop 3*) - "svctcp_create", readsAll;(*safe*) - "clntudp_bufcreate", writesAll;(*unsafe*) - "authunix_create_default", readsAll;(*safe*) - "clnt_broadcast", writesAll;(*unsafe*) - "clnt_sperrno", readsAll;(*safe*) - "pmap_unset", writesAll;(*unsafe*) - "svcudp_create", readsAll;(*safe*) - "svc_register", writesAll;(*unsafe*) - "svc_run", writesAll;(*unsafe*) - "dup", readsAll; (*safe*) - "__builtin___vsnprintf", writesAllButFirst 3 readsAll; (*drop 3*) - "__builtin___vsnprintf_chk", writesAllButFirst 3 readsAll; (*drop 3*) - "__error", readsAll; (*safe*) - "__maskrune", writesAll; (*unsafe*) - "times", writesAll; (*unsafe*) - "timespec_get", writes [1]; - "__tolower", readsAll; (*safe*) - "signal", writesAll; (*unsafe*) - "BF_cfb64_encrypt", writes [1;3;4;5]; (*keep [1;3;4,5]*) - "BZ2_bzBuffToBuffDecompress", writes [3;4]; (*keep [3;4]*) - "uncompress", writes [3;4]; (*keep [3;4]*) - "__xstat", writes [3]; (*keep [1]*) - "__lxstat", writes [3]; (*keep [1]*) - "remove", readsAll; - "BZ2_bzBuffToBuffCompress", writes [3;4]; (*keep [3;4]*) - "compress2", writes [3]; (*keep [3]*) - "__toupper", readsAll; (*safe*) - "BF_set_key", writes [3]; (*keep [3]*) - "PL_NewHashTable", readsAll; (*safe*) - "assert_failed", readsAll; (*safe*) - "munmap", readsAll;(*safe*) - "mmap", readsAll;(*safe*) - "__builtin_va_arg_pack_len", readsAll; - "__open_too_many_args", readsAll; - "usb_submit_urb", readsAll; (* first argument is written to but according to specification must not be read from anymore *) - "dev_driver_string", readsAll; - "__spin_lock_init", writes [1]; - "kmem_cache_create", readsAll; - "idr_pre_get", readsAll; - "zil_replay", writes [1;2;3;5]; - (* ddverify *) - "sema_init", readsAll; - "__goblint_assume_join", readsAll; - ] + "__printf_chk", readsAll;(*safe*) + "printk", readsAll;(*safe*) + "__mutex_init", readsAll;(*safe*) + "__builtin___snprintf_chk", writes [1];(*keep [1]*) + "__vfprintf_chk", writes [1];(*keep [1]*) + "__builtin_va_arg", readsAll;(*safe*) + "__builtin_va_end", readsAll;(*safe*) + "__builtin_va_start", readsAll;(*safe*) + "__ctype_b_loc", readsAll;(*safe*) + "__errno", readsAll;(*safe*) + "__errno_location", readsAll;(*safe*) + "__strdup", readsAll;(*safe*) + "strtoul__extinline", readsAll;(*safe*) + "atoi__extinline", readsAll;(*safe*) + "_IO_getc", writesAll;(*unsafe*) + "_strlen", readsAll;(*safe*) + "stat__extinline", writesAllButFirst 1 readsAll;(*drop 1*) + "lstat__extinline", writesAllButFirst 1 readsAll;(*drop 1*) + "__open_alias", readsAll;(*safe*) + "__open_2", readsAll;(*safe*) + "fstat__extinline", writesAll;(*unsafe*) + "scandir", writes [1;3;4];(*keep [1;3;4]*) + "bindtextdomain", readsAll;(*safe*) + "textdomain", readsAll;(*safe*) + "dcgettext", readsAll;(*safe*) + "__getdelim", writes [3];(*keep [3]*) + "__h_errno_location", readsAll;(*safe*) + "__fxstat", readsAll;(*safe*) + (* RPC library start *) + "clntudp_create", writesAllButFirst 3 readsAll;(*drop 3*) + "svctcp_create", readsAll;(*safe*) + "clntudp_bufcreate", writesAll;(*unsafe*) + "authunix_create_default", readsAll;(*safe*) + "clnt_broadcast", writesAll;(*unsafe*) + "clnt_sperrno", readsAll;(*safe*) + "pmap_unset", writesAll;(*unsafe*) + "svcudp_create", readsAll;(*safe*) + "svc_register", writesAll;(*unsafe*) + "svc_run", writesAll;(*unsafe*) + (* RPC library end *) + "__builtin___vsnprintf", writesAllButFirst 3 readsAll; (*drop 3*) + "__builtin___vsnprintf_chk", writesAllButFirst 3 readsAll; (*drop 3*) + "__error", readsAll; (*safe*) + "__maskrune", writesAll; (*unsafe*) + "__tolower", readsAll; (*safe*) + "BF_cfb64_encrypt", writes [1;3;4;5]; (*keep [1;3;4,5]*) + "BZ2_bzBuffToBuffDecompress", writes [3;4]; (*keep [3;4]*) + "uncompress", writes [3;4]; (*keep [3;4]*) + "__xstat", writes [3]; (*keep [1]*) + "__lxstat", writes [3]; (*keep [1]*) + "BZ2_bzBuffToBuffCompress", writes [3;4]; (*keep [3;4]*) + "compress2", writes [3]; (*keep [3]*) + "__toupper", readsAll; (*safe*) + "BF_set_key", writes [3]; (*keep [3]*) + "PL_NewHashTable", readsAll; (*safe*) + "assert_failed", readsAll; (*safe*) + "__builtin_va_arg_pack_len", readsAll; + "__open_too_many_args", readsAll; + "usb_submit_urb", readsAll; (* first argument is written to but according to specification must not be read from anymore *) + "dev_driver_string", readsAll; + "__spin_lock_init", writes [1]; + "kmem_cache_create", readsAll; + "idr_pre_get", readsAll; + "zil_replay", writes [1;2;3;5]; + (* ddverify *) + "sema_init", readsAll; + "__goblint_assume_join", readsAll; +] let invalidate_actions = let tbl = Hashtbl.create 113 in diff --git a/src/analyses/libraryFunctions.mli b/src/util/library/libraryFunctions.mli similarity index 100% rename from src/analyses/libraryFunctions.mli rename to src/util/library/libraryFunctions.mli diff --git a/src/util/std/dune b/src/util/std/dune index c6961a1725..2b814c677a 100644 --- a/src/util/std/dune +++ b/src/util/std/dune @@ -9,9 +9,11 @@ goblint-cil fpath yojson - yaml) + yaml + qcheck-core) (preprocess (pps ppx_deriving.std ppx_deriving_hash - ppx_deriving_yojson))) + ppx_deriving_yojson)) + (instrumentation (backend bisect_ppx))) diff --git a/src/util/std/gobHashtbl.ml b/src/util/std/gobHashtbl.ml index c14bafc0cb..c93244eb47 100644 --- a/src/util/std/gobHashtbl.ml +++ b/src/util/std/gobHashtbl.ml @@ -1,9 +1,5 @@ module Pretty = GoblintCil.Pretty -let magic_stats h = - let h: _ Hashtbl.t = Obj.magic h in (* Batteries Hashtables don't expose stats yet...: https://github.com/ocaml-batteries-team/batteries-included/pull/1079 *) - Hashtbl.stats h - let pretty_statistics () (s: Hashtbl.statistics) = let load_factor = float_of_int s.num_bindings /. float_of_int s.num_buckets in Pretty.dprintf "bindings=%d buckets=%d max_length=%d histo=%a load=%f" s.num_bindings s.num_buckets s.max_bucket_length (Pretty.docList (Pretty.dprintf "%d")) (Array.to_list s.bucket_histogram) load_factor diff --git a/src/common/domains/myCheck.ml b/src/util/std/gobQCheck.ml similarity index 91% rename from src/common/domains/myCheck.ml rename to src/util/std/gobQCheck.ml index 98583cd2c3..12809d5b46 100644 --- a/src/common/domains/myCheck.ml +++ b/src/util/std/gobQCheck.ml @@ -56,7 +56,4 @@ struct let gens = List.map gen arbs in let shrinks = List.map shrink arbs in make ~shrink:(Shrink.sequence shrinks) (Gen.sequence gens) - - open GoblintCil - let varinfo: Cil.varinfo arbitrary = QCheck.always (Cil.makeGlobalVar "arbVar" Cil.voidPtrType) (* S TODO: how to generate this *) end diff --git a/src/util/std/goblint_std.ml b/src/util/std/goblint_std.ml index e716d1df5b..0d548cac08 100644 --- a/src/util/std/goblint_std.ml +++ b/src/util/std/goblint_std.ml @@ -19,6 +19,7 @@ module GobUnix = GobUnix module GobFpath = GobFpath module GobPretty = GobPretty +module GobQCheck = GobQCheck module GobYaml = GobYaml module GobYojson = GobYojson module GobZ = GobZ diff --git a/src/util/tracing/dune b/src/util/tracing/dune new file mode 100644 index 0000000000..7e37139567 --- /dev/null +++ b/src/util/tracing/dune @@ -0,0 +1,9 @@ +(include_subdirs no) + +(library + (name goblint_tracing) + (public_name goblint.tracing) + (libraries + goblint_std + goblint-cil + goblint_build_info)) diff --git a/src/common/util/tracing.ml b/src/util/tracing/goblint_tracing.ml similarity index 84% rename from src/common/util/tracing.ml rename to src/util/tracing/goblint_tracing.ml index ad8892c396..0e5580b036 100644 --- a/src/common/util/tracing.ml +++ b/src/util/tracing/goblint_tracing.ml @@ -4,6 +4,7 @@ * large domains we output. The original code generated the document object * even when the subsystem is not activated. *) +open Goblint_std open GoblintCil open Pretty @@ -67,13 +68,6 @@ let trace sys ?var fmt = gtrace true printtrace sys var ignore fmt * c: continue/normal print w/o indent-change *) -let tracel sys ?var fmt = - let loc = !current_loc in - let docloc sys doc = - printtrace sys (dprintf "(%a)@?" CilType.Location.pretty loc ++ indent 2 doc); - in - gtrace true docloc sys var ~loc ignore fmt - let tracei (sys:string) ?var ?(subsys=[]) fmt = let f sys d = printtrace sys d; traceIndent () in let g () = activate sys subsys in @@ -85,13 +79,3 @@ let traceu sys fmt = let f sys d = printtrace sys d; traceOutdent () in let g () = deactivate sys in gtrace true f sys None g fmt - - -let traceli sys ?var ?(subsys=[]) fmt = - let loc = !current_loc in - let g () = activate sys subsys in - let docloc sys doc: unit = - printtrace sys (dprintf "(%a)" CilType.Location.pretty loc ++ indent 2 doc); - traceIndent () - in - gtrace true docloc sys var ~loc g fmt diff --git a/src/witness/observerAnalysis.ml b/src/witness/observerAnalysis.ml index e8daf56155..58b5b31fe4 100644 --- a/src/witness/observerAnalysis.ml +++ b/src/witness/observerAnalysis.ml @@ -29,7 +29,7 @@ struct let n () = -1 let names x = "state " ^ string_of_int x end - module D = Lattice.Flat (Printable.Chain (ChainParams)) (Printable.DefaultNames) + module D = Lattice.Flat (Printable.Chain (ChainParams)) module C = D module P = IdentityP (D) (* fully path-sensitive *) diff --git a/src/witness/yamlWitness.ml b/src/witness/yamlWitness.ml index 635ba4ad72..253ee5eecd 100644 --- a/src/witness/yamlWitness.ml +++ b/src/witness/yamlWitness.ml @@ -136,9 +136,9 @@ struct let precondition_loop_invariant_certificate ~target ~(certification): Entry.t = { entry_type = PreconditionLoopInvariantCertificate { - target; - certification; - }; + target; + certification; + }; metadata = metadata (); } end diff --git a/sv-comp/README.md b/sv-comp/README.md deleted file mode 100644 index 9f5c203213..0000000000 --- a/sv-comp/README.md +++ /dev/null @@ -1,28 +0,0 @@ -# Goblint for SV-COMP -All the SV-COMP configuration is in `conf/svcomp.json`. - -## Run Goblint in SV-COMP mode -### ReachSafety -``` -./goblint --conf conf/svcomp.json --set ana.specification ../sv-benchmarks/c/properties/unreach-call.prp ../sv-benchmarks/c/DIR/FILE.i -``` - -### NoDataRace -``` -./goblint --conf conf/svcomp.json --set ana.specification ../sv-benchmarks/c/properties/no-data-race.prp ../sv-benchmarks/c/DIR/FILE.i -``` - - -# Inspecting witnesses -## yEd - -1. Open (Ctrl+o) `witness.graphml` from Goblint root directory. -2. Click menu "Edit" → "Properties Mapper". - 1. _First time:_ Click button "Imports additional configurations" and open `yed-sv-comp.cnfx` from this directory. - 2. Select "SV-COMP (Node)" and click "Apply". - 3. Select "SV-COMP (Edge)" and click "Ok". -3. Click menu "Layout" → "Hierarchial" (Alt+shift+h). - 1. _First time:_ Click tab "Labeling", select "Hierarchic" in "Edge Labeling". - 2. Click "Ok". - -yEd manual for the Properties Mapper: https://yed.yworks.com/support/manual/properties_mapper.html. diff --git a/sv-comp/my-bench-sv-comp/.gitignore b/sv-comp/my-bench-sv-comp/.gitignore deleted file mode 100644 index 2eb047c8d6..0000000000 --- a/sv-comp/my-bench-sv-comp/.gitignore +++ /dev/null @@ -1 +0,0 @@ -*-tmp.xml diff --git a/sv-comp/my-bench-sv-comp/README.md b/sv-comp/my-bench-sv-comp/README.md deleted file mode 100644 index b401a1898c..0000000000 --- a/sv-comp/my-bench-sv-comp/README.md +++ /dev/null @@ -1,46 +0,0 @@ -# my-bench-sv-comp -This directory contains BenchExec benchmark and table definitions for a number of use cases and shell scripts for running them. - -## goblint-all-fast -Run Goblint on a large number of reachability benchmarks with decreased timeout. - -Files: -* `goblint-all-fast.sh` -* `goblint-all-fast.xml` -* `table-generator-all-fast.xml` - - -## goblint-data-race -Run Goblint on data-race benchmarks. - -Files: -* `goblint-data-race.sh` -* `goblint-data-race.xml` -* `table-generator-data-race.xml` - - -## goblint-lint -Run Goblint and validate witnesses using witnesslinter. - -Files: -* `goblint-lint.sh` -* `goblint-lint.xml` -* `table-generator-lint.xml` -* `witnesslint-validate.xml` - - -## goblint -Run Goblint and validate witnesses using: -* CPAChecker, -* Ultimate Automizer, -* witnesslinter. - -Files: -* `cpa-validate-correctness.xml` -* `cpa-validate-violation.xml` -* `goblint.sh` -* `goblint.xml` -* `table-generator-witness.xml` -* `uautomizer-validate-correctness.xml` -* `uautomizer-validate-violation.xml` -* `witnesslint-validate2.xml` diff --git a/sv-comp/my-bench-sv-comp/cpa-validate-correctness.xml b/sv-comp/my-bench-sv-comp/cpa-validate-correctness.xml deleted file mode 100644 index dca5c52c6d..0000000000 --- a/sv-comp/my-bench-sv-comp/cpa-validate-correctness.xml +++ /dev/null @@ -1,25 +0,0 @@ - - - - - - **.graphml - - - - - - - RESULTSDIR/LOGDIR/${rundefinition_name}/${taskdef_name}/witness.graphml - - - - /home/simmo/benchexec/sv-benchmarks/c/SoftwareSystems-DeviceDriversLinux64-ReachSafety.set - /home/simmo/benchexec/sv-benchmarks/c/properties/unreach-call.prp - - - - diff --git a/sv-comp/my-bench-sv-comp/cpa-validate-violation.xml b/sv-comp/my-bench-sv-comp/cpa-validate-violation.xml deleted file mode 100644 index 8fcffd7321..0000000000 --- a/sv-comp/my-bench-sv-comp/cpa-validate-violation.xml +++ /dev/null @@ -1,30 +0,0 @@ - - - - - - **.graphml - - - - - - - - - - - - RESULTSDIR/LOGDIR/${rundefinition_name}/${taskdef_name}/witness.graphml - - - - /home/simmo/benchexec/sv-benchmarks/c/SoftwareSystems-DeviceDriversLinux64-ReachSafety.set - /home/simmo/benchexec/sv-benchmarks/c/properties/unreach-call.prp - - - - diff --git a/sv-comp/my-bench-sv-comp/goblint-all-fast.sh b/sv-comp/my-bench-sv-comp/goblint-all-fast.sh deleted file mode 100755 index c47ff10141..0000000000 --- a/sv-comp/my-bench-sv-comp/goblint-all-fast.sh +++ /dev/null @@ -1,26 +0,0 @@ -#!/usr/bin/env bash - -shopt -s extglob - -MYBENCHDIR=/mnt/goblint-svcomp/benchexec/my-bench-sv-comp -RESULTSDIR=/mnt/goblint-svcomp/benchexec/results/70-all-fast-no-interval -GOBLINTPARALLEL=14 - -mkdir $RESULTSDIR - -# Run verification -cd /mnt/goblint-svcomp/sv-comp/goblint -# read-only and overlay dirs for Value too large for defined data type workaround -benchexec --read-only-dir / --overlay-dir . --hidden-dir /home --outputpath $RESULTSDIR --numOfThreads $GOBLINTPARALLEL $MYBENCHDIR/goblint-all-fast.xml - -# Extract witness directory -cd $RESULTSDIR -LOGDIR=`echo goblint*.files` -echo $LOGDIR - -# Generate table with merged results and witness validation results -sed -e "s/LOGDIR/$LOGDIR/" $MYBENCHDIR/table-generator-all-fast.xml > table-generator.xml -table-generator -x table-generator.xml - -# Decompress all tool outputs for table HTML links -unzip -o goblint*.logfiles.zip \ No newline at end of file diff --git a/sv-comp/my-bench-sv-comp/goblint-all-fast.xml b/sv-comp/my-bench-sv-comp/goblint-all-fast.xml deleted file mode 100644 index 6d4bb8fc3c..0000000000 --- a/sv-comp/my-bench-sv-comp/goblint-all-fast.xml +++ /dev/null @@ -1,74 +0,0 @@ - - - - - - - - - - - - - - - - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/ConcurrencySafety-Main.set - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/properties/unreach-call.prp - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/pthread-wmm/* - - - - - - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/SoftwareSystems-DeviceDriversLinux64-ReachSafety.set - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/properties/unreach-call.prp - - - - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/SoftwareSystems-DeviceDriversLinux64Large-ReachSafety.set - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/properties/unreach-call.prp - - - - diff --git a/sv-comp/my-bench-sv-comp/goblint-data-race.sh b/sv-comp/my-bench-sv-comp/goblint-data-race.sh deleted file mode 100755 index b42e69d5ce..0000000000 --- a/sv-comp/my-bench-sv-comp/goblint-data-race.sh +++ /dev/null @@ -1,26 +0,0 @@ -#!/usr/bin/env bash - -shopt -s extglob - -MYBENCHDIR=/mnt/goblint-svcomp/benchexec/my-bench-sv-comp -RESULTSDIR=/mnt/goblint-svcomp/benchexec/results/data-race-results21-concurrencysafety-new -GOBLINTPARALLEL=14 - -mkdir $RESULTSDIR - -# Run verification -cd /mnt/goblint-svcomp/sv-comp/goblint -# read-only and overlay dirs for Value too large for defined data type workaround -benchexec --read-only-dir / --overlay-dir . --hidden-dir /home --outputpath $RESULTSDIR --numOfThreads $GOBLINTPARALLEL $MYBENCHDIR/goblint-data-race.xml - -# Extract witness directory -cd $RESULTSDIR -LOGDIR=`echo goblint*.files` -echo $LOGDIR - -# Generate table with merged results and witness validation results -sed -e "s/LOGDIR/$LOGDIR/" $MYBENCHDIR/table-generator-data-race.xml > table-generator.xml -table-generator -x table-generator.xml - -# Decompress all tool outputs for table HTML links -unzip -o goblint*.logfiles.zip \ No newline at end of file diff --git a/sv-comp/my-bench-sv-comp/goblint-data-race.xml b/sv-comp/my-bench-sv-comp/goblint-data-race.xml deleted file mode 100644 index f8c00b582a..0000000000 --- a/sv-comp/my-bench-sv-comp/goblint-data-race.xml +++ /dev/null @@ -1,17 +0,0 @@ - - - - - - - - - - - - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/NoDataRace-ConcurrencySafety.set - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/properties/no-data-race.prp - - - - diff --git a/sv-comp/my-bench-sv-comp/goblint-lint.sh b/sv-comp/my-bench-sv-comp/goblint-lint.sh deleted file mode 100755 index bbd1270a31..0000000000 --- a/sv-comp/my-bench-sv-comp/goblint-lint.sh +++ /dev/null @@ -1,42 +0,0 @@ -#!/bin/bash - -shopt -s extglob - -MYBENCHDIR=/mnt/goblint-svcomp/benchexec/my-bench-sv-comp -RESULTSDIR=/mnt/goblint-svcomp/benchexec/results/new-results28-all-fast-systems-witness-linter -GOBLINTPARALLEL=15 -VALIDATEPARALLEL=15 - -mkdir $RESULTSDIR - -# Run verification -cd /mnt/goblint-svcomp/sv-comp/goblint -# read-only and overlay dirs for Value too large for defined data type workaround -benchexec --read-only-dir / --overlay-dir . --hidden-dir /home --outputpath $RESULTSDIR --numOfThreads $GOBLINTPARALLEL $MYBENCHDIR/goblint-lint.xml - -# Extract witness directory -cd $RESULTSDIR -LOGDIR=`echo goblint*.files` -echo $LOGDIR - -# Construct validation XMLs -cd $MYBENCHDIR -# witnesslint -sed -e "s|RESULTSDIR|$RESULTSDIR|" -e "s/LOGDIR/$LOGDIR/" witnesslint-validate.xml > witnesslint-validate-tmp.xml - -# Run validation -# witnesslint -cd /mnt/goblint-svcomp/benchexec/tools/witnesslint -benchexec --read-only-dir / --overlay-dir . --hidden-dir /home --outputpath $RESULTSDIR --numOfThreads $VALIDATEPARALLEL $MYBENCHDIR/witnesslint-validate-tmp.xml - -# Merge witness validation results -cd $RESULTSDIR -python3 /mnt/goblint-svcomp/benchexec/benchexec/contrib/mergeBenchmarkSets.py goblint*.results.!(*merged*).xml.bz2 witnesslint-validate-tmp.*.results.*.xml.bz2 - -# Generate table with merged results and witness validation results -sed -e "s/LOGDIR/$LOGDIR/" $MYBENCHDIR/table-generator-lint.xml > table-generator.xml -table-generator -x table-generator.xml - -# Decompress all tool outputs for table HTML links -unzip -o goblint*.logfiles.zip -unzip -o witnesslint-validate-tmp.*.logfiles.zip \ No newline at end of file diff --git a/sv-comp/my-bench-sv-comp/goblint-lint.xml b/sv-comp/my-bench-sv-comp/goblint-lint.xml deleted file mode 100644 index 8cae0a2c69..0000000000 --- a/sv-comp/my-bench-sv-comp/goblint-lint.xml +++ /dev/null @@ -1,68 +0,0 @@ - - - - - - **.graphml - - - - - - - - - - - - - - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/SoftwareSystems-DeviceDriversLinux64-ReachSafety.set - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/properties/unreach-call.prp - - - - diff --git a/sv-comp/my-bench-sv-comp/goblint.sh b/sv-comp/my-bench-sv-comp/goblint.sh deleted file mode 100755 index eaf74350de..0000000000 --- a/sv-comp/my-bench-sv-comp/goblint.sh +++ /dev/null @@ -1,63 +0,0 @@ -#!/bin/bash - -shopt -s extglob - -MYBENCHDIR=/mnt/goblint-svcomp/benchexec/my-bench-sv-comp -RESULTSDIR=/mnt/goblint-svcomp/benchexec/results/new-results32-overflow -GOBLINTPARALLEL=15 -VALIDATEPARALLEL=4 # not enough memory for more - -mkdir $RESULTSDIR - -# Run verification -cd /mnt/goblint-svcomp/sv-comp/goblint -# read-only and overlay dirs for Value too large for defined data type workaround -benchexec --read-only-dir / --overlay-dir . --hidden-dir /home --outputpath $RESULTSDIR --numOfThreads $GOBLINTPARALLEL $MYBENCHDIR/goblint.xml - -# Extract witness directory -cd $RESULTSDIR -LOGDIR=`echo goblint.*.files` -echo $LOGDIR - -# Construct validation XMLs -cd $MYBENCHDIR -# witnesslint -sed -e "s|RESULTSDIR|$RESULTSDIR|" -e "s/LOGDIR/$LOGDIR/" witnesslint-validate2.xml > witnesslint-validate2-tmp.xml -# CPAChecker -# sed -e "s|RESULTSDIR|$RESULTSDIR|" -e "s/LOGDIR/$LOGDIR/" cpa-validate-correctness.xml > cpa-validate-correctness-tmp.xml -# sed -e "s|RESULTSDIR|$RESULTSDIR|" -e "s/LOGDIR/$LOGDIR/" cpa-validate-violation.xml > cpa-validate-violation-tmp.xml -# Ultimate -sed -e "s|RESULTSDIR|$RESULTSDIR|" -e "s/LOGDIR/$LOGDIR/" uautomizer-validate-correctness.xml > uautomizer-validate-correctness-tmp.xml -sed -e "s|RESULTSDIR|$RESULTSDIR|" -e "s/LOGDIR/$LOGDIR/" uautomizer-validate-violation.xml > uautomizer-validate-violation-tmp.xml - -# Run validation -# witnesslint -cd /mnt/goblint-svcomp/benchexec/tools/witnesslint -benchexec --read-only-dir / --overlay-dir . --hidden-dir /home --outputpath $RESULTSDIR --numOfThreads $VALIDATEPARALLEL $MYBENCHDIR/witnesslint-validate2-tmp.xml -# CPAChecker -# cd /home/simmo/benchexec/tools/CPAchecker-1.9-unix -# benchexec --outputpath $RESULTSDIR --numOfThreads $VALIDATEPARALLEL $MYBENCHDIR/cpa-validate-correctness-tmp.xml -# benchexec --outputpath $RESULTSDIR --numOfThreads $VALIDATEPARALLEL $MYBENCHDIR/cpa-validate-violation-tmp.xml -# Ultimate -cd /mnt/goblint-svcomp/benchexec/tools/UAutomizer-linux -benchexec --read-only-dir / --overlay-dir . --hidden-dir /home --outputpath $RESULTSDIR --numOfThreads $VALIDATEPARALLEL $MYBENCHDIR/uautomizer-validate-correctness-tmp.xml -benchexec --read-only-dir / --overlay-dir . --hidden-dir /home --outputpath $RESULTSDIR --numOfThreads $VALIDATEPARALLEL $MYBENCHDIR/uautomizer-validate-violation-tmp.xml - -# Merge witness validation results -cd $RESULTSDIR -# python3 /mnt/goblint-svcomp/benchexec/benchexec/contrib/mergeBenchmarkSets.py goblint.*.results.!(*merged*).xml.bz2 cpa-validate-correctness-tmp.*.results.*.xml.bz2 cpa-validate-violation-tmp.*.results.*.xml.bz2 uautomizer-validate-correctness-tmp.*.results.*.xml.bz2 uautomizer-validate-violation-tmp.*.results.*.xml.bz2 -# python3 /mnt/goblint-svcomp/benchexec/benchexec/contrib/mergeBenchmarkSets.py goblint.*.results.!(*merged*).xml.bz2 uautomizer-validate-correctness-tmp.*.results.*.xml.bz2 uautomizer-validate-violation-tmp.*.results.*.xml.bz2 witnesslint-validate2-tmp.*.results.*.xml.bz2 -python3 /mnt/goblint-svcomp/benchexec/benchexec/contrib/mergeBenchmarkSets.py goblint.*.results.*no-overflow.xml.bz2 uautomizer-validate-correctness-tmp.*.results.*no-overflow.xml.bz2 uautomizer-validate-violation-tmp.*.results.*no-overflow.xml.bz2 witnesslint-validate2-tmp.*.results.*no-overflow.xml.bz2 - -# Generate table with merged results and witness validation results -# table-generator goblint.*.results.*.xml.bz2.merged.xml.bz2 cpa-validate-correctness-tmp.*.results.*.xml.bz2 cpa-validate-violation-tmp.*.results.*.xml.bz2 uautomizer-validate-correctness-tmp.*.results.*.xml.bz2 uautomizer-validate-violation-tmp.*.results.*.xml.bz2 -sed -e "s/LOGDIR/$LOGDIR/" $MYBENCHDIR/table-generator-witness.xml > table-generator.xml -table-generator -x table-generator.xml - -# Decompress all tool outputs for table HTML links -unzip -o goblint.*.logfiles.zip -# unzip -o cpa-validate-correctness-tmp.*.logfiles.zip -# unzip -o cpa-validate-violation-tmp.*.logfiles.zip -unzip -o uautomizer-validate-correctness-tmp.*.logfiles.zip -unzip -o uautomizer-validate-violation-tmp.*.logfiles.zip -unzip -o witnesslint-validate2-tmp.*.logfiles.zip \ No newline at end of file diff --git a/sv-comp/my-bench-sv-comp/goblint.xml b/sv-comp/my-bench-sv-comp/goblint.xml deleted file mode 100644 index c5773f3569..0000000000 --- a/sv-comp/my-bench-sv-comp/goblint.xml +++ /dev/null @@ -1,38 +0,0 @@ - - - - - - **.graphml - - - - - - - - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/NoOverflows-BitVectors.set - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/properties/no-overflow.prp - - - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/NoOverflows-Other.set - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/properties/no-overflow.prp - - - - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/SoftwareSystems-BusyBox-NoOverflows.set - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/properties/no-overflow.prp - - - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/SoftwareSystems-uthash-NoOverflows.set - /mnt/goblint-svcomp/benchexec/sv-benchmarks/c/properties/no-overflow.prp - - - - - diff --git a/sv-comp/my-bench-sv-comp/table-generator-all-fast.xml b/sv-comp/my-bench-sv-comp/table-generator-all-fast.xml deleted file mode 100644 index c9b9932390..0000000000 --- a/sv-comp/my-bench-sv-comp/table-generator-all-fast.xml +++ /dev/null @@ -1,17 +0,0 @@ - - - - - - - - - - - - - - - - -
diff --git a/sv-comp/my-bench-sv-comp/table-generator-data-race.xml b/sv-comp/my-bench-sv-comp/table-generator-data-race.xml deleted file mode 100644 index 28410d1805..0000000000 --- a/sv-comp/my-bench-sv-comp/table-generator-data-race.xml +++ /dev/null @@ -1,13 +0,0 @@ - - - - - - - - - - - - -
diff --git a/sv-comp/my-bench-sv-comp/table-generator-lint.xml b/sv-comp/my-bench-sv-comp/table-generator-lint.xml deleted file mode 100644 index 6ca64dc84e..0000000000 --- a/sv-comp/my-bench-sv-comp/table-generator-lint.xml +++ /dev/null @@ -1,16 +0,0 @@ - - - - - - - - - witness - - - - - - -
diff --git a/sv-comp/my-bench-sv-comp/table-generator-witness.xml b/sv-comp/my-bench-sv-comp/table-generator-witness.xml deleted file mode 100644 index 876c08d392..0000000000 --- a/sv-comp/my-bench-sv-comp/table-generator-witness.xml +++ /dev/null @@ -1,20 +0,0 @@ - - - - - - - - - witness - - - - - - - - - - -
diff --git a/sv-comp/my-bench-sv-comp/uautomizer-validate-correctness.xml b/sv-comp/my-bench-sv-comp/uautomizer-validate-correctness.xml deleted file mode 100644 index efb0861775..0000000000 --- a/sv-comp/my-bench-sv-comp/uautomizer-validate-correctness.xml +++ /dev/null @@ -1,33 +0,0 @@ - - - - - **.graphml - - diff --git a/sv-comp/my-bench-sv-comp/uautomizer-validate-violation.xml b/sv-comp/my-bench-sv-comp/uautomizer-validate-violation.xml deleted file mode 100644 index fdf61b1bab..0000000000 --- a/sv-comp/my-bench-sv-comp/uautomizer-validate-violation.xml +++ /dev/null @@ -1,32 +0,0 @@ - - - - - **.graphml - - diff --git a/sv-comp/my-bench-sv-comp/witnesslint-validate.xml b/sv-comp/my-bench-sv-comp/witnesslint-validate.xml deleted file mode 100644 index 96a41ef731..0000000000 --- a/sv-comp/my-bench-sv-comp/witnesslint-validate.xml +++ /dev/null @@ -1,17 +0,0 @@ - - - - - diff --git a/sv-comp/my-bench-sv-comp/witnesslint-validate2.xml b/sv-comp/my-bench-sv-comp/witnesslint-validate2.xml deleted file mode 100644 index 475bc9846e..0000000000 --- a/sv-comp/my-bench-sv-comp/witnesslint-validate2.xml +++ /dev/null @@ -1,31 +0,0 @@ - - - - - diff --git a/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.c b/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.c new file mode 100644 index 0000000000..94c0f3efeb --- /dev/null +++ b/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.c @@ -0,0 +1,16 @@ +// PARAM: --enable allglobs --set ana.activated[+] threadJoins +#include +#include + +void *t_benign(void *arg) { + return NULL; +} + +int main() { + rand(); + pthread_t id; + pthread_create(&id, NULL, t_benign, NULL); + pthread_join(id, NULL); + rand(); + return 0; +} \ No newline at end of file diff --git a/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.t b/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.t new file mode 100644 index 0000000000..64413bae36 --- /dev/null +++ b/tests/regression/00-sanity/52-thread-unsafe-libfuns-single-thread.t @@ -0,0 +1,5 @@ + $ goblint --enable allglobs --set ana.activated[+] threadJoins 52-thread-unsafe-libfuns-single-thread.c + [Info][Deadcode] Logical lines of code (LLoC) summary: + live: 8 + dead: 0 + total lines: 8 diff --git a/tests/regression/04-mutex/49-type-invariants.t b/tests/regression/04-mutex/49-type-invariants.t index 4b8118eec1..b6c43d21bc 100644 --- a/tests/regression/04-mutex/49-type-invariants.t +++ b/tests/regression/04-mutex/49-type-invariants.t @@ -16,8 +16,8 @@ total lines: 7 [Info][Unsound] Write to unknown address: privatization is unsound. (49-type-invariants.c:21:3-21:21) [Info][Imprecise] INVALIDATING ALL GLOBALS! (49-type-invariants.c:21:3-21:21) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(s, NoOffset)) (49-type-invariants.c:21:3-21:21) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (49-type-invariants.c:21:3-21:21) + [Info][Imprecise] Invalidating expressions: & s (49-type-invariants.c:21:3-21:21) + [Info][Imprecise] Invalidating expressions: & tmp (49-type-invariants.c:21:3-21:21) [Error][Imprecise][Unsound] Function definition missing for getS (49-type-invariants.c:21:3-21:21) [Error][Imprecise][Unsound] Function definition missing @@ -39,7 +39,7 @@ total lines: 7 [Info][Unsound] Write to unknown address: privatization is unsound. (49-type-invariants.c:21:3-21:21) [Info][Imprecise] INVALIDATING ALL GLOBALS! (49-type-invariants.c:21:3-21:21) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(s, NoOffset)) (49-type-invariants.c:21:3-21:21) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (49-type-invariants.c:21:3-21:21) + [Info][Imprecise] Invalidating expressions: & s (49-type-invariants.c:21:3-21:21) + [Info][Imprecise] Invalidating expressions: & tmp (49-type-invariants.c:21:3-21:21) [Error][Imprecise][Unsound] Function definition missing for getS (49-type-invariants.c:21:3-21:21) [Error][Imprecise][Unsound] Function definition missing diff --git a/tests/regression/04-mutex/77-type-nested-fields.t b/tests/regression/04-mutex/77-type-nested-fields.t index 68d9cdb779..0ecf051578 100644 --- a/tests/regression/04-mutex/77-type-nested-fields.t +++ b/tests/regression/04-mutex/77-type-nested-fields.t @@ -18,9 +18,9 @@ [Info][Unsound] Write to unknown address: privatization is unsound. (77-type-nested-fields.c:31:3-31:20) [Info][Unsound] Write to unknown address: privatization is unsound. (77-type-nested-fields.c:38:3-38:22) [Info][Imprecise] INVALIDATING ALL GLOBALS! (77-type-nested-fields.c:31:3-31:20) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (77-type-nested-fields.c:31:3-31:20) + [Info][Imprecise] Invalidating expressions: & tmp (77-type-nested-fields.c:31:3-31:20) [Info][Imprecise] INVALIDATING ALL GLOBALS! (77-type-nested-fields.c:38:3-38:22) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (77-type-nested-fields.c:38:3-38:22) + [Info][Imprecise] Invalidating expressions: & tmp (77-type-nested-fields.c:38:3-38:22) [Error][Imprecise][Unsound] Function definition missing for getS (77-type-nested-fields.c:31:3-31:20) [Error][Imprecise][Unsound] Function definition missing for getT (77-type-nested-fields.c:38:3-38:22) [Error][Imprecise][Unsound] Function definition missing diff --git a/tests/regression/04-mutex/79-type-nested-fields-deep1.t b/tests/regression/04-mutex/79-type-nested-fields-deep1.t index 85f7bfb709..611a70a7c3 100644 --- a/tests/regression/04-mutex/79-type-nested-fields-deep1.t +++ b/tests/regression/04-mutex/79-type-nested-fields-deep1.t @@ -18,9 +18,9 @@ [Info][Unsound] Write to unknown address: privatization is unsound. (79-type-nested-fields-deep1.c:36:3-36:20) [Info][Unsound] Write to unknown address: privatization is unsound. (79-type-nested-fields-deep1.c:43:3-43:24) [Info][Imprecise] INVALIDATING ALL GLOBALS! (79-type-nested-fields-deep1.c:36:3-36:20) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (79-type-nested-fields-deep1.c:36:3-36:20) + [Info][Imprecise] Invalidating expressions: & tmp (79-type-nested-fields-deep1.c:36:3-36:20) [Info][Imprecise] INVALIDATING ALL GLOBALS! (79-type-nested-fields-deep1.c:43:3-43:24) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (79-type-nested-fields-deep1.c:43:3-43:24) + [Info][Imprecise] Invalidating expressions: & tmp (79-type-nested-fields-deep1.c:43:3-43:24) [Error][Imprecise][Unsound] Function definition missing for getS (79-type-nested-fields-deep1.c:36:3-36:20) [Error][Imprecise][Unsound] Function definition missing for getU (79-type-nested-fields-deep1.c:43:3-43:24) [Error][Imprecise][Unsound] Function definition missing diff --git a/tests/regression/04-mutex/80-type-nested-fields-deep2.t b/tests/regression/04-mutex/80-type-nested-fields-deep2.t index a2e9e2ab15..7ddbdc4fd7 100644 --- a/tests/regression/04-mutex/80-type-nested-fields-deep2.t +++ b/tests/regression/04-mutex/80-type-nested-fields-deep2.t @@ -18,9 +18,9 @@ [Info][Unsound] Write to unknown address: privatization is unsound. (80-type-nested-fields-deep2.c:36:3-36:22) [Info][Unsound] Write to unknown address: privatization is unsound. (80-type-nested-fields-deep2.c:43:3-43:24) [Info][Imprecise] INVALIDATING ALL GLOBALS! (80-type-nested-fields-deep2.c:36:3-36:22) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (80-type-nested-fields-deep2.c:36:3-36:22) + [Info][Imprecise] Invalidating expressions: & tmp (80-type-nested-fields-deep2.c:36:3-36:22) [Info][Imprecise] INVALIDATING ALL GLOBALS! (80-type-nested-fields-deep2.c:43:3-43:24) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (80-type-nested-fields-deep2.c:43:3-43:24) + [Info][Imprecise] Invalidating expressions: & tmp (80-type-nested-fields-deep2.c:43:3-43:24) [Error][Imprecise][Unsound] Function definition missing for getT (80-type-nested-fields-deep2.c:36:3-36:22) [Error][Imprecise][Unsound] Function definition missing for getU (80-type-nested-fields-deep2.c:43:3-43:24) [Error][Imprecise][Unsound] Function definition missing diff --git a/tests/regression/04-mutex/90-distribute-fields-type-1.t b/tests/regression/04-mutex/90-distribute-fields-type-1.t index a3b5faf083..587e943b36 100644 --- a/tests/regression/04-mutex/90-distribute-fields-type-1.t +++ b/tests/regression/04-mutex/90-distribute-fields-type-1.t @@ -20,9 +20,9 @@ [Info][Unsound] Write to unknown address: privatization is unsound. (90-distribute-fields-type-1.c:31:3-31:20) [Info][Unsound] Write to unknown address: privatization is unsound. (90-distribute-fields-type-1.c:39:3-39:17) [Info][Imprecise] INVALIDATING ALL GLOBALS! (90-distribute-fields-type-1.c:31:3-31:20) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (90-distribute-fields-type-1.c:31:3-31:20) + [Info][Imprecise] Invalidating expressions: & tmp (90-distribute-fields-type-1.c:31:3-31:20) [Info][Imprecise] INVALIDATING ALL GLOBALS! (90-distribute-fields-type-1.c:39:3-39:17) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (90-distribute-fields-type-1.c:39:3-39:17) + [Info][Imprecise] Invalidating expressions: & tmp (90-distribute-fields-type-1.c:39:3-39:17) [Error][Imprecise][Unsound] Function definition missing for getS (90-distribute-fields-type-1.c:31:3-31:20) [Error][Imprecise][Unsound] Function definition missing for getT (90-distribute-fields-type-1.c:39:3-39:17) [Error][Imprecise][Unsound] Function definition missing diff --git a/tests/regression/04-mutex/91-distribute-fields-type-2.t b/tests/regression/04-mutex/91-distribute-fields-type-2.t index 5773245114..afb01fdced 100644 --- a/tests/regression/04-mutex/91-distribute-fields-type-2.t +++ b/tests/regression/04-mutex/91-distribute-fields-type-2.t @@ -20,9 +20,9 @@ [Info][Unsound] Write to unknown address: privatization is unsound. (91-distribute-fields-type-2.c:32:3-32:17) [Info][Unsound] Write to unknown address: privatization is unsound. (91-distribute-fields-type-2.c:40:3-40:17) [Info][Imprecise] INVALIDATING ALL GLOBALS! (91-distribute-fields-type-2.c:32:3-32:17) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (91-distribute-fields-type-2.c:32:3-32:17) + [Info][Imprecise] Invalidating expressions: & tmp (91-distribute-fields-type-2.c:32:3-32:17) [Info][Imprecise] INVALIDATING ALL GLOBALS! (91-distribute-fields-type-2.c:40:3-40:17) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (91-distribute-fields-type-2.c:40:3-40:17) + [Info][Imprecise] Invalidating expressions: & tmp (91-distribute-fields-type-2.c:40:3-40:17) [Error][Imprecise][Unsound] Function definition missing for getS (91-distribute-fields-type-2.c:32:3-32:17) [Error][Imprecise][Unsound] Function definition missing for getT (91-distribute-fields-type-2.c:40:3-40:17) [Error][Imprecise][Unsound] Function definition missing diff --git a/tests/regression/04-mutex/92-distribute-fields-type-deep.t b/tests/regression/04-mutex/92-distribute-fields-type-deep.t index 798374d63c..1748b245e2 100644 --- a/tests/regression/04-mutex/92-distribute-fields-type-deep.t +++ b/tests/regression/04-mutex/92-distribute-fields-type-deep.t @@ -20,9 +20,9 @@ [Info][Unsound] Write to unknown address: privatization is unsound. (92-distribute-fields-type-deep.c:36:3-36:20) [Info][Unsound] Write to unknown address: privatization is unsound. (92-distribute-fields-type-deep.c:44:3-44:17) [Info][Imprecise] INVALIDATING ALL GLOBALS! (92-distribute-fields-type-deep.c:36:3-36:20) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (92-distribute-fields-type-deep.c:36:3-36:20) + [Info][Imprecise] Invalidating expressions: & tmp (92-distribute-fields-type-deep.c:36:3-36:20) [Info][Imprecise] INVALIDATING ALL GLOBALS! (92-distribute-fields-type-deep.c:44:3-44:17) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (92-distribute-fields-type-deep.c:44:3-44:17) + [Info][Imprecise] Invalidating expressions: & tmp (92-distribute-fields-type-deep.c:44:3-44:17) [Error][Imprecise][Unsound] Function definition missing for getS (92-distribute-fields-type-deep.c:36:3-36:20) [Error][Imprecise][Unsound] Function definition missing for getU (92-distribute-fields-type-deep.c:44:3-44:17) [Error][Imprecise][Unsound] Function definition missing diff --git a/tests/regression/04-mutex/93-distribute-fields-type-global.t b/tests/regression/04-mutex/93-distribute-fields-type-global.t index 07999854ff..50c72aa289 100644 --- a/tests/regression/04-mutex/93-distribute-fields-type-global.t +++ b/tests/regression/04-mutex/93-distribute-fields-type-global.t @@ -18,7 +18,7 @@ total lines: 7 [Info][Unsound] Write to unknown address: privatization is unsound. (93-distribute-fields-type-global.c:13:3-13:29) [Info][Imprecise] INVALIDATING ALL GLOBALS! (93-distribute-fields-type-global.c:13:3-13:29) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(s, NoOffset)) (93-distribute-fields-type-global.c:13:3-13:29) - [Info][Imprecise] Invalidating expressions: AddrOf(Var(tmp, NoOffset)) (93-distribute-fields-type-global.c:13:3-13:29) + [Info][Imprecise] Invalidating expressions: & s (93-distribute-fields-type-global.c:13:3-13:29) + [Info][Imprecise] Invalidating expressions: & tmp (93-distribute-fields-type-global.c:13:3-13:29) [Error][Imprecise][Unsound] Function definition missing for getS (93-distribute-fields-type-global.c:13:3-13:29) [Error][Imprecise][Unsound] Function definition missing diff --git a/tests/regression/18-file/01-ok.c b/tests/regression/18-file/01-ok.c deleted file mode 100644 index 5c1f21ff1c..0000000000 --- a/tests/regression/18-file/01-ok.c +++ /dev/null @@ -1,12 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp; - fp = fopen("test.txt", "a"); - fprintf(fp, "Testing...\n"); - fclose(fp); -} - -// All ok! diff --git a/tests/regression/18-file/02-function.c b/tests/regression/18-file/02-function.c deleted file mode 100644 index fc3157c264..0000000000 --- a/tests/regression/18-file/02-function.c +++ /dev/null @@ -1,17 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -void f(){ - fp = fopen("test.txt", "a"); -} - -int main(){ - f(); - fprintf(fp, "Testing...\n"); - fclose(fp); -} - -// All ok! diff --git a/tests/regression/18-file/03-if-close.c b/tests/regression/18-file/03-if-close.c deleted file mode 100644 index b2bf1ebe97..0000000000 --- a/tests/regression/18-file/03-if-close.c +++ /dev/null @@ -1,15 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - int b; - fp = fopen("test.txt", "a"); // WARN: MAYBE file is never closed - - fprintf(fp, "Testing...\n"); - - if (b) - fclose(fp); -} // WARN: MAYBE unclosed files: fp diff --git a/tests/regression/18-file/04-no-open.c b/tests/regression/18-file/04-no-open.c deleted file mode 100644 index 70683f3852..0000000000 --- a/tests/regression/18-file/04-no-open.c +++ /dev/null @@ -1,10 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - fprintf(fp, "Testing...\n"); // WARN: writing to unopened file handle fp - fclose(fp); // WARN: closeing unopened file handle fp -} diff --git a/tests/regression/18-file/05-open-mode.c b/tests/regression/18-file/05-open-mode.c deleted file mode 100644 index 77326d7a70..0000000000 --- a/tests/regression/18-file/05-open-mode.c +++ /dev/null @@ -1,11 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - fp = fopen("test.txt", "r"); - fprintf(fp, "Testing...\n"); // WARN: writing to read-only file handle fp - fclose(fp); -} diff --git a/tests/regression/18-file/06-2open.c b/tests/regression/18-file/06-2open.c deleted file mode 100644 index 2826c2f1dc..0000000000 --- a/tests/regression/18-file/06-2open.c +++ /dev/null @@ -1,12 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - fp = fopen("test1.txt", "a"); // WARN: file is never closed - fp = fopen("test2.txt", "a"); // WARN: overwriting still opened file handle fp - fprintf(fp, "Testing...\n"); - fclose(fp); -} // WARN: unclosed files: fp diff --git a/tests/regression/18-file/07-2close.c b/tests/regression/18-file/07-2close.c deleted file mode 100644 index 0545bf9814..0000000000 --- a/tests/regression/18-file/07-2close.c +++ /dev/null @@ -1,11 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp; - fp = fopen("test.txt", "a"); - fprintf(fp, "Testing...\n"); - fclose(fp); - fclose(fp); // WARN: closeing already closed file handle fp -} diff --git a/tests/regression/18-file/08-var-reuse.c b/tests/regression/18-file/08-var-reuse.c deleted file mode 100644 index 1caa238517..0000000000 --- a/tests/regression/18-file/08-var-reuse.c +++ /dev/null @@ -1,15 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp; - fp = fopen("test.txt", "a"); - fprintf(fp, "Testing...\n"); - fclose(fp); - fp = fopen("test2.txt", "a"); - fprintf(fp, "Testing...\n"); - fclose(fp); -} - -// All ok! diff --git a/tests/regression/18-file/09-inf-loop-no-close.c b/tests/regression/18-file/09-inf-loop-no-close.c deleted file mode 100644 index e9563ef195..0000000000 --- a/tests/regression/18-file/09-inf-loop-no-close.c +++ /dev/null @@ -1,17 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - int i; - fp = fopen("test.txt", "a"); // WARN: file is never closed - - while (i){ - fprintf(fp, "Testing...\n"); - i++; - } - - //fclose(fp); -} // WARN: unclosed files: fp diff --git a/tests/regression/18-file/10-inf-loop-ok.c b/tests/regression/18-file/10-inf-loop-ok.c deleted file mode 100644 index d88fde272e..0000000000 --- a/tests/regression/18-file/10-inf-loop-ok.c +++ /dev/null @@ -1,19 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - int i; - fp = fopen("test.txt", "a"); - - while (i){ - fprintf(fp, "Testing...\n"); - i++; - } - - fclose(fp); -} - -// All ok. diff --git a/tests/regression/18-file/11-2if.c b/tests/regression/18-file/11-2if.c deleted file mode 100644 index e24fec6e46..0000000000 --- a/tests/regression/18-file/11-2if.c +++ /dev/null @@ -1,18 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - int b; - fp = fopen("test.txt", "a"); // WARN: MAYBE file is never closed - - if (b) - fclose(fp); - - fprintf(fp, "Testing...\n"); // WARN: MAYBE writing to closed file handle fp - - if (!b) - fclose(fp); // WARN: MAYBE closeing already closed file handle fp -} // WARN: MAYBE unclosed files: fp diff --git a/tests/regression/18-file/12-2close-if.c b/tests/regression/18-file/12-2close-if.c deleted file mode 100644 index 4934b33114..0000000000 --- a/tests/regression/18-file/12-2close-if.c +++ /dev/null @@ -1,15 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp; - int b; - fp = fopen("test.txt", "a"); - fprintf(fp, "Testing...\n"); - - if (b) - fclose(fp); - - fclose(fp); // WARN: MAYBE closeing already closed file handle fp -} diff --git a/tests/regression/18-file/13-ptr-arith-ok.c b/tests/regression/18-file/13-ptr-arith-ok.c deleted file mode 100644 index f707110957..0000000000 --- a/tests/regression/18-file/13-ptr-arith-ok.c +++ /dev/null @@ -1,16 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp; - fp = fopen("test.txt", "a"); // WARN: MAYBE file is never closed - fprintf(fp, "Testing...\n"); - - fp++; // WARN: changed pointer fp (no longer safe) - fp--; // WARN: changed pointer fp (no longer safe) - - fclose(fp); // WARN: MAYBE closeing already closed file handle fp -} // WARN: MAYBE unclosed files: fp - -// OPT: All ok! diff --git a/tests/regression/18-file/14-ptr-arith-close.c b/tests/regression/18-file/14-ptr-arith-close.c deleted file mode 100644 index 3f9cd21ee2..0000000000 --- a/tests/regression/18-file/14-ptr-arith-close.c +++ /dev/null @@ -1,13 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp; - fp = fopen("test.txt", "a"); // WARN: MAYBE file is never closed - fprintf(fp, "Testing...\n"); - - fp++; // WARN: changed pointer fp (no longer safe) - - fclose(fp); // WARN: MAYBE closeing already closed file handle fp -} // WARN: MAYBE unclosed files: fp diff --git a/tests/regression/18-file/15-var-switch.c b/tests/regression/18-file/15-var-switch.c deleted file mode 100644 index d7f74b85db..0000000000 --- a/tests/regression/18-file/15-var-switch.c +++ /dev/null @@ -1,18 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp1; - fp1 = fopen("test.txt", "a"); - fprintf(fp1, "Testing...\n"); - - FILE *fp2; - fp2 = fopen("test.txt", "a"); // WARN: file is never closed - fprintf(fp2, "Testing...\n"); - - fp2 = fp1; - - fclose(fp1); - fclose(fp2); // WARN: closeing already closed file handle fp2 -} // WARN: unclosed files: fp2 diff --git a/tests/regression/18-file/16-var-reuse-close.c b/tests/regression/18-file/16-var-reuse-close.c deleted file mode 100644 index cb1fb5fd22..0000000000 --- a/tests/regression/18-file/16-var-reuse-close.c +++ /dev/null @@ -1,14 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp; - fp = fopen("test.txt", "a"); - fprintf(fp, "Testing...\n"); - fclose(fp); - - fp = fopen("test.txt", "a"); // WARN: file is never closed - fprintf(fp, "Testing...\n"); - // fclose(fp); -} // WARN: unclosed files: fp diff --git a/tests/regression/18-file/17-myfopen.c b/tests/regression/18-file/17-myfopen.c deleted file mode 100644 index 3e005c6e70..0000000000 --- a/tests/regression/18-file/17-myfopen.c +++ /dev/null @@ -1,21 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - - -FILE* myfopen(){ - // FILE *fp_tmp = fopen("test.txt", "a"); // local! - return fopen("test.txt", "a"); -} - -int main(){ - FILE *fp1; - FILE *fp2; - fp1 = myfopen(); - fp2 = myfopen(); // WARN: file is never closed - - fprintf(fp1, "Testing...\n"); - fclose(fp1); - fprintf(fp2, "Testing...\n"); - // fclose(fp2); -} // WARN: unclosed files: fp2 diff --git a/tests/regression/18-file/18-myfopen-arg.c b/tests/regression/18-file/18-myfopen-arg.c deleted file mode 100644 index 5d98db4c53..0000000000 --- a/tests/regression/18-file/18-myfopen-arg.c +++ /dev/null @@ -1,20 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - - -FILE* myfopen(char* f){ - return fopen(f, "a"); -} - -int main(){ - FILE *fp1; - FILE *fp2; - fp1 = myfopen("test1.txt"); - fp2 = myfopen("test2.txt"); // WARN: file is never closed - - fprintf(fp1, "Testing...\n"); - fclose(fp1); - fprintf(fp2, "Testing...\n"); - // fclose(fp2); -} // WARN: unclosed files: fp2 diff --git a/tests/regression/18-file/19-if-close-else.c b/tests/regression/18-file/19-if-close-else.c deleted file mode 100644 index 049e8454b4..0000000000 --- a/tests/regression/18-file/19-if-close-else.c +++ /dev/null @@ -1,17 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - int b; - fp = fopen("test.txt", "a"); - - if (b) - fclose(fp); - else - fprintf(fp, "Testing...\n"); - - fclose(fp); // WARN: MAYBE closeing already closed file handle fp -} diff --git a/tests/regression/18-file/20-loop-close.c b/tests/regression/18-file/20-loop-close.c deleted file mode 100644 index 981248c152..0000000000 --- a/tests/regression/18-file/20-loop-close.c +++ /dev/null @@ -1,18 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - int i; - fp = fopen("test.txt", "a"); // WARN: MAYBE file is never closed - - while (i){ // May closed (11, 3), open(test.txt, Write) (7, 3) - fprintf(fp, "Testing...\n"); // WARN: MAYBE writing to closed file handle fp - fclose(fp); // WARN: MAYBE closeing already closed file handle fp - i++; - } - // why: fp -> Must open(test.txt, Write) (7, 3) - // -> because loop wouldn't exit? -} // WARN: MAYBE unclosed files: fp diff --git a/tests/regression/18-file/21-for-i.c b/tests/regression/18-file/21-for-i.c deleted file mode 100644 index e41bb9b005..0000000000 --- a/tests/regression/18-file/21-for-i.c +++ /dev/null @@ -1,26 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE *fp; - -int main(){ - int i; - fp = fopen("test.txt", "w"); // WARN: MAYBE file is never closed - - for(i=1; i<10; i++){ // join - // i -> Unknown int - if(i%2){ - // i -> Unknown int - // fprintf(fp, "Testing...%s\n", i); // Segmentation fault! - // actually shouldn't warn because open and close are always alternating... - fprintf(fp, "Testing...%i\n", i); // WARN: MAYBE writing to closed file handle fp - fclose(fp); // WARN: MAYBE closeing already closed file handle fp - }else{ - fp = fopen("test.txt", "a"); // WARN: MAYBE file is never closed - } - // why no join? - } - // fp opened or closed? (last i=9 -> open) - // widening -> Warn: might be unclosed -} // WARN: MAYBE unclosed files: fp diff --git a/tests/regression/18-file/22-f_int.c b/tests/regression/18-file/22-f_int.c deleted file mode 100644 index f0376fc5a9..0000000000 --- a/tests/regression/18-file/22-f_int.c +++ /dev/null @@ -1,13 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int f(int x){ - return 2*x; -} - -int main(){ - int a = 1; - a = f(2); - return 0; -} diff --git a/tests/regression/18-file/23-f_str.c b/tests/regression/18-file/23-f_str.c deleted file mode 100644 index 81224d2e72..0000000000 --- a/tests/regression/18-file/23-f_str.c +++ /dev/null @@ -1,13 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -char* f(char* x){ - return x; -} - -int main(){ - char* a = "foo"; - a = f("bar"); - return 0; -} diff --git a/tests/regression/18-file/24-f_wstr.c b/tests/regression/18-file/24-f_wstr.c deleted file mode 100644 index 2379c1f718..0000000000 --- a/tests/regression/18-file/24-f_wstr.c +++ /dev/null @@ -1,14 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include -#include - -wchar_t* f(wchar_t* x){ - return x; -} - -int main(){ - wchar_t* a = L"foo"; - a = f(L"bar"); - return 0; -} diff --git a/tests/regression/18-file/25-mem-ok.c b/tests/regression/18-file/25-mem-ok.c deleted file mode 100644 index 00ba189b8d..0000000000 --- a/tests/regression/18-file/25-mem-ok.c +++ /dev/null @@ -1,29 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp[3]; - // Array -> varinfo with index-offset - fp[1] = fopen("test.txt", "a"); - fprintf(fp[1], "Testing...\n"); - fclose(fp[1]); - - - struct foo { - int i; - FILE *fp; - } bar; - // Struct -> varinfo with field-offset - bar.fp = fopen("test.txt", "a"); - fprintf(bar.fp, "Testing...\n"); - fclose(bar.fp); - - - // Pointer -> Mem exp - *(fp+2) = fopen("test.txt", "a"); - fprintf(*(fp+2), "Testing...\n"); - fclose(*(fp+2)); -} - -// All ok! diff --git a/tests/regression/18-file/26-open-error-ok.c b/tests/regression/18-file/26-open-error-ok.c deleted file mode 100644 index 5cf3aaf7bb..0000000000 --- a/tests/regression/18-file/26-open-error-ok.c +++ /dev/null @@ -1,15 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main (){ - FILE *fp; - fp = fopen("test.txt", "w"); - - if(fp!=NULL){ - fprintf(fp, "Testing..."); - fclose(fp); - } -} - -// All ok! diff --git a/tests/regression/18-file/27-open-error.c b/tests/regression/18-file/27-open-error.c deleted file mode 100644 index bd3048208f..0000000000 --- a/tests/regression/18-file/27-open-error.c +++ /dev/null @@ -1,13 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main (){ - FILE *fp; - fp = fopen("test.txt", "w"); // WARN: MAYBE file is never closed - - if(fp==NULL){ - fprintf(fp, "Testing..."); // WARN: writing to unopened file handle fp - fclose(fp); // WARN: closeing unopened file handle fp - } -} // WARN: MAYBE unclosed files: fp diff --git a/tests/regression/18-file/28-multiple-exits.c b/tests/regression/18-file/28-multiple-exits.c deleted file mode 100644 index 04fa5abab0..0000000000 --- a/tests/regression/18-file/28-multiple-exits.c +++ /dev/null @@ -1,14 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp; - fp = fopen("test.txt", "a"); // WARN: MAYBE file is never closed - fprintf(fp, "Testing...\n"); - int b; - if(b) - return 1; // WARN: unclosed files: fp - fclose(fp); - return 0; -} diff --git a/tests/regression/18-file/29-alias-global.c b/tests/regression/18-file/29-alias-global.c deleted file mode 100644 index 17b94748c0..0000000000 --- a/tests/regression/18-file/29-alias-global.c +++ /dev/null @@ -1,22 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE* fp; -FILE* myfopen(char* f){ - fp = fopen(f, "a"); - return fp; -} - -int main(){ - FILE *fp1; - FILE *fp2; - fp1 = myfopen("test1.txt"); - fp2 = myfopen("test2.txt"); - fprintf(fp1, "Testing...\n"); - fclose(fp1); - fprintf(fp2, "Testing...\n"); - fclose(fp2); -} - -// All ok! diff --git a/tests/regression/18-file/30-ptr-of-ptr.c b/tests/regression/18-file/30-ptr-of-ptr.c deleted file mode 100644 index 5a8d1f97a9..0000000000 --- a/tests/regression/18-file/30-ptr-of-ptr.c +++ /dev/null @@ -1,14 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp1; - fp1 = fopen("test.txt", "a"); - FILE **fp2; - - fp2 = &fp1; - - fclose(fp1); - fclose(*fp2); // WARN: closeing already closed file handle fp1 -} diff --git a/tests/regression/18-file/31-var-reuse-fun.c b/tests/regression/18-file/31-var-reuse-fun.c deleted file mode 100644 index 9c0ccb16a2..0000000000 --- a/tests/regression/18-file/31-var-reuse-fun.c +++ /dev/null @@ -1,16 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -FILE* myfopen(char* f){ - FILE* fp; - fp = fopen(f, "a"); - return fp; -} - -int main(){ - FILE *fp; - fp = fopen("test1.txt", "a"); // WARN: file is never closed - fp = myfopen("test2.txt"); // WARN: overwriting still opened file handle fp - fclose(fp); -} // WARN: unclosed files: fp diff --git a/tests/regression/18-file/32-multi-ptr-close.c b/tests/regression/18-file/32-multi-ptr-close.c deleted file mode 100644 index e252d563a5..0000000000 --- a/tests/regression/18-file/32-multi-ptr-close.c +++ /dev/null @@ -1,25 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp1; - fp1 = fopen("test1.txt", "a"); - fprintf(fp1, "Testing...\n"); - - FILE *fp2; - fp2 = fopen("test2.txt", "a"); - fprintf(fp2, "Testing...\n"); - - FILE **fp; - int b; - if(b){ - fp = &fp1; - }else{ - fp = &fp2; - } - - fclose(*fp); - fclose(fp1); // WARN: MAYBE closeing already closed file handle fp1 - fclose(fp2); // WARN: MAYBE closeing already closed file handle fp2 -} diff --git a/tests/regression/18-file/33-multi-ptr-open.c b/tests/regression/18-file/33-multi-ptr-open.c deleted file mode 100644 index b3cfa0ade4..0000000000 --- a/tests/regression/18-file/33-multi-ptr-open.c +++ /dev/null @@ -1,23 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp1; - fp1 = fopen("test1.txt", "a"); // WARN: MAYBE file is never closed - - FILE *fp2; - fp2 = fopen("test2.txt", "r"); // WARN: MAYBE file is never closed - - FILE **fp; - int b; - if(b){ - fp = &fp1; - }else{ - fp = &fp2; - } - - fprintf(*fp, "Testing...\n"); // WARN: MAYBE writing to read-only file handle fp - - fclose(*fp); -} // WARN: MAYBE unclosed files: fp1, fp2 diff --git a/tests/regression/18-file/34-multi-alias-close.c b/tests/regression/18-file/34-multi-alias-close.c deleted file mode 100644 index 0ebb9ddd30..0000000000 --- a/tests/regression/18-file/34-multi-alias-close.c +++ /dev/null @@ -1,25 +0,0 @@ -// SKIP PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp1; - fp1 = fopen("test1.txt", "a"); - fprintf(fp1, "Testing...\n"); - - FILE *fp2; - fp2 = fopen("test2.txt", "a"); - fprintf(fp2, "Testing...\n"); - - FILE *fp; - int b; - if(b){ - fp = fp1; - }else{ - fp = fp2; - } - - fclose(fp); - fclose(fp1); // WARN: MAYBE closeing already closed file handle fp1 - fclose(fp2); // WARN: MAYBE closeing already closed file handle fp2 -} diff --git a/tests/regression/18-file/35-multi-alias-open.c b/tests/regression/18-file/35-multi-alias-open.c deleted file mode 100644 index 21a4a9cca6..0000000000 --- a/tests/regression/18-file/35-multi-alias-open.c +++ /dev/null @@ -1,23 +0,0 @@ -// SKIP PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp1; - fp1 = fopen("test1.txt", "a"); // WARN: MAYBE file is never closed - - FILE *fp2; - fp2 = fopen("test2.txt", "r"); // WARN: MAYBE file is never closed - - FILE *fp; - int b; - if(b){ - fp = fp1; - }else{ - fp = fp2; - } - - fprintf(fp, "Testing...\n"); // WARN: MAYBE writing to read-only file handle fp - - fclose(fp); -} // WARN: MAYBE unclosed files: fp1, fp2 diff --git a/tests/regression/18-file/36-fun-ptr.c b/tests/regression/18-file/36-fun-ptr.c deleted file mode 100644 index 4f70bf7382..0000000000 --- a/tests/regression/18-file/36-fun-ptr.c +++ /dev/null @@ -1,14 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp; - FILE* (*f)(const char *, const char*); - f = fopen; - fp = f("test.txt", "a"); - fprintf(fp, "Testing...\n"); - fclose(fp); -} - -// All ok! diff --git a/tests/regression/18-file/37-var-switch-alias.c b/tests/regression/18-file/37-var-switch-alias.c deleted file mode 100644 index 5dfde5a2d9..0000000000 --- a/tests/regression/18-file/37-var-switch-alias.c +++ /dev/null @@ -1,18 +0,0 @@ -// PARAM: --set ana.activated[+] "'file'" --enable ana.file.optimistic - -#include - -int main(){ - FILE *fp1; - fp1 = fopen("test.txt", "a"); - fprintf(fp1, "Testing...\n"); - - FILE *fp2; - fp2 = fopen("test.txt", "a"); // WARN: file is never closed - fprintf(fp2, "Testing...\n"); - - fp2 = fp1; - - fclose(fp2); - fclose(fp1); // WARN: closeing already closed file handle fp1 -} // WARN: unclosed files: fp2 diff --git a/tests/regression/18-file/README.md b/tests/regression/18-file/README.md new file mode 100644 index 0000000000..0e93e175c6 --- /dev/null +++ b/tests/regression/18-file/README.md @@ -0,0 +1,2 @@ +The file analysis has been removed from recent Goblint versions, please use Release 2.3.0 +Folder is left in place to avoid renumbering all tests diff --git a/tests/regression/18-file/file.c b/tests/regression/18-file/file.c deleted file mode 100644 index fc2ebe1699..0000000000 --- a/tests/regression/18-file/file.c +++ /dev/null @@ -1,44 +0,0 @@ -#include - -int main(){ - - // no errors - FILE *fp; - fp = fopen("test.txt", "a"); - if(fp!=0) { - fprintf(fp, "Testing...\n"); - fclose(fp); - } - - // missing fopen -> compiles, but leads to Segmentation fault - FILE *fp2; - // fp2 = fopen("test.txt", "a"); - fprintf(fp2, "Testing...\n"); // WARN - fclose(fp2); // WARN - - // writing to a read-only file -> doesn't do anything - FILE *fp3; - fp3 = fopen("test.txt", "r"); - fprintf(fp3, "Testing...\n"); // (WARN) - fclose(fp3); - - // accessing closed file -> write doesn't do anything - FILE *fp4; - fp4 = fopen("test.txt", "a"); - fclose(fp4); - fprintf(fp4, "Testing...\n"); // WARN - - // missing fclose - FILE *fp5; - fp5 = fopen("test.txt", "a"); // WARN - fprintf(fp5, "Testing...\n"); - - // missing assignment to file handle - fopen("test.txt", "a"); // WARN - - - // bad style: - // opening file but not doing anything - - return 0; // WARN about all unclosed files -} \ No newline at end of file diff --git a/tests/regression/18-file/file.optimistic.spec b/tests/regression/18-file/file.optimistic.spec deleted file mode 100644 index d42e2217b7..0000000000 --- a/tests/regression/18-file/file.optimistic.spec +++ /dev/null @@ -1,34 +0,0 @@ -w1 "file handle is not saved!" -w2 "closeing unopened file handle $" -w3 "writing to unopened file handle $" -w4 "writing to read-only file handle $" -w5 "closeing already closed file handle $" -w6 "writing to closed file handle $" -w7 "overwriting still opened file handle $" -w8 "unrecognized file open mode for file handle $" - -1 -> w1 fopen(_, _) -1 -> w2 fclose($fp) -1 -> w3 fprintf($fp, _) -1 -> open_read $fp = fopen(path, "r") -1 -> open_write $fp = fopen(path, r"[wa]") // see OCaml doc for details (e.g. \\| for alternatives) -1 -> w8 $fp = fopen(path, _) - -open_read -> w4 fprintf($fp, _) - -open_read -w7>> 1 $fp = fopen(path, _) -open_write -w7>> 1 $fp = fopen(path, _) - -open_read -> closed fclose($fp) -open_write -> closed fclose($fp) - -closed -> w5 fclose($fp) -closed -> w6 fprintf($fp, _) -closed ->> 1 _ // let state 1 handle the rest - -// setup which states are end states -1 -> end _ -closed -> end _ -// warning for all entries that are not in an end state -_end "file is never closed" -_END "unclosed files: $" \ No newline at end of file diff --git a/tests/regression/18-file/file.spec b/tests/regression/18-file/file.spec deleted file mode 100644 index aeb747abfd..0000000000 --- a/tests/regression/18-file/file.spec +++ /dev/null @@ -1,57 +0,0 @@ -w1 "file handle is not saved!" -w2 "closeing unopened file handle $" -w3 "writing to unopened file handle $" -w4 "writing to read-only file handle $" -w5 "closeing already closed file handle $" -w6 "writing to closed file handle $" -w7 "overwriting still opened file handle $" -w8 "unrecognized file open mode for file handle $" - -// TODO later add fputs and stuff -1 -> w1 fopen(_, _) -1 -> w2 fclose($fp) -1 -> w3 fprintf($fp, _) -//1 -> open_read $fp = fopen(path, "r") -//1 -> open_write $fp = fopen(path, r"[wa]") // see OCaml doc for details (e.g. \\| for alternatives) -//1 -> w8 $fp = fopen(path, _) - -// go to unchecked states first -1 -> u_open_read $fp = fopen(path, "r") -1 -> u_open_write $fp = fopen(path, r"[wa]") -1 -> w8 $fp = fopen(path, _) -// once branch(exp, tv) is matched, return dom with 1. arg (lval = exp) and true/false -// forwarding from branch is not possible (would need an extra map for storing states) -> ignore it -// warnings are also ignored -// then in branch take out lval, check exp and do the transition to a checked state -u_open_read -> 1 branch($key==0, true) -u_open_read -> open_read branch($key==0, false) -u_open_write -> 1 branch($key==0, true) -u_open_write -> open_write branch($key==0, false) - -// alternative: forward everything. Problem: saving arguments of call (special_fn -> branch -> special_fn) -// 1 ->> open_check $fp = fopen(path, _) -// open_check ->> 1 branch($fp==0, true) -// open_check ->> open branch($fp==0, false) -// open -> open_read $fp = fopen(path, "r") -// open -> open_write $fp = fopen(path, "[wa]") -// open -> w8 $fp = fopen(path, _) - -open_read -> w4 fprintf($fp, _) -// open_write -> open_write fprintf($fp, _) // not needed, but changes loc - -open_read -w7>> 1 $fp = fopen(path, _) -open_write -w7>> 1 $fp = fopen(path, _) - -open_read -> closed fclose($fp) -open_write -> closed fclose($fp) - -closed -> w5 fclose($fp) -closed -> w6 fprintf($fp, _) -closed ->> 1 _ // let state 1 handle the rest - -// setup which states are end states -1 -> end _ -closed -> end _ -// warning for all entries that are not in an end state -_end "file is never closed" -_END "unclosed files: $" \ No newline at end of file diff --git a/tests/regression/19-spec/01-malloc-free.c b/tests/regression/19-spec/01-malloc-free.c deleted file mode 100644 index 43ee527dba..0000000000 --- a/tests/regression/19-spec/01-malloc-free.c +++ /dev/null @@ -1,19 +0,0 @@ -#include -#include - -int main(){ - int *ip; - //*ip = 5; // segfault - //printf("%i", *ip); // segfault - ip = malloc(sizeof(int)); // assume malloc never fails - - // do stuff - //*ip = 5; - - free(ip); - //free(ip); // crash: double free or corruption - *ip = 5; // undefined but no crash - printf("%i", *ip); // undefined but printed 5 - ip = NULL; // make sure the pointer is not used anymore - *ip = 5; // segfault -} diff --git a/tests/regression/19-spec/02-mutex_rc.c b/tests/regression/19-spec/02-mutex_rc.c deleted file mode 100644 index 82c1642a93..0000000000 --- a/tests/regression/19-spec/02-mutex_rc.c +++ /dev/null @@ -1,23 +0,0 @@ -#include -#include - -int myglobal; -pthread_mutex_t mutex1 = PTHREAD_MUTEX_INITIALIZER; -pthread_mutex_t mutex2 = PTHREAD_MUTEX_INITIALIZER; - -void *t_fun(void *arg) { - pthread_mutex_lock(&mutex1); - myglobal=myglobal+1; // RACE! - pthread_mutex_unlock(&mutex1); - return NULL; -} - -int main(void) { - pthread_t id; - pthread_create(&id, NULL, t_fun, NULL); - pthread_mutex_lock(&mutex2); - myglobal=myglobal+1; // RACE! - pthread_mutex_unlock(&mutex2); - pthread_join (id, NULL); - return 0; -} diff --git a/tests/regression/19-spec/README.md b/tests/regression/19-spec/README.md new file mode 100644 index 0000000000..d7e3ae3c8e --- /dev/null +++ b/tests/regression/19-spec/README.md @@ -0,0 +1,2 @@ +The spec analysis has been removed from recent Goblint versions, please use Release 2.3.0 +Folder is left in place to avoid renumbering all tests diff --git a/tests/regression/19-spec/malloc.optimistic.spec b/tests/regression/19-spec/malloc.optimistic.spec deleted file mode 100644 index 860c573814..0000000000 --- a/tests/regression/19-spec/malloc.optimistic.spec +++ /dev/null @@ -1,23 +0,0 @@ -w1 "pointer is not saved [leak]" -w2 "freeing unallocated pointer $ [segfault?]" -w3 "writing to unallocated pointer $ [segfault?]" -w4 "overwriting unfreed pointer $ [leak]" -w5 "freeing already freed pointer $ [double free!]" - -1 -w1> 1 malloc(_) -1 -w2> 1 free($p) -1 -w3> 1 *$p = _ -1 -> alloc $p = malloc(_) // TODO does compiler check size? - -alloc -w4> alloc $p = malloc(_) -alloc -> freed free($p) - -freed -w5> freed free($p) -freed ->> 1 _ // let state 1 handle the rest - -// setup which states are end states -1 -> end _ -freed -> end _ -// warning for all entries that are not in an end state -_end "pointer is never freed" -_END "unfreed pointers: $" \ No newline at end of file diff --git a/tests/regression/19-spec/malloc.spec b/tests/regression/19-spec/malloc.spec deleted file mode 100644 index 9f09430051..0000000000 --- a/tests/regression/19-spec/malloc.spec +++ /dev/null @@ -1,26 +0,0 @@ -w1 "pointer is not saved [leak]" -w2 "freeing unallocated pointer $ [segfault?]" -w3 "writing to unallocated pointer $ [segfault?]" -w4 "overwriting unfreed pointer $ [leak]" -w5 "freeing already freed pointer $ [double free!]" - -1 -w1> 1 malloc(_) -1 -w2> 1 free($p) -1 -w3> 1 *$p = _ -1 -> u_alloc $p = malloc(_) - -u_alloc -> 1 branch($key==0, true) -u_alloc -> alloc branch($key==0, false) - -alloc -w4> alloc $p = malloc(_) -alloc -> freed free($p) - -freed -w5> freed free($p) -freed ->> 1 _ // let state 1 handle the rest - -// setup which states are end states -1 -> end _ -freed -> end _ -// warning for all entries that are not in an end state -_end "pointer is never freed" -_END "unfreed pointers: $" \ No newline at end of file diff --git a/tests/regression/19-spec/mutex-lock.spec b/tests/regression/19-spec/mutex-lock.spec deleted file mode 100644 index 1ec8264078..0000000000 --- a/tests/regression/19-spec/mutex-lock.spec +++ /dev/null @@ -1,31 +0,0 @@ -w1 "unlocking not locked mutex" -w2 "locking already locked mutex" - -1 -w1> 1 pthread_mutex_unlock($p) -1 -> lock pthread_mutex_lock($p) - -lock -w2> lock pthread_mutex_lock($p) -lock -> 1 pthread_mutex_unlock($p) - -// setup which states are end states -1 -> end _ -// warning for all entries that are not in an end state -_end "mutex is never unlocked" -_END "locked mutexes: $" - - - -//w1 "joining not created thread" -//w2 "overwriting id of already created thread" -// -//1 -w1> 1 pthread_join ($p, _) -//1 -> created pthread_create($p, _, _, _) -// -//created -w2> created pthread_create($p, _, _, _) -//created -> 1 pthread_join ($p, _) -// -//// setup which states are end states -//1 -> end _ -//// warning for all entries that are not in an end state -//_end "thread is never joined" -//_END "unjoined threads: $" \ No newline at end of file diff --git a/tests/regression/29-svcomp/32-no-ov.t b/tests/regression/29-svcomp/32-no-ov.t index 85eb90c185..1dc22ed89e 100644 --- a/tests/regression/29-svcomp/32-no-ov.t +++ b/tests/regression/29-svcomp/32-no-ov.t @@ -9,8 +9,3 @@ dead: 0 total lines: 3 SV-COMP result: true - [Info][Race] Memory locations race summary: - safe: 1 - vulnerable: 0 - unsafe: 0 - total memory locations: 1 diff --git a/tests/regression/39-signed-overflows/06-abs.c b/tests/regression/39-signed-overflows/06-abs.c index e56cc9ff7d..1323434cbc 100644 --- a/tests/regression/39-signed-overflows/06-abs.c +++ b/tests/regression/39-signed-overflows/06-abs.c @@ -17,6 +17,13 @@ int main() { __goblint_check(-100 <= data); int result = data * data; //NOWARN } + + if(abs(data) - 1 <= 99) + { + __goblint_check(data <= 100); + __goblint_check(-100 <= data); + int result = data * data; //NOWARN + } } return 8; } \ No newline at end of file diff --git a/tests/regression/51-threadjoins/07-trivial-unknowntid.c b/tests/regression/51-threadjoins/07-trivial-unknowntid.c new file mode 100644 index 0000000000..2797291ee3 --- /dev/null +++ b/tests/regression/51-threadjoins/07-trivial-unknowntid.c @@ -0,0 +1,34 @@ +//PARAM: --set ana.activated[+] threadJoins +#include + +int g = 10; +int h = 10; +pthread_mutex_t A = PTHREAD_MUTEX_INITIALIZER; + +void *t_fun(void *arg) { + g++; // RACE! + return NULL; +} + +void *t_benign(void *arg) { + h++; // NORACE + pthread_t id2; + pthread_create(&id2, NULL, t_fun, NULL); + foo(&id2); + pthread_join(id2, NULL); + return NULL; +} + +int main(void) { + int t; + + pthread_t id2; + pthread_create(&id2, NULL, t_benign, NULL); + pthread_join(id2, NULL); + // t_benign and t_fun should be in here + + g++; // RACE! + h++; // NORACE + + return 0; +} diff --git a/tests/regression/51-threadjoins/07-klever-multiple.c b/tests/regression/51-threadjoins/08-klever-multiple.c similarity index 100% rename from tests/regression/51-threadjoins/07-klever-multiple.c rename to tests/regression/51-threadjoins/08-klever-multiple.c diff --git a/tests/regression/73-strings/01-string_literals.c b/tests/regression/73-strings/01-string_literals.c index 42086e07b6..4a43590bf5 100644 --- a/tests/regression/73-strings/01-string_literals.c +++ b/tests/regression/73-strings/01-string_literals.c @@ -2,6 +2,7 @@ #include #include +#include char* hello_world() { return "Hello world!"; @@ -10,28 +11,49 @@ char* hello_world() { void id(char* s) { char* ptr = NULL; // future usage of cmp should warn: workaround for macOS test #ifdef __APPLE__ - #define ID int i = strcmp(ptr, "trigger warning") + #define ID int i = *ptr #else #define ID strcpy(s, s) #endif ID; // WARN } -int main() { +void example1() { + char* s1 = "bc\0test"; + char* s2 = "bc"; + char* s3; + if (rand()) + s3 = "aabbcc"; + else + s3 = "ebcdf"; + + int i = strcmp(s1, s2); + __goblint_check(i == 0); + + char* s4 = strstr(s3, s1); + __goblint_check(s4 != NULL); + + size_t len = strlen(s4); + __goblint_check(len >= 3); + __goblint_check(len <= 4); + __goblint_check(len == 3); // UNKNOWN! +} + +void example2() { char* s1 = "abcde"; char* s2 = "abcdfg"; char* s3 = hello_world(); + + size_t len = strlen(s1); + __goblint_check(len == 5); - int i = strlen(s1); - __goblint_check(i == 5); - - i = strlen(s2); - __goblint_check(i == 6); + len = strlen(s2); + __goblint_check(len == 6); - i = strlen(s3); - __goblint_check(i == 12); + len = strlen(s3); + __goblint_check(len == 12); - i = strcmp(s1, s2); + int i = strcmp(s1, s2); __goblint_check(i < 0); i = strcmp(s2, "abcdfg"); @@ -70,28 +92,28 @@ int main() { cmp = NULL; // future usage of cmp should warn: workaround for macOS test #ifdef __APPLE__ - #define STRCPY i = strcmp(cmp, "trigger warning") + #define STRCPY i = *cmp #else #define STRCPY strcpy(s1, "hi"); #endif STRCPY; // WARN #ifdef __APPLE__ - #define STRNCPY i = strcmp(cmp, "trigger warning") + #define STRNCPY i = *cmp #else # define STRNCPY strncpy(s1, "hi", 1) #endif STRNCPY; // WARN #ifdef __APPLE__ - #define STRCAT i = strcmp(cmp, "trigger warning") + #define STRCAT i = *cmp #else #define STRCAT strcat(s1, "hi") #endif STRCAT; // WARN #ifdef __APPLE__ - #define STRNCAT i = strcmp(cmp, "trigger warning") + #define STRNCAT i = *cmp #else #define STRNCAT strncat(s1, "hi", 1) #endif @@ -101,13 +123,18 @@ int main() { // do nothing => no warning #else char s4[] = "hello"; - strcpy(s4, s2); // NOWARN + strcpy(s4, s2); // NOWARN -> null byte array domain not enabled strncpy(s4, s3, 2); // NOWARN char s5[13] = "hello"; strcat(s5, " world"); // NOWARN strncat(s5, "! some further text", 1); // NOWARN #endif +} + +int main() { + example1(); + example2(); return 0; } diff --git a/tests/regression/73-strings/02-string_literals_with_null.c b/tests/regression/73-strings/02-string_literals_with_null.c index cc41e9e287..610390701a 100644 --- a/tests/regression/73-strings/02-string_literals_with_null.c +++ b/tests/regression/73-strings/02-string_literals_with_null.c @@ -9,10 +9,10 @@ int main() { char* s3 = "hello world!"; char* s4 = "\0 i am the empty string"; - int i = strlen(s1); - __goblint_check(i == 5); + size_t len = strlen(s1); + __goblint_check(len == 5); - i = strcmp(s1, s2); + int i = strcmp(s1, s2); __goblint_check(i == 0); i = strcmp(s3, s1); diff --git a/tests/regression/73-strings/03-string_basics.c b/tests/regression/73-strings/03-string_basics.c index a9d02d5e8b..e4d6c5c5e4 100644 --- a/tests/regression/73-strings/03-string_basics.c +++ b/tests/regression/73-strings/03-string_basics.c @@ -1,4 +1,4 @@ -// PARAM: --set ana.base.strings.domain disjoint --enable ana.int.interval +// PARAM: --set ana.base.strings.domain disjoint --enable ana.int.interval --enable ana.base.arrays.nullbytes #include #include @@ -13,35 +13,49 @@ void concat_1(char* s, int i) { } int main() { - char* s1 = malloc(40); - strcpy(s1, "hello "); + char s1[40] = "hello "; char s2[] = "world!"; char s3[10] = "abcd"; char s4[20] = "abcdf"; + char* s5 = malloc(40); + strcpy(s5, "hello"); - int i = strlen(s1); - __goblint_check(i == 6); // UNKNOWN + size_t len = strlen(s1); + __goblint_check(len == 6); - i = strlen(s2); - __goblint_check(i == 6); // UNKNOWN + len = strlen(s2); + __goblint_check(len == 6); - i = strlen(s3); - __goblint_check(i == 4); // UNKNOWN + len = strlen(s3); + __goblint_check(len == 4); + + len = strlen(s5); + __goblint_check(len == 5); strcat(s1, s2); - i = strcmp(s1, "hello world!"); + len = strlen(s1); + int i = strcmp(s1, "hello world!"); + __goblint_check(len == 12); __goblint_check(i == 0); // UNKNOWN strcpy(s1, "hi "); + strncpy(s1, s3, 3); // WARN + len = strlen(s1); + __goblint_check(len == 3); + + char tmp[] = "hi "; + len = strlen(tmp); + __goblint_check(len == 3); + strcpy(s1, tmp); strncpy(s1, s3, 3); - i = strlen(s1); - __goblint_check(i == 3); // UNKNOWN + len = strlen(s1); + __goblint_check(len == 3); strcat(s1, "ababcd"); char* cmp = strstr(s1, "bab"); __goblint_check(cmp != NULL); // UNKNOWN - i = strcmp(cmp, "babcd"); // WARN: no check if cmp != NULL (even if it obviously is != NULL) + i = strcmp(cmp, "babcd"); // NOWARN: cmp != NULL __goblint_check(i == 0); // UNKNOWN i = strncmp(s4, s3, 4); @@ -50,15 +64,27 @@ int main() { i = strncmp(s4, s3, 5); __goblint_check(i > 0); // UNKNOWN - strncpy(s1, "", 20); + strncpy(s1, "", 20); // WARN + strcpy(tmp, "\0hi"); + i = strcmp(s1, tmp); + __goblint_check(i == 0); + + char tmp2[] = ""; + strcpy(s1, tmp2); + i = strcmp(s1, tmp2); + __goblint_check(i == 0); + + i = strcmp(s1, tmp); + __goblint_check(i == 0); + concat_1(s1, 30); - i = strlen(s1); - __goblint_check(i == 30); // UNKNOWN + len = strlen(s1); + __goblint_check(len == 30); cmp = strstr(s1, "0"); __goblint_check(cmp == NULL); // UNKNOWN - free(s1); + free(s5); return 0; -} \ No newline at end of file +} diff --git a/tests/regression/73-strings/06-juliet.c b/tests/regression/73-strings/06-juliet.c new file mode 100644 index 0000000000..a198c62948 --- /dev/null +++ b/tests/regression/73-strings/06-juliet.c @@ -0,0 +1,166 @@ +// PARAM: --set ana.base.strings.domain disjoint --enable ana.int.interval --set ana.base.arrays.domain partitioned --enable ana.base.arrays.nullbytes + +#include +#include +#include + +// TODO: tackle memset -> map it to for loop with set for each cell + +int main() { + CWE121_Stack_Based_Buffer_Overflow__src_char_declare_cpy_01_bad(); + CWE126_Buffer_Overread__CWE170_char_loop_01_bad(); + CWE126_Buffer_Overread__CWE170_char_strncpy_01_bad(); + CWE126_Buffer_Overread__char_declare_loop_01_bad(); + CWE571_Expression_Always_True__string_equals_01_bad(); + CWE665_Improper_Initialization__char_cat_01_bad(); + CWE665_Improper_Initialization__char_ncat_11_bad(); + + return 0; +} + +void CWE121_Stack_Based_Buffer_Overflow__src_char_declare_cpy_01_bad() +{ + char * data; + char dataBuffer[100]; + data = dataBuffer; + /* FLAW: Initialize data as a large buffer that is larger than the small buffer used in the sink */ + /* memset(data, 'A', 100-1); // fill with 'A's -- memset not supported currently, replaced with for-loop */ + for (size_t i = 0; i < 100-1; i++) + data[i] = 'A'; + data[100-1] = '\0'; /* null terminate */ + __goblint_check(data[42] == 'A'); + { + char dest[50] = ""; + /* POTENTIAL FLAW: Possible buffer overflow if data is larger than dest */ + strcpy(dest, data); // WARN + } +} + +void CWE126_Buffer_Overread__CWE170_char_loop_01_bad() +{ + { + char src[150], dest[100]; + int i; + /* Initialize src */ + /* memset(src, 'A', 149); */ + for (i = 0; i < 149; i++) + src[i] = 'A'; + src[149] = '\0'; + for(i=0; i < 99; i++) + { + dest[i] = src[i]; + } + /* FLAW: do not explicitly null terminate dest after the loop */ + __goblint_check(dest[42] != '\0'); // UNKNOWN + __goblint_check(dest[99] != '\0'); // UNKNOWN + } +} + +void CWE126_Buffer_Overread__CWE170_char_strncpy_01_bad() +{ + { + char data[150], dest[100]; + /* Initialize data */ + /* memset(data, 'A', 149); */ + for (size_t i = 0; i < 149; i++) + data[i] = 'A'; + data[149] = '\0'; + /* strncpy() does not null terminate if the string in the src buffer is larger than + * the number of characters being copied to the dest buffer */ + strncpy(dest, data, 99); // WARN + /* FLAW: do not explicitly null terminate dest after the use of strncpy() */ + } +} + +void CWE126_Buffer_Overread__char_declare_loop_01_bad() +{ + char * data; + char dataBadBuffer[50]; + char dataGoodBuffer[100]; + /* memset(dataBadBuffer, 'A', 50-1); // fill with 'A's */ + for (size_t i = 0; i < 50-1; i++) + dataBadBuffer[i] = 'A'; + dataBadBuffer[50-1] = '\0'; /* null terminate */ + /* memset(dataGoodBuffer, 'A', 100-1); // fill with 'A's */ + for (size_t i = 0; i < 100-1; i++) + dataGoodBuffer[i] = 'A'; + dataGoodBuffer[100-1] = '\0'; /* null terminate */ + /* FLAW: Set data pointer to a small buffer */ + data = dataBadBuffer; + { + size_t i, destLen; + char dest[100]; + /* memset(dest, 'C', 100-1); */ + for (i = 0; i < 100-1; i++) + dest[i] = 'C'; + dest[100-1] = '\0'; /* null terminate */ + destLen = strlen(dest); + __goblint_check(destLen <= 99); + /* POTENTIAL FLAW: using length of the dest where data + * could be smaller than dest causing buffer overread */ + for (i = 0; i < destLen; i++) + { + dest[i] = data[i]; + } + dest[100-1] = '\0'; + } +} + +void CWE665_Improper_Initialization__char_cat_01_bad() +{ + char * data; + char dataBuffer[100]; + data = dataBuffer; + /* FLAW: Do not initialize data */ + ; /* empty statement needed for some flow variants */ + { + char source[100]; + /* memset(source, 'C', 100-1); // fill with 'C's */ + for (size_t i = 0; i < 100-1; i++) + source[i] = 'C'; + source[100-1] = '\0'; /* null terminate */ + /* POTENTIAL FLAW: If data is not initialized properly, strcat() may not function correctly */ + strcat(data, source); // WARN + } +} + +void CWE571_Expression_Always_True__string_equals_01_bad() +{ + char charString[10] = "true"; + int cmp = strcmp(charString, "true"); + __goblint_check(cmp == 0); // UNKNOWN + + /* FLAW: This expression is always true */ + if (cmp == 0) + { + printf("always prints"); + } +} + +void CWE665_Improper_Initialization__char_ncat_11_bad() +{ + char * data; + char dataBuffer[100]; + data = dataBuffer; + if(rand()) + { + /* FLAW: Do not initialize data */ + ; /* empty statement needed for some flow variants */ + } + { + size_t sourceLen; + char source[100]; + /* memset(source, 'C', 100-1); // fill with 'C's */ + for (size_t i = 0; i < 100-1; i++) + source[i] = 'C'; + source[100-1] = '\0'; /* null terminate */ + sourceLen = strlen(source); + __goblint_check(sourceLen <= 99); + /* POTENTIAL FLAW: If data is not initialized properly, strncat() may not function correctly */ + #ifdef __APPLE__ + ; + #else + strncat(data, source, sourceLen); // NOWARN because sourceLen is not exactly known => array domain not consulted + #endif + } +} diff --git a/tests/regression/73-strings/07-larger_example.c b/tests/regression/73-strings/07-larger_example.c new file mode 100644 index 0000000000..9e9c2985ce --- /dev/null +++ b/tests/regression/73-strings/07-larger_example.c @@ -0,0 +1,41 @@ +// PARAM: --set ana.base.strings.domain disjoint --enable ana.int.interval --enable ana.base.arrays.nullbytes + +#include +#include +#include + +int main() { + char* user; + if (rand()) + user = "Alice"; + else + user = "Bob"; + + if (strcmp(user, "Alice") == 0) + strcpy(user, "++++++++"); // WARN + + __goblint_check(strcmp(user, "Alice") == 0); // UNKNOWN + __goblint_check(strcmp(user, "Bob") == 0); // UNKNOWN + __goblint_check(strcmp(user, "Eve") != 0); + + char pwd_gen[20]; + for (size_t i = 12; i < 20; i++) + pwd_gen[i] = (char) (rand() % 123); + + char* p1 = "hello"; + char* p2 = "12345"; + strcat(pwd_gen, p1); // WARN + strncpy(pwd_gen, p2, 6); + __goblint_check(pwd_gen[5] == '\0'); + strncat(pwd_gen, p1, 4); + __goblint_check(pwd_gen[5] != '\0'); + + int cmp = strcmp(pwd_gen, "12345hello"); + __goblint_check(cmp != 0); + + char* pwd = strstr(pwd_gen, p2); + size_t pwd_len = strlen(pwd_gen); + __goblint_check(pwd_len == 9); + + return 0; +} diff --git a/tests/regression/73-strings/08-cursed.c b/tests/regression/73-strings/08-cursed.c new file mode 100644 index 0000000000..836b744da5 --- /dev/null +++ b/tests/regression/73-strings/08-cursed.c @@ -0,0 +1,31 @@ +// PARAM: --set ana.base.strings.domain disjoint --enable ana.int.interval --enable ana.base.arrays.nullbytes --set ana.malloc.unique_address_count 1 + +#include +#include +#include + +int main() { + // These should behave identically + char s1[40]; + char* s5 = malloc(40); + char* s6 = malloc(40); + + strcpy(s1, "hello"); + strcpy(s5, "hello"); + + int len = strlen(s5); + __goblint_check(len == 5); + + int len2 = strlen(s1); + __goblint_check(len2 == 5); + + strcpy(s6,s5); + int len3 = strlen(s6); + __goblint_check(len3 == 5); + + strcpy(s5, "badabingbadaboom"); + int len2 = strlen(s5); + __goblint_check(len2 == 16); + + return 0; +} diff --git a/tests/regression/73-strings/09-malloc.c b/tests/regression/73-strings/09-malloc.c new file mode 100644 index 0000000000..126872c682 --- /dev/null +++ b/tests/regression/73-strings/09-malloc.c @@ -0,0 +1,16 @@ +// PARAM: --set ana.base.strings.domain disjoint --enable ana.int.interval --enable ana.base.arrays.nullbytes +#include +#include +#include + +int main () { + char* s1 = malloc(50); + s1[0] = 'a'; + + char s2[50]; + s2[0] = 'a'; + + // Use size_t to avoid integer warnings hiding the lack of string warnings + size_t len1 = strlen(s1); //TODO + size_t len2 = strlen(s2); //WARN +} diff --git a/tests/regression/73-strings/10-char_arrays.c b/tests/regression/73-strings/10-char_arrays.c new file mode 100644 index 0000000000..2454f2811b --- /dev/null +++ b/tests/regression/73-strings/10-char_arrays.c @@ -0,0 +1,383 @@ +// PARAM: --set ana.base.strings.domain disjoint --enable ana.int.interval --enable ana.base.arrays.nullbytes + +#include +#include +#include + +int main() { + example1(); + example2(); + example3(); + example4(); + example5(); + example6(); + example7(); + example8(); + example9(); + example10(); + example11(); + example12(); + example13(); + example14(); + example15(); + example16(); + example17(); + example18(); + + return 0; +} + +void example1() { + char s1[] = "user1_"; // must and may null at 6 and 7 + char s2[] = "pwd:\0abc"; // must and may null at 4 and 8 + char s3[20]; // no must nulls, all may nulls + + strcpy(s3, s1); // must null at 6, may nulls starting from 6 + + if (rand()) { + s2[4] = ' '; + strncat(s3, s2, 10); // must null at 14, may nulls starting from 14 + } else + strcat(s3, s2); // must null at 10, may nulls starting from 10 + + // s3: no must nulls, may nulls starting from 10 + + s3[14] = '\0'; // must null at 14, may nulls starting from 10 + + size_t len = strlen(s3); + __goblint_check(len >= 10); + __goblint_check(len <= 14); + __goblint_check(len == 10); // UNKNOWN! + + strcpy(s1, s3); // WARN +} + +void example2() { + char s1[42]; + char s2[20] = "testing"; // must null at 7, may null starting from 7 + + strcpy(s1, s2); // must null and may null at 7 + + size_t len = strlen(s1); + __goblint_check(len == 7); + + strcat(s1, s2); // "testingtesting" + + len = strlen(s1); + __goblint_check(len == 14); +} + +void example3() { + char s1[42]; + char s2[20] = "testing"; // must null at 7, may null starting from 7 + + if (rand() == 42) + s2[1] = '\0'; + + strcpy(s1, s2); // may null at 1 and starting from 7 + + size_t len = strlen(s1); // WARN: no must null in s1 + __goblint_check(len >= 1); + __goblint_check(len <= 7); // UNKNOWN + + strcpy(s2, s1); // WARN: no must null in s1 +} + +void example4() { + char s1[5] = "abc\0d"; // must and may null at 3 + char s2[] = "a"; // must and may null at 1 + + strcpy(s1, s2); // "a\0c\0d" + + size_t len = strlen(s1); + __goblint_check(len == 1); + + s1[1] = 'b'; // "abc\0d" + len = strlen(s1); + __goblint_check(len == 3); +} + +void example5() { + char s1[7] = "hello!"; // must and may null at 6 + char s2[8] = "goblint"; // must and may null at 7 + + strncpy(s1, s2, 7); // WARN + + size_t len = strlen(s1); // WARN + __goblint_check(len >= 7); // no null byte in s1 +} + +void example6() { + char s1[42] = "a string, i.e. null-terminated char array"; // must and may null at 42 + for (int i = 0; i < 42; i += 3) { + if (rand() != 42) + s1[i] = '\0'; + } + s1[41] = '.'; // no must nulls, only may null a 0, 3, 6... + + char s2[42] = "actually containing some text"; // must and may null at 29 + char s3[60] = "text: "; // must and may null at 6 + + strcat(s3, s1); // WARN: no must nulls, may nulls at 6, 9, 12... + + size_t len = strlen(s3); // WARN + __goblint_check(len >= 6); + __goblint_check(len > 6); // UNKNOWN + + strncat(s2, s3, 10); // WARN: no must nulls, may nulls at 35 and 38 + + len = strlen(s2); // WARN + __goblint_check(len >= 35); + __goblint_check(len > 40); // UNKNOWN +} + +void example7() { + char s1[50] = "hello"; // must and may null at 5 + char s2[] = " world!"; // must and may null at 7 + char s3[] = " goblint."; // must and may null at 9 + + if (rand() < 42) + strcat(s1, s2); // "hello world!" -> must and may null at 12 + else + strncat(s1, s3, 8); // "hello goblint" -> must and may null at 13 + + char s4[20]; + strcpy(s4, s1); // WARN: no must nulls, may nulls at 12 and 13 + + size_t len = strlen(s4); + __goblint_check(len >= 12); + __goblint_check(len == 13); // UNKNOWN + + s4[14] = '\0'; // must null at 14, may nulls at 12, 13 and 14 + len = strlen(s4); + __goblint_check(len >= 12); + __goblint_check(len <= 14); + + char s5[20]; + strncpy(s5, s4, 16); // WARN: no must nulls, may nulls at 12, 13, 14, 15... + len = strlen(s5); // WARN + __goblint_check(len >= 12); + __goblint_check(len <= 14); // UNKNOWN + __goblint_check(len < 20); // UNKNOWN +} + +void example8() { + char s1[6] = "abc"; // must and may null at 3 + if (rand() == 42) + s1[5] = '\0'; // must null at 3, may nulls at 3 and 5 + + char s2[] = "hello world"; // must and may null at 11 + + strncpy(s2, s1, 8); // WARN: 8 > size of s1 -- must and may nulls at 3, 4, 5, 6 and 7 + + size_t len = strlen(s2); + __goblint_check(len == 3); + + s2[3] = 'a'; // must and may nulls at 4, 5, 6 and 7 + len = strlen(s2); + __goblint_check(len == 4); + + for (int i = 4; i <= 7; i++) + s2[i] = 'a'; + s2[11] = 'a'; // no must nulls, may nulls at 4, 5, 6 and 7 + + len = strlen(s2); // WARN + __goblint_check(len >= 12); // UNKNOWN: loop transformed to interval + + s2[4] = 'a'; + s2[5] = 'a'; + s2[6] = 'a'; + s2[7] = 'a'; + len = strlen(s2); // WARN: no must nulls and may nulls + __goblint_check(len >= 12); +} + +void example9() { + char empty[] = ""; + char s1[] = "hello world"; // must and may null at 11 + char s2[] = "test"; // must and may null at 4 + + char cmp[50]; + #ifdef __APPLE__ + size_t len = 11; + #else + strcpy(cmp, strstr(s1, empty)); // NOWARN: strstr(s1, empty) != NULL + size_t len = strlen(cmp); + #endif + __goblint_check(len == 11); + + char* cmp_ptr = strstr(s2, s1); + __goblint_check(cmp_ptr == NULL); +} + +void example10() { + char empty1[] = ""; + char empty2[] = "\0 also empty"; + char s1[] = "hi"; + char s2[] = "hello"; + + int i = strcmp(empty1, empty2); + __goblint_check(i == 0); + + i = strcmp(empty1, s1); + __goblint_check(i < 0); + + i = strcmp(s1, empty1); + __goblint_check(i > 0); + + i = strcmp(s1, s2); + __goblint_check(i != 0); + + i = strncmp(s1, s2, 2); + __goblint_check(i != 0); // UNKNOWN + + s1[2] = 'a'; + + i = strcmp(s1, s2); // WARN + __goblint_check(i != 0); // UNKNOWN + + i = strncmp(s1, s2, 10); // WARN + __goblint_check(i != 0); // UNKNOWN +} + +void example11() { + size_t i; + if (rand()) + i = 0; + else + i = 1; + + char s1[50] = "goblint"; // must null at 7, may nulls starting from 7 + __goblint_check(s1[i] != '\0'); + + char s2[6] = "\0\0\0\0\0"; // all must and may nulls + __goblint_check(s2[i] == '\0'); + + strcpy(s1, s2); // must null at 0 and 7, mays nulls at 0 and starting from 7 + __goblint_check(s1[i] == '\0'); // UNKNOWN + + s1[i] = 'a'; // must null at 7, mays nulls at 0 and starting from 7 + + size_t len = strlen(s1); + __goblint_check(len >= 0); + __goblint_check(len > 0); // UNKNOWN + __goblint_check(len <= 7); + + s2[0] = 'a'; // all must and may null >= 1 + __goblint_check(s2[i] == '\0'); // UNKNOWN +} + +void example12() { + char s1[50]; + for (size_t i = 0; i < 50; i++) + s1[i] = '\0'; + __goblint_check(s1[0] == '\0'); // no must null, all may nulls + __goblint_check(s1[1] == '\0'); // known by trivial array domain + + char s2[5]; + s2[0] = 'a'; s2[1] = 'a'; s2[2] = 'a'; s2[3] = 'a'; s2[4] ='a'; + __goblint_check(s2[10] != '\0'); // no must null and may nulls + + strcpy(s1, s2); // WARN: no must nulls, may nulls >= 5 + strcpy(s2, "definite buffer overflow"); // WARN + + s2[4] = '\0'; // must and may null at 4 + + strncpy(s1, s2, 4); // WARN +} + +void example13() { + char s1[10]; // no must null, all may nulls + char s2[10]; // no must null, all may nulls + strncpy(s1, s2, 4); // WARN: no must null, all may nulls + __goblint_check(s1[3] == '\0'); // UNKNOWN + + s1[0] = 'a'; + s1[1] = 'b'; // no must null, may nulls >= 2 + + strcat(s1, s2); // WARN: no must null, may nulls >= 2 + __goblint_check(s1[1] != '\0'); + __goblint_check(s1[2] == '\0'); // UNKNOWN + + int cmp = strncmp(s1, s2, 0); + __goblint_check(cmp == 0); +} + +void example14() { + size_t size; + if (rand()) + size = 15; + else + size = 20; + + char* s = malloc(size); + + strcpy(s, ""); // must null at 0, all may null + + strcat(s, "123456789012345678"); // WARN +} + +example15() { + char* s1 = malloc(8); + strcpy(s1, "goblint"); // must and may null at 7 + + char s2[42] = "static"; // must null at 6, may null >= 6 + + strcat(s2, s1); // must null at 13, may null >= 13 + __goblint_check(s2[12] != '\0'); + __goblint_check(s2[13] == '\0'); + __goblint_check(s2[14] == '\0'); // UNKNOWN + + char* s3 = strstr(s1, s2); + __goblint_check(s3 == NULL); +} + +example16() { + size_t i; + if (rand()) + i = 3; + else + i = 4; + + char s[5] = "abab"; + __goblint_check(s[i] != '\0'); // UNKNOWN + + s[4] = 'a'; + __goblint_check(s[i] != '\0'); + + s[4] = '\0'; + s[i] = '\0'; + __goblint_check(s[4] == '\0'); + __goblint_check(s[3] == '\0'); // UNKNOWN + + s[i] = 'a'; + __goblint_check(s[4] == '\0'); // UNKNOWN +} + +example17() { + char s1[20]; + char s2[10]; + strcat(s1, s2); // WARN + __goblint_check(s1[0] == '\0'); // UNKNOWN + __goblint_check(s1[5] == '\0'); // UNKNOWN + __goblint_check(s1[12] == '\0'); // UNKNOWN +} + +example18() { + char s1[20] = "hello"; + char s2[10] = "world"; + + size_t i; + if (rand()) + i = 1; + else + i = 2; + s1[i] = '\0'; + + strcat(s1, s2); + __goblint_check(s1[1] != '\0'); + __goblint_check(s1[6] == '\0'); // UNKNOWN + __goblint_check(s1[7] == '\0'); // UNKNOWN + __goblint_check(s1[8] != '\0'); // UNKNOWN because might still be uninitialized + __goblint_check(s1[10] == '\0'); // UNKNOWN +} diff --git a/tests/regression/74-invalid_deref/31-multithreaded.c b/tests/regression/74-invalid_deref/31-multithreaded.c new file mode 100644 index 0000000000..8a0c12350b --- /dev/null +++ b/tests/regression/74-invalid_deref/31-multithreaded.c @@ -0,0 +1,21 @@ +//PARAM: --set ana.path_sens[+] threadflag --set ana.activated[+] memOutOfBounds --set ana.base.privatization mutex-meet-tid +#include + +int data; +int *p = &data, *q; +pthread_mutex_t mutex; +void *t_fun(void *arg) { + pthread_mutex_lock(&mutex); + *p = 8; + pthread_mutex_unlock(&mutex); + return ((void *)0); +} +int main() { + pthread_t id; + pthread_create(&id, ((void *)0), t_fun, ((void *)0)); + q = p; + pthread_mutex_lock(&mutex); + *q = 8; //NOWARN + pthread_mutex_unlock(&mutex); + return 0; +} diff --git a/unittest/dune b/unittest/dune index 7313aa964b..036c8d8013 100644 --- a/unittest/dune +++ b/unittest/dune @@ -2,7 +2,7 @@ (test (name mainTest) - (libraries ounit2 qcheck-ounit goblint.lib goblint.sites.dune goblint.build-info.dune) + (libraries ounit2 qcheck-ounit goblint.std goblint.lib goblint.constraint goblint.solver goblint.cdomain.value goblint.sites.dune goblint.build-info.dune) (preprocess (pps ppx_deriving.std ppx_deriving_hash ppx_deriving_yojson)) (flags :standard -linkall)) diff --git a/unittest/solver/solverTest.ml b/unittest/solver/solverTest.ml index 47ec5443ca..4e96266262 100644 --- a/unittest/solver/solverTest.ml +++ b/unittest/solver/solverTest.ml @@ -2,6 +2,8 @@ open Goblint_lib open OUnit2 open GoblintCil open Pretty +open ConstrSys +open Goblint_solver (* variables are strings *) module StringVar = @@ -43,7 +45,7 @@ module ConstrSys = struct | _ -> None let iter_vars _ _ _ _ _ = () - let sys_change _ _ = {Analyses.obsolete = []; delete = []; reluctant = []; restart = []} + let sys_change _ _ = {obsolete = []; delete = []; reluctant = []; restart = []} end module LH = BatHashtbl.Make (ConstrSys.LVar) @@ -55,7 +57,7 @@ struct let should_warn = false let should_save_run = false end -module Solver = Constraints.GlobSolverFromEqSolver (Constraints.EqIncrSolverFromEqSolver (EffectWConEq.Make) (PostSolverArg)) (ConstrSys) (LH) (GH) +module Solver = GlobSolverFromEqSolver (PostSolver.EqIncrSolverFromEqSolver (EffectWConEq.Make) (PostSolverArg)) (ConstrSys) (LH) (GH) let test1 _ = let id x = x in diff --git a/unittest/util/intOpsTest.ml b/unittest/util/intOpsTest.ml index 611f2f546f..b0cb4dc984 100644 --- a/unittest/util/intOpsTest.ml +++ b/unittest/util/intOpsTest.ml @@ -1,5 +1,5 @@ open OUnit2 -open Goblint_lib +open Goblint_std (* If the first operand of a div is negative, Zarith rounds the result away from zero. We thus always transform this into a division with a non-negative first operand. *) @@ -10,13 +10,13 @@ let old_div a b = if Z.lt a Z.zero then Z.neg (Z.ediv (Z.neg a) b) else Z.ediv a let old_rem a b = Z.sub a (Z.mul b (old_div a b)) let test_bigint_div = - QCheck.(Test.make ~name:"div" (pair MyCheck.Arbitrary.big_int MyCheck.Arbitrary.big_int) (fun (x, y) -> + QCheck.(Test.make ~name:"div" (pair GobQCheck.Arbitrary.big_int GobQCheck.Arbitrary.big_int) (fun (x, y) -> assume (Z.compare y Z.zero <> 0); Z.equal (Z.div x y) (old_div x y) )) let test_bigint_rem = - QCheck.(Test.make ~name:"rem" (pair MyCheck.Arbitrary.big_int MyCheck.Arbitrary.big_int) (fun (x, y) -> + QCheck.(Test.make ~name:"rem" (pair GobQCheck.Arbitrary.big_int GobQCheck.Arbitrary.big_int) (fun (x, y) -> assume (Z.compare y Z.zero <> 0); Z.equal (Z.rem x y) (old_rem x y) ))